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

Submitted by Arnaud Charlet on Nov. 23, 2011, 11:25 a.m.

Details

Message ID 20111123112552.GA21389@adacore.com
State New
Headers show

Commit Message

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 hide | download patch | download mbox

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