[multiple changes]

2010-06-21  Thomas Quinot  <quinot@adacore.com>

	* sem_ch9.adb, checks.adb, sem_util.adb, sem_util.ads, sem_res.adb,
	sem_attr.adb (Get_E_First_Or_Last): Use attribute references on E to
	extract bounds, to ensure that we get the proper captured values,
	rather than an expression that may have changed value since the point
	where the subtype was elaborated.
	(Find_Body_Discriminal): New utility subprogram to share code between...
	(Eval_Attribute): For the case of a subtype bound that references a
	discriminant of the current concurrent type, insert appropriate
	discriminal reference.
	(Resolve_Entry.Actual_Index_Type.Actual_Discriminant_Ref): For a
	requeue to an entry in a family in the current task, use corresponding
	body discriminal. 
	(Analyze_Accept_Statement): Rely on expansion of attribute references
	to insert proper discriminal references in range check for entry in
	family.

2010-06-21  Emmanuel Briot  <briot@adacore.com>

	* s-regpat.adb (Compile): Fix handling of big patterns.

2010-06-21  Robert Dewar  <dewar@adacore.com>

	* a-tifiio.adb: Minor reformatting.

From-SVN: r161076

gcc/ada/ChangeLog

+2010-06-21  Thomas Quinot  <quinot@adacore.com>
+
+	* sem_ch9.adb, checks.adb, sem_util.adb, sem_util.ads, sem_res.adb,
+	sem_attr.adb (Get_E_First_Or_Last): Use attribute references on E to
+	extract bounds, to ensure that we get the proper captured values,
+	rather than an expression that may have changed value since the point
+	where the subtype was elaborated.
+	(Find_Body_Discriminal): New utility subprogram to share code between...
+	(Eval_Attribute): For the case of a subtype bound that references a
+	discriminant of the current concurrent type, insert appropriate
+	discriminal reference.
+	(Resolve_Entry.Actual_Index_Type.Actual_Discriminant_Ref): For a
+	requeue to an entry in a family in the current task, use corresponding
+	body discriminal. 
+	(Analyze_Accept_Statement): Rely on expansion of attribute references
+	to insert proper discriminal references in range check for entry in
+	family.
+
+2010-06-21  Emmanuel Briot  <briot@adacore.com>
+
+	* s-regpat.adb (Compile): Fix handling of big patterns.
+
+2010-06-21  Robert Dewar  <dewar@adacore.com>
+
+	* a-tifiio.adb: Minor reformatting.
+
 2010-06-21  Pascal Obry  <obry@adacore.com>
 
 	* prj-nmsc.adb (Search_Directories): Use the non-translated directory

gcc/ada/a-tifiio.adb

@@ -304,7 +304,7 @@ package body Ada.Text_IO.Fixed_IO is
       Fore : Integer;
       Aft  : Field;
       Exp  : Field);
-   --  Actual output function, used internally by all other Put routines
+   --  Actual output function, used internally by all other Put routines.
    --  The formal Fore is an Integer, not a Field, because the routine is
    --  also called from the version of Put that performs I/O to a string,
    --  where the starting position depends on the size of the String, and

gcc/ada/checks.adb

@@ -6249,7 +6249,8 @@ package body Checks is
       --    Expr > Typ'Last
 
       function Get_E_First_Or_Last
-        (E    : Entity_Id;
+        (Loc  : Source_Ptr;
+         E    : Entity_Id;
          Indx : Nat;
          Nam  : Name_Id) return Node_Id;
       --  Returns expression to compute:
@@ -6320,7 +6321,7 @@ package body Checks is
                      Duplicate_Subexpr_No_Checks (Expr)),
                  Right_Opnd =>
                    Convert_To (Base_Type (Typ),
-                               Get_E_First_Or_Last (Typ, 0, Name_First))),
+                               Get_E_First_Or_Last (Loc, Typ, 0, Name_First))),
 
              Right_Opnd =>
                Make_Op_Gt (Loc,
@@ -6330,7 +6331,7 @@ package body Checks is
                  Right_Opnd =>
                    Convert_To
                      (Base_Type (Typ),
-                      Get_E_First_Or_Last (Typ, 0, Name_Last))));
+                      Get_E_First_Or_Last (Loc, Typ, 0, Name_Last))));
       end Discrete_Expr_Cond;
 
       -------------------------
@@ -6368,7 +6369,8 @@ package body Checks is
 
              Right_Opnd =>
                Convert_To
-                 (Base_Type (Typ), Get_E_First_Or_Last (Typ, 0, Name_First)));
+                 (Base_Type (Typ),
+                  Get_E_First_Or_Last (Loc, Typ, 0, Name_First)));
 
          if Base_Type (Typ) = Typ then
             return Left_Opnd;
@@ -6403,7 +6405,7 @@ package body Checks is
              Right_Opnd =>
                Convert_To
                  (Base_Type (Typ),
-                  Get_E_First_Or_Last (Typ, 0, Name_Last)));
+                  Get_E_First_Or_Last (Loc, Typ, 0, Name_Last)));
 
          return Make_Or_Else (Loc, Left_Opnd, Right_Opnd);
       end Discrete_Range_Cond;
@@ -6413,115 +6415,23 @@ package body Checks is
       -------------------------
 
       function Get_E_First_Or_Last
-        (E    : Entity_Id;
+        (Loc  : Source_Ptr;
+         E    : Entity_Id;
          Indx : Nat;
          Nam  : Name_Id) return Node_Id
       is
-         N     : Node_Id;
-         LB    : Node_Id;
-         HB    : Node_Id;
-         Bound : Node_Id;
-
+         Exprs : List_Id;
       begin
-         if Is_Array_Type (E) then
-            N := First_Index (E);
-
-            for J in 2 .. Indx loop
-               Next_Index (N);
-            end loop;
-
-         else
-            N := Scalar_Range (E);
-         end if;
-
-         if Nkind (N) = N_Subtype_Indication then
-            LB := Low_Bound (Range_Expression (Constraint (N)));
-            HB := High_Bound (Range_Expression (Constraint (N)));
-
-         elsif Is_Entity_Name (N) then
-            LB := Type_Low_Bound  (Etype (N));
-            HB := Type_High_Bound (Etype (N));
-
+         if Indx > 0 then
+            Exprs := New_List (Make_Integer_Literal (Loc, UI_From_Int (Indx)));
          else
-            LB := Low_Bound  (N);
-            HB := High_Bound (N);
+            Exprs := No_List;
          end if;
 
-         if Nam = Name_First then
-            Bound := LB;
-         else
-            Bound := HB;
-         end if;
-
-         if Nkind (Bound) = N_Identifier
-           and then Ekind (Entity (Bound)) = E_Discriminant
-         then
-            --  If this is a task discriminant, and we are the body, we must
-            --  retrieve the corresponding body discriminal. This is another
-            --  consequence of the early creation of discriminals, and the
-            --  need to generate constraint checks before their declarations
-            --  are made visible.
-
-            if Is_Concurrent_Record_Type (Scope (Entity (Bound)))  then
-               declare
-                  Tsk : constant Entity_Id :=
-                          Corresponding_Concurrent_Type
-                           (Scope (Entity (Bound)));
-                  Disc : Entity_Id;
-
-               begin
-                  if In_Open_Scopes (Tsk)
-                    and then Has_Completion (Tsk)
-                  then
-                     --  Find discriminant of original task, and use its
-                     --  current discriminal, which is the renaming within
-                     --  the task body.
-
-                     Disc := First_Discriminant (Tsk);
-                     while Present (Disc) loop
-                        if Chars (Disc) = Chars (Entity (Bound)) then
-                           Set_Scope (Discriminal (Disc), Tsk);
-                           return New_Occurrence_Of (Discriminal (Disc), Loc);
-                        end if;
-
-                        Next_Discriminant (Disc);
-                     end loop;
-
-                     --  That loop should always succeed in finding a matching
-                     --  entry and returning. Fatal error if not.
-
-                     raise Program_Error;
-
-                  else
-                     return
-                       New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
-                  end if;
-               end;
-            else
-               return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
-            end if;
-
-         elsif Nkind (Bound) = N_Identifier
-           and then Ekind (Entity (Bound)) = E_In_Parameter
-           and then not Inside_Init_Proc
-         then
-            return Get_Discriminal (E, Bound);
-
-         elsif Nkind (Bound) = N_Integer_Literal then
-            return Make_Integer_Literal (Loc, Intval (Bound));
-
-         --  Case of a bound rewritten to an N_Raise_Constraint_Error node
-         --  because it is an out-of-range value. Duplicate_Subexpr cannot be
-         --  called on this node because an N_Raise_Constraint_Error is not
-         --  side effect free, and we may not assume that we are in the proper
-         --  context to remove side effects on it at the point of reference.
-
-         elsif Nkind (Bound) = N_Raise_Constraint_Error then
-            return New_Copy_Tree (Bound);
-
-         else
-            return Duplicate_Subexpr_No_Checks (Bound);
-         end if;
+         return Make_Attribute_Reference (Loc,
+                  Prefix         => New_Occurrence_Of (E, Loc),
+                  Attribute_Name => Nam,
+                  Expressions    => Exprs);
       end Get_E_First_Or_Last;
 
       -----------------
@@ -6568,13 +6478,17 @@ package body Checks is
            Make_Or_Else (Loc,
              Left_Opnd =>
                Make_Op_Lt (Loc,
-                 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First),
-                 Right_Opnd  => Get_E_First_Or_Last (Typ, Indx, Name_First)),
+                 Left_Opnd   =>
+                   Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_First),
+                 Right_Opnd  =>
+                   Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)),
 
              Right_Opnd =>
                Make_Op_Gt (Loc,
-                 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last),
-                 Right_Opnd  => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
+                 Left_Opnd   =>
+                   Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_Last),
+                 Right_Opnd  =>
+                   Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last)));
       end Range_E_Cond;
 
       ------------------------
@@ -6591,12 +6505,17 @@ package body Checks is
            Make_Or_Else (Loc,
              Left_Opnd =>
                Make_Op_Ne (Loc,
-                 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First),
-                 Right_Opnd  => Get_E_First_Or_Last (Typ, Indx, Name_First)),
+                 Left_Opnd   =>
+                   Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_First),
+                 Right_Opnd  =>
+                   Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)),
+
              Right_Opnd =>
                Make_Op_Ne (Loc,
-                 Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last),
-                 Right_Opnd  => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
+                 Left_Opnd   =>
+                   Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_Last),
+                 Right_Opnd  =>
+                   Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last)));
       end Range_Equal_E_Cond;
 
       ------------------
@@ -6613,13 +6532,17 @@ package body Checks is
            Make_Or_Else (Loc,
              Left_Opnd =>
                Make_Op_Lt (Loc,
-                 Left_Opnd => Get_N_First (Expr, Indx),
-                 Right_Opnd  => Get_E_First_Or_Last (Typ, Indx, Name_First)),
+                 Left_Opnd  =>
+                   Get_N_First (Expr, Indx),
+                 Right_Opnd =>
+                   Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)),
 
              Right_Opnd =>
                Make_Op_Gt (Loc,
-                 Left_Opnd => Get_N_Last (Expr, Indx),
-                 Right_Opnd  => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
+                 Left_Opnd  =>
+                   Get_N_Last (Expr, Indx),
+                 Right_Opnd =>
+                   Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last)));
       end Range_N_Cond;
 
    --  Start of processing for Selected_Range_Checks

gcc/ada/s-regpat.adb

@@ -781,7 +781,7 @@ package body System.Regpat is
 
       procedure Link_Operand_Tail (P, Val : Pointer) is
       begin
-         if Program (P) = BRANCH then
+         if P <= PM.Size and then Program (P) = BRANCH then
             Link_Tail (Operand (P), Val);
          end if;
       end Link_Operand_Tail;
@@ -796,14 +796,10 @@ package body System.Regpat is
          Offset : Pointer;
 
       begin
-         if Emit_Ptr > PM.Size then
-            return;
-         end if;
-
          --  Find last node
 
          Scan := P;
-         loop
+         while Scan <= PM.Size loop
             Temp := Get_Next (Program, Scan);
             exit when Temp = Scan;
             Scan := Temp;
@@ -914,7 +910,7 @@ package body System.Regpat is
 
          Link_Tail (IP, Ender);
 
-         if Have_Branch then
+         if Have_Branch and then Emit_Ptr <= PM.Size then
 
             --  Hook the tails of the branches to the closing node
 

gcc/ada/sem_attr.adb

@@ -4811,6 +4811,12 @@ package body Sem_Attr is
       --  Computes Aft value for current attribute prefix (used by Aft itself
       --  and also by Width for computing the Width of a fixed point type).
 
+      procedure Check_Concurrent_Discriminant (Bound : Node_Id);
+      --  If Bound is a reference to a discriminant of a task or protected type
+      --  occurring within the object's body, rewrite attribute reference into
+      --  a reference to the corresponding discriminal. Use for the expansion
+      --  of checks against bounds of entry family index subtypes.
+
       procedure Check_Expressions;
       --  In case where the attribute is not foldable, the expressions, if
       --  any, of the attribute, are in a non-static context. This procedure
@@ -4895,6 +4901,33 @@ package body Sem_Attr is
          return Result;
       end Aft_Value;
 
+      -----------------------------------
+      -- Check_Concurrent_Discriminant --
+      -----------------------------------
+
+      procedure Check_Concurrent_Discriminant (Bound : Node_Id) is
+         Tsk  : Entity_Id;
+         --  The concurrent (task or protected) type
+      begin
+         if Nkind (Bound) = N_Identifier
+           and then Ekind (Entity (Bound)) = E_Discriminant
+           and then Is_Concurrent_Record_Type (Scope (Entity (Bound)))
+         then
+            Tsk := Corresponding_Concurrent_Type (Scope (Entity (Bound)));
+            if In_Open_Scopes (Tsk)
+                 and then Has_Completion (Tsk)
+            then
+               --  Find discriminant of original concurrent type, and use
+               --  its current discriminal, which is the renaming within
+               --  the task/protected body.
+
+               Rewrite (N,
+                 New_Occurrence_Of
+                   (Find_Body_Discriminal (Entity (Bound)), Loc));
+            end if;
+         end if;
+      end Check_Concurrent_Discriminant;
+
       -----------------------
       -- Check_Expressions --
       -----------------------
@@ -5982,6 +6015,8 @@ package body Sem_Attr is
             else
                Fold_Uint  (N, Expr_Value (Lo_Bound), Static);
             end if;
+         else
+            Check_Concurrent_Discriminant (Lo_Bound);
          end if;
       end First_Attr;
 
@@ -6170,6 +6205,8 @@ package body Sem_Attr is
             else
                Fold_Uint  (N, Expr_Value (Hi_Bound), Static);
             end if;
+         else
+            Check_Concurrent_Discriminant (Hi_Bound);
          end if;
       end Last;
 

gcc/ada/sem_ch9.adb

@@ -30,7 +30,6 @@ with Errout;   use Errout;
 with Exp_Ch9;  use Exp_Ch9;
 with Elists;   use Elists;
 with Freeze;   use Freeze;
-with Itypes;   use Itypes;
 with Lib.Xref; use Lib.Xref;
 with Namet;    use Namet;
 with Nlists;   use Nlists;
@@ -167,73 +166,6 @@ package body Sem_Ch9 is
       Kind      : Entity_Kind;
       Task_Nam  : Entity_Id;
 
-      -----------------------
-      -- Actual_Index_Type --
-      -----------------------
-
-      function Actual_Index_Type (E : Entity_Id) return Entity_Id;
-      --  If the bounds of an entry family depend on task discriminants, create
-      --  a new index type where a discriminant is replaced by the local
-      --  variable that renames it in the task body.
-
-      -----------------------
-      -- Actual_Index_Type --
-      -----------------------
-
-      function Actual_Index_Type (E : Entity_Id) return Entity_Id is
-         Typ   : constant Entity_Id := Entry_Index_Type (E);
-         Lo    : constant Node_Id   := Type_Low_Bound  (Typ);
-         Hi    : constant Node_Id   := Type_High_Bound (Typ);
-         New_T : Entity_Id;
-
-         function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
-         --  If bound is discriminant reference, replace with corresponding
-         --  local variable of the same name.
-
-         -----------------------------
-         -- Actual_Discriminant_Ref --
-         -----------------------------
-
-         function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
-            Typ : constant Entity_Id := Etype (Bound);
-            Ref : Node_Id;
-         begin
-            if not Is_Entity_Name (Bound)
-              or else Ekind (Entity (Bound)) /= E_Discriminant
-            then
-               return Bound;
-            else
-               Ref := Make_Identifier (Sloc (N), Chars (Entity (Bound)));
-               Analyze (Ref);
-               Resolve (Ref, Typ);
-               return Ref;
-            end if;
-         end Actual_Discriminant_Ref;
-
-      --  Start of processing for Actual_Index_Type
-
-      begin
-         if not Has_Discriminants (Task_Nam)
-           or else (not Is_Entity_Name (Lo)
-                     and then not Is_Entity_Name (Hi))
-         then
-            return Entry_Index_Type (E);
-         else
-            New_T := Create_Itype (Ekind (Typ), N);
-            Set_Etype        (New_T, Base_Type (Typ));
-            Set_Size_Info    (New_T, Typ);
-            Set_RM_Size      (New_T, RM_Size (Typ));
-            Set_Scalar_Range (New_T,
-              Make_Range (Sloc (N),
-                Low_Bound  => Actual_Discriminant_Ref (Lo),
-                High_Bound => Actual_Discriminant_Ref (Hi)));
-
-            return New_T;
-         end if;
-      end Actual_Index_Type;
-
-   --  Start of processing for Analyze_Accept_Statement
-
    begin
       Tasking_Used := True;
 
@@ -370,7 +302,7 @@ package body Sem_Ch9 is
             Error_Msg_N ("missing entry index in accept for entry family", N);
          else
             Analyze_And_Resolve (Index, Entry_Index_Type (E));
-            Apply_Range_Check (Index, Actual_Index_Type (E));
+            Apply_Range_Check (Index, Entry_Index_Type (E));
          end if;
 
       elsif Present (Index) then

gcc/ada/sem_res.adb

@@ -5929,7 +5929,8 @@ package body Sem_Res is
               and then In_Open_Scopes (Tsk)
               and then Nkind (Parent (Entry_Name)) = N_Requeue_Statement
             then
-               return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
+               return New_Occurrence_Of
+                        (Find_Body_Discriminal (Entity (Bound)), Loc);
 
             else
                Ref :=

gcc/ada/sem_util.adb

@@ -3062,6 +3062,37 @@ package body Sem_Util is
       Call   := Empty;
    end Find_Actual;
 
+   ---------------------------
+   -- Find_Body_Discriminal --
+   ---------------------------
+
+   function Find_Body_Discriminal
+     (Spec_Discriminant : Entity_Id) return Entity_Id
+   is
+      pragma Assert (Is_Concurrent_Record_Type (Scope (Spec_Discriminant)));
+      Tsk  : constant Entity_Id :=
+               Corresponding_Concurrent_Type (Scope (Spec_Discriminant));
+      Disc : Entity_Id;
+   begin
+      --  Find discriminant of original concurrent type, and use its current
+      --  discriminal, which is the renaming within the task/protected body.
+
+      Disc := First_Discriminant (Tsk);
+      while Present (Disc) loop
+         if Chars (Disc) = Chars (Spec_Discriminant) then
+            Set_Scope (Discriminal (Disc), Tsk);
+            return Discriminal (Disc);
+         end if;
+
+         Next_Discriminant (Disc);
+      end loop;
+
+      --  That loop should always succeed in finding a matching entry and
+      --  returning. Fatal error if not.
+
+      raise Program_Error;
+   end Find_Body_Discriminal;
+
    -------------------------------------
    -- Find_Corresponding_Discriminant --
    -------------------------------------

gcc/ada/sem_util.ads

@@ -329,11 +329,11 @@ package Sem_Util is
    function Find_Corresponding_Discriminant
      (Id   : Node_Id;
       Typ  : Entity_Id) return Entity_Id;
-   --  Because discriminants may have different names in a generic unit
-   --  and in an instance, they are resolved positionally when possible.
-   --  A reference to a discriminant carries the discriminant that it
-   --  denotes when analyzed. Subsequent uses of this id on a different
-   --  type denote the discriminant at the same position in this new type.
+   --  Because discriminants may have different names in a generic unit and in
+   --  an instance, they are resolved positionally when possible. A reference
+   --  to a discriminant carries the discriminant that it denotes when
+   --  analyzed. Subsequent uses of this id on a different type denotes the
+   --  discriminant at the same position in this new type.
 
    procedure Find_Overlaid_Entity
      (N   : Node_Id;
@@ -355,6 +355,12 @@ package Sem_Util is
    --  Determine the alternative chosen, so that the code of non-selected
    --  alternatives, and the warnings that may apply to them, are removed.
 
+   function Find_Body_Discriminal
+     (Spec_Discriminant : Entity_Id) return Entity_Id;
+   --  Given a discriminant of the record type that implements a task or
+   --  protected type, return the discriminal of the corresponding discriminant
+   --  of the actual concurrent type.
+
    function First_Actual (Node : Node_Id) return Node_Id;
    --  Node is an N_Function_Call or N_Procedure_Call_Statement node. The
    --  result returned is the first actual parameter in declaration order