Patchwork [Ada] Fix check for entry family bounds out of range

login
register
mail settings
Submitter Arnaud Charlet
Date Nov. 23, 2011, 11:25 a.m.
Message ID <20111123112552.GA21389@adacore.com>
Download mbox | patch
Permalink /patch/127268/
State New
Headers show

Comments

Arnaud Charlet - Nov. 23, 2011, 11:25 a.m.
This patch adds code to the semantic analyzer to properly check
that entry family bounds are in range. Previously this check was
done during code expansion, leading to messages posted at the
wrong point, omission of the check in -gnatc mode, and in the
case of task entry families a blow up in the expander.

The following tests compile with the errors shown in
both normal and -gnatc modes.

     1. procedure badentrymsg is
     2.     protected type PT is
     3.       entry Test (Long_Long_Integer)
                          |
        >>> entry family low bound must be >= 0
        >>> entry family high bound must be <= 16#7FFF_FFFF#

     4.         (X : Integer);
     5.     private
     6.         Data : Integer := 0;
     7.     end PT;
     8.
     9.     protected body PT is
    10.       entry Test
    11.         (for I in Long_Long_Integer)
    12.           (X : Integer)
    13.         when True is
    14.         begin
    15.             Data := X;
    16.         end Test;
    17.     end PT;
    18.     PO : PT;
    19. begin
    20.     PO.Test(3)(5);
    21. end;

     1. procedure badtaskentry is
     2.    Data : Integer;
     3.    task type PT is
     4.       entry Test (Long_Long_Integer)
                          |
        >>> entry family low bound must be >= 0
        >>> entry family high bound must be <= 16#7FFF_FFFF#

     5.         (X : Integer);
     6.     end PT;
     7.
     8.    task body PT is
     9.    begin
    10.       accept Test (3) (X : Integer) do
    11.          Data := X;
    12.       end Test;
    13.     end PT;
    14.
    15.     T : PT;
    16. begin
    17.     null;
    18. end;

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-11-23  Robert Dewar  <dewar@adacore.com>

	* sem_ch9.adb (Analyze_Entry_Declaration): Check for entry
	family bounds out of range.

Patch

Index: sem_ch9.adb
===================================================================
--- sem_ch9.adb	(revision 181654)
+++ sem_ch9.adb	(working copy)
@@ -905,6 +905,60 @@ 
          Bad_Predicated_Subtype_Use
            ("subtype& has predicate, not allowed in entry family",
             D_Sdef, Etype (D_Sdef));
+
+         --  Check entry family static bounds outside allowed limits
+
+         --  Note: originally this check was not performed here, but in that
+         --  case the check happens deep in the expander, and the message is
+         --  posted at the wrong location, and omitted in -gnatc mode.
+
+         declare
+            PEI : constant Entity_Id := RTE (RE_Protected_Entry_Index);
+            LB  : constant Uint      := Expr_Value (Type_Low_Bound (PEI));
+            UB  : constant Uint      := Expr_Value (Type_High_Bound (PEI));
+
+            LBR : Node_Id;
+            UBR : Node_Id;
+
+         begin
+            if Nkind (D_Sdef) = N_Range then
+               LBR := Low_Bound (D_Sdef);
+            elsif Is_Entity_Name (D_Sdef)
+              and then Is_Type (Entity (D_Sdef))
+            then
+               LBR := Type_Low_Bound (Entity (D_Sdef));
+            else
+               goto Skip_LB;
+            end if;
+
+            if Is_Static_Expression (LBR)
+              and then Expr_Value (LBR) < LB
+            then
+               Error_Msg_Uint_1 := LB;
+               Error_Msg_N ("entry family low bound must be '>'= ^!", D_Sdef);
+            end if;
+
+            <<Skip_LB>>
+            if Nkind (D_Sdef) = N_Range then
+               UBR := High_Bound (D_Sdef);
+            elsif Is_Entity_Name (D_Sdef)
+              and then Is_Type (Entity (D_Sdef))
+            then
+               UBR := Type_High_Bound (Entity (D_Sdef));
+            else
+               goto Skip_UB;
+            end if;
+
+            if Is_Static_Expression (UBR)
+              and then Expr_Value (UBR) > UB
+            then
+               Error_Msg_Uint_1 := UB;
+               Error_Msg_N ("entry family high bound must be '<'= ^!", D_Sdef);
+            end if;
+
+            <<Skip_UB>>
+            null;
+         end;
       end if;
 
       --  Decorate Def_Id