ada: Adjust semantics and implementation of storage models

This makes the following adjustments to the semantics and implementation of
storage models in the compiler:

  1. By-copy semantics in subprogram calls: when an object accessed with a
     nonnative storage model is passed as an actual parameter in a call to
     a subprogram, an intermediate copy made on the host is passed instead.

  2. More generally, any additional temporary required on the host by the
     semantics of nonnative storage models is now created by the front-end
     instead of the code generator.

  3. All the temporaries created on the host for nonnative storage models
     are allocated on the secondary stack instead of the primary stack.

As a result, this should simplify the implementation in code generators.

gcc/ada/

	* exp_aggr.adb (Build_Assignment_With_Temporary): Adjust comment
	and fix type of second parameter. Create the temporary on the
	secondary stack by calling Build_Temporary_On_Secondary_Stack.
	(Convert_Array_Aggr_In_Allocator): Adjust formatting.
	(Expand_Array_Aggregate): Likewise.
	* exp_ch4.adb (Expand_N_Allocator): Set Actual_Designated_Subtype
	on the dereference in the initialization for all composite types.
	* exp_ch5.adb (Expand_N_Assignment_Statement): Create a temporary
	on the host for an assignment between nonnative storage models.
	Suppress more checks when Suppress_Assignment_Checks is set.
	* exp_ch6.adb (Add_Simple_Call_By_Copy_Code): Deal with actuals
	that are dereferences with an Actual_Designated_Subtype. Add
	support for nonnative storage models.
	(Expand_Actuals): Create a copy if the actual is a dereference
	with a nonnative storage model.
	* exp_util.ads (Build_Temporary_On_Secondary_Stack): Declare.
	* exp_util.adb (Build_Temporary_On_Secondary_Stack): New function.
	* sem_ch5.adb (Analyze_Assignment.Set_Assignment_Type): Do not
	build an actual subtype for dereferences with an
	Actual_Designated_Subtype
	* sinfo.ads (Actual_Designated_Subtype): Adjust documentation.
	(Suppress_Assignment_Checks): Likewise.

diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index f1cbbfc31557783ab4e453a0440ff5a6c3cc635c..cf8bac0f4bf401f8b0a17be94719f7e1240e3119 100644 (file)
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -62,7 +62,7 @@ with Sem_Eval;       use Sem_Eval;
 with Sem_Mech;       use Sem_Mech;
 with Sem_Res;        use Sem_Res;
 with Sem_Util;       use Sem_Util;
-use Sem_Util.Storage_Model_Support;
+                     use Sem_Util.Storage_Model_Support;
 with Sinfo;          use Sinfo;
 with Sinfo.Nodes;    use Sinfo.Nodes;
 with Sinfo.Utils;    use Sinfo.Utils;
@@ -78,12 +78,10 @@ package body Exp_Aggr is
 
    function Build_Assignment_With_Temporary
      (Target : Node_Id;
-      Typ    : Node_Id;
+      Typ    : Entity_Id;
       Source : Node_Id) return List_Id;
    --  Returns a list of actions to assign Source to Target of type Typ using
-   --  an extra temporary:
-   --   Tmp := Source;
-   --   Target := Tmp;
+   --  an extra temporary, which can potentially be large.
 
    type Case_Bounds is record
      Choice_Lo   : Node_Id;
@@ -2524,33 +2522,33 @@ package body Exp_Aggr is
 
    function Build_Assignment_With_Temporary
      (Target : Node_Id;
-      Typ    : Node_Id;
+      Typ    : Entity_Id;
       Source : Node_Id) return List_Id
    is
       Loc : constant Source_Ptr := Sloc (Source);
 
       Aggr_Code : List_Id;
       Tmp       : Entity_Id;
-      Tmp_Decl  : Node_Id;
 
    begin
-      Tmp := Make_Temporary (Loc, 'A', Source);
-      Tmp_Decl :=
-        Make_Object_Declaration (Loc,
-          Defining_Identifier => Tmp,
-          Object_Definition   => New_Occurrence_Of (Typ, Loc));
-      Set_No_Initialization (Tmp_Decl, True);
+      Aggr_Code := New_List;
+
+      Tmp := Build_Temporary_On_Secondary_Stack (Loc, Typ, Aggr_Code);
 
-      Aggr_Code := New_List (Tmp_Decl);
       Append_To (Aggr_Code,
         Make_OK_Assignment_Statement (Loc,
-          Name       => New_Occurrence_Of (Tmp, Loc),
+          Name       =>
+            Make_Explicit_Dereference (Loc,
+              Prefix => New_Occurrence_Of (Tmp, Loc)),
           Expression => Source));
 
       Append_To (Aggr_Code,
         Make_OK_Assignment_Statement (Loc,
           Name       => Target,
-          Expression => New_Occurrence_Of (Tmp, Loc)));
+          Expression =>
+            Make_Explicit_Dereference (Loc,
+              Prefix => New_Occurrence_Of (Tmp, Loc))));
+
       return Aggr_Code;
    end Build_Assignment_With_Temporary;
 
@@ -4571,8 +4569,9 @@ package body Exp_Aggr is
                                (Storage_Model_Object
                                   (Etype (Prefix (Expression (Target))))))
          then
-            Aggr_Code := Build_Assignment_With_Temporary (Target,
-                           Typ, New_Aggr);
+            Aggr_Code :=
+              Build_Assignment_With_Temporary (Target, Typ, New_Aggr);
+
          else
             Aggr_Code :=
               New_List (
@@ -7139,20 +7138,20 @@ package body Exp_Aggr is
                                   (Storage_Model_Object
                                      (Etype (Prefix (Name (Parent_Node))))))
             then
-               Aggr_Code := Build_Assignment_With_Temporary (Target,
-                              Typ, New_Copy_Tree (N));
+               Aggr_Code := Build_Assignment_With_Temporary
+                              (Target, Typ, New_Copy_Tree (N));
+
             else
                if Maybe_In_Place_OK then
                   return;
                end if;
 
-               Aggr_Code :=
-                 New_List (
-                   Make_Assignment_Statement (Loc,
-                     Name       => Target,
-                     Expression => New_Copy_Tree (N)));
-
+               Aggr_Code := New_List (
+                 Make_Assignment_Statement (Loc,
+                   Name       => Target,
+                   Expression => New_Copy_Tree (N)));
             end if;
+
          else
             Aggr_Code :=
               Build_Array_Aggr_Code (N,

diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 9558596ffa0bca4f6e251f378ce522b95f9d7e89..95b81fb8e535afe410f5bac0a455b97ab28970a8 100644 (file)
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -5066,13 +5066,12 @@ package body Exp_Ch4 is
                --  Add discriminants if discriminated type
 
                declare
-                  Dis : Boolean := False;
-                  Typ : Entity_Id := Empty;
+                  Dis : Boolean   := False;
+                  Typ : Entity_Id := T;
 
                begin
                   if Has_Discriminants (T) then
                      Dis := True;
-                     Typ := T;
 
                   --  Type may be a private type with no visible discriminants
                   --  in which case check full view if in scope, or the
@@ -5115,30 +5114,6 @@ package body Exp_Ch4 is
                         Set_Expression (N, New_Occurrence_Of (Typ, Loc));
                      end if;
 
-                     --  When the designated subtype is unconstrained and
-                     --  the allocator specifies a constrained subtype (or
-                     --  such a subtype has been created, such as above by
-                     --  Build_Default_Subtype), associate that subtype with
-                     --  the dereference of the allocator's access value.
-                     --  This is needed by the back end for cases where
-                     --  the access type has a Designated_Storage_Model,
-                     --  to support allocation of a host object of the right
-                     --  size for passing to the initialization procedure.
-
-                     if not Is_Constrained (Dtyp)
-                       and then Is_Constrained (Typ)
-                     then
-                        declare
-                           Init_Deref : constant Node_Id :=
-                             Unqual_Conv (Init_Arg1);
-                        begin
-                           pragma Assert
-                             (Nkind (Init_Deref) = N_Explicit_Dereference);
-
-                           Set_Actual_Designated_Subtype (Init_Deref, Typ);
-                        end;
-                     end if;
-
                      Discr := First_Elmt (Discriminant_Constraint (Typ));
                      while Present (Discr) loop
                         Nod := Node (Discr);
@@ -5161,6 +5136,29 @@ package body Exp_Ch4 is
                         Next_Elmt (Discr);
                      end loop;
                   end if;
+
+                  --  When the designated subtype is unconstrained and
+                  --  the allocator specifies a constrained subtype (or
+                  --  such a subtype has been created, such as above by
+                  --  Build_Default_Subtype), associate that subtype with
+                  --  the dereference of the allocator's access value.
+                  --  This is needed by the expander for cases where the
+                  --  access type has a Designated_Storage_Model in order
+                  --  to support allocation of a host object of the right
+                  --  size for passing to the initialization procedure.
+
+                  if not Is_Constrained (Dtyp)
+                    and then Is_Constrained (Typ)
+                  then
+                     declare
+                        Deref : constant Node_Id := Unqual_Conv (Init_Arg1);
+
+                     begin
+                        pragma Assert (Nkind (Deref) = N_Explicit_Dereference);
+
+                        Set_Actual_Designated_Subtype (Deref, Typ);
+                     end;
+                  end if;
                end;
 
                --  We set the allocator as analyzed so that when we analyze

diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb
index 0dbf2d551925e34bd58217dcdc154791a0573186..0c89856b58bf61f23571f405e1d7f20a4b6ddc31 100644 (file)
--- a/gcc/ada/exp_ch5.adb
+++ b/gcc/ada/exp_ch5.adb
@@ -59,6 +59,7 @@ with Sem_Ch13;       use Sem_Ch13;
 with Sem_Eval;       use Sem_Eval;
 with Sem_Res;        use Sem_Res;
 with Sem_Util;       use Sem_Util;
+                     use Sem_Util.Storage_Model_Support;
 with Snames;         use Snames;
 with Stand;          use Stand;
 with Stringt;        use Stringt;
@@ -2658,10 +2659,50 @@ package body Exp_Ch5 is
          Convert_Aggr_In_Assignment (N);
          Rewrite (N, Make_Null_Statement (Loc));
          Analyze (N);
-
          return;
       end if;
 
+      --  An assignment between nonnative storage models requires creating an
+      --  intermediate temporary on the host, which can potentially be large.
+
+      if Nkind (Lhs) = N_Explicit_Dereference
+        and then Has_Designated_Storage_Model_Aspect (Etype (Prefix (Lhs)))
+        and then Present (Storage_Model_Copy_To
+                           (Storage_Model_Object (Etype (Prefix (Lhs)))))
+        and then Nkind (Rhs) = N_Explicit_Dereference
+        and then Has_Designated_Storage_Model_Aspect (Etype (Prefix (Rhs)))
+        and then Present (Storage_Model_Copy_From
+                           (Storage_Model_Object (Etype (Prefix (Rhs)))))
+      then
+         declare
+            Assign_Code : List_Id;
+            Tmp         : Entity_Id;
+
+         begin
+            Assign_Code := New_List;
+
+            Tmp := Build_Temporary_On_Secondary_Stack (Loc, Typ, Assign_Code);
+
+            Append_To (Assign_Code,
+              Make_Assignment_Statement (Loc,
+                Name       =>
+                  Make_Explicit_Dereference (Loc,
+                    Prefix => New_Occurrence_Of (Tmp, Loc)),
+                Expression => Relocate_Node (Rhs)));
+
+            Append_To (Assign_Code,
+              Make_Assignment_Statement (Loc,
+                Name       => Relocate_Node (Lhs),
+                Expression =>
+                  Make_Explicit_Dereference (Loc,
+                    Prefix => New_Occurrence_Of (Tmp, Loc))));
+
+            Insert_Actions (N, Assign_Code);
+            Rewrite (N, Make_Null_Statement (Loc));
+            return;
+         end;
+      end if;
+
       --  Apply discriminant check if required. If Lhs is an access type to a
       --  designated type with discriminants, we must always check. If the
       --  type has unknown discriminants, more elaborate processing below.
@@ -2672,7 +2713,7 @@ package body Exp_Ch5 is
          --  Skip discriminant check if change of representation. Will be
          --  done when the change of representation is expanded out.
 
-         if not Crep then
+         if not Crep and then not Suppress_Assignment_Checks (N) then
             Apply_Discriminant_Check (Rhs, Etype (Lhs), Lhs);
          end if;
 
@@ -2712,7 +2753,9 @@ package body Exp_Ch5 is
 
             Set_Etype (Lhs, Ubt);
             Rewrite (Rhs, OK_Convert_To (Base_Type (Ubt), Rhs));
-            Apply_Discriminant_Check (Rhs, Ubt, Lhs);
+            if not Suppress_Assignment_Checks (N) then
+               Apply_Discriminant_Check (Rhs, Ubt, Lhs);
+            end if;
             Set_Etype (Lhs, Lt);
          end;
 
@@ -2732,12 +2775,16 @@ package body Exp_Ch5 is
          then
             Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs));
             Rewrite (Lhs, OK_Convert_To (Base_Type (Typ), Lhs));
-            Apply_Discriminant_Check (Rhs, Typ, Lhs);
+            if not Suppress_Assignment_Checks (N) then
+               Apply_Discriminant_Check (Rhs, Typ, Lhs);
+            end if;
 
          elsif Is_Array_Type (Typ) and then Is_Constrained (Typ) then
             Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs));
             Rewrite (Lhs, OK_Convert_To (Base_Type (Typ), Lhs));
-            Apply_Length_Check (Rhs, Typ);
+            if not Suppress_Assignment_Checks (N) then
+               Apply_Length_Check (Rhs, Typ);
+            end if;
          end if;
 
       --  In the access type case, we need the same discriminant check, and
@@ -2745,6 +2792,7 @@ package body Exp_Ch5 is
 
       elsif Is_Access_Type (Etype (Lhs))
         and then Is_Constrained (Designated_Type (Etype (Lhs)))
+        and then not Suppress_Assignment_Checks (N)
       then
          if Has_Discriminants (Designated_Type (Etype (Lhs))) then
 

diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 7abf25e3859a8b6992f21fa0bf3f63284002df7b..af7f75342fa5d5bdcc2d9dc6be2f25d944f1edc9 100644 (file)
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -70,6 +70,7 @@ with Sem_Mech;       use Sem_Mech;
 with Sem_Res;        use Sem_Res;
 with Sem_SCIL;       use Sem_SCIL;
 with Sem_Util;       use Sem_Util;
+                     use Sem_Util.Storage_Model_Support;
 with Sinfo;          use Sinfo;
 with Sinfo.Nodes;    use Sinfo.Nodes;
 with Sinfo.Utils;    use Sinfo.Utils;
@@ -1936,8 +1937,14 @@ package body Exp_Ch6 is
       ----------------------------------
 
       procedure Add_Simple_Call_By_Copy_Code (Force : Boolean) is
+         With_Storage_Model : constant Boolean :=
+           Nkind (Actual) = N_Explicit_Dereference
+             and then
+               Has_Designated_Storage_Model_Aspect (Etype (Prefix (Actual)));
+
+         Cpcod  : List_Id;
          Decl   : Node_Id;
-         F_Typ  : Entity_Id := Etype (Formal);
+         F_Typ  : Entity_Id;
          Incod  : Node_Id;
          Indic  : Node_Id;
          Lhs    : Node_Id;
@@ -1952,6 +1959,8 @@ package body Exp_Ch6 is
             return;
          end if;
 
+         F_Typ := Etype (Formal);
+
          --  Handle formals whose type comes from the limited view
 
          if From_Limited_With (F_Typ)
@@ -1960,12 +1969,21 @@ package body Exp_Ch6 is
             F_Typ := Non_Limited_View (F_Typ);
          end if;
 
+         --  Use the actual designated subtype for a dereference, if any
+
+         if Nkind (Actual) = N_Explicit_Dereference
+           and then Present (Actual_Designated_Subtype (Actual))
+         then
+            Indic :=
+              New_Occurrence_Of (Actual_Designated_Subtype (Actual), Loc);
+
          --  Use formal type for temp, unless formal type is an unconstrained
          --  array, in which case we don't have to worry about bounds checks,
          --  and we use the actual type, since that has appropriate bounds.
 
-         if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then
+         elsif Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then
             Indic := New_Occurrence_Of (Etype (Actual), Loc);
+
          else
             Indic := New_Occurrence_Of (F_Typ, Loc);
          end if;
@@ -1974,7 +1992,6 @@ package body Exp_Ch6 is
 
          Reset_Packed_Prefix;
 
-         Temp   := Make_Temporary (Loc, 'T', Actual);
          Incod  := Relocate_Node (Actual);
          Outcod := New_Copy_Tree (Incod);
 
@@ -1990,7 +2007,10 @@ package body Exp_Ch6 is
          if Ekind (Formal) = E_Out_Parameter then
             Incod := Empty;
 
-            if Has_Discriminants (F_Typ) then
+            if Has_Discriminants (F_Typ)
+              and then (Nkind (Actual) /= N_Explicit_Dereference
+                         or else No (Actual_Designated_Subtype (Actual)))
+            then
                Indic := New_Occurrence_Of (Etype (Actual), Loc);
             end if;
 
@@ -2017,15 +2037,31 @@ package body Exp_Ch6 is
             end if;
          end if;
 
-         Decl :=
-           Make_Object_Declaration (Loc,
-             Defining_Identifier => Temp,
-             Object_Definition   => Indic,
-             Expression          => Incod);
+         Cpcod := New_List;
+
+         if With_Storage_Model then
+            Temp :=
+              Build_Temporary_On_Secondary_Stack (Loc, Entity (Indic), Cpcod);
+
+            if Present (Incod) then
+               Append_To (Cpcod,
+                 Make_Assignment_Statement (Loc,
+                   Name       =>
+                     Make_Explicit_Dereference (Loc,
+                       Prefix => New_Occurrence_Of (Temp, Loc)),
+                   Expression => Incod));
+               Set_Suppress_Assignment_Checks (Last (Cpcod));
+            end if;
+
+         else
+            Temp := Make_Temporary (Loc, 'T', Actual);
+
+            Decl :=
+              Make_Object_Declaration (Loc,
+                Defining_Identifier => Temp,
+                Object_Definition   => Indic,
+                Expression          => Incod);
 
-         if Inside_Init_Proc
-           and then No (Incod)
-         then
             --  If the call is to initialize a component of a composite type,
             --  and the component does not depend on discriminants, use the
             --  actual type of the component. This is required in case the
@@ -2035,23 +2071,42 @@ package body Exp_Ch6 is
             --  discriminant, the presence of the initialization in the
             --  declaration will generate an expression for the actual subtype.
 
-            Set_No_Initialization (Decl);
-            Set_Object_Definition (Decl,
-              New_Occurrence_Of (Etype (Actual), Loc));
+            if Inside_Init_Proc and then No (Incod) then
+               Set_No_Initialization (Decl);
+               Set_Object_Definition (Decl,
+                 New_Occurrence_Of (Etype (Actual), Loc));
+            end if;
+
+            Append_To (Cpcod, Decl);
          end if;
 
-         Insert_Action (N, Decl);
+         Insert_Actions (N, Cpcod);
 
          --  The actual is simply a reference to the temporary
 
-         Rewrite (Actual, New_Occurrence_Of (Temp, Loc));
+         if With_Storage_Model then
+            Rewrite (Actual,
+              Make_Explicit_Dereference (Loc,
+                Prefix => New_Occurrence_Of (Temp, Loc)));
+         else
+            Rewrite (Actual, New_Occurrence_Of (Temp, Loc));
+         end if;
+
+         Analyze (Actual);
 
          --  Generate copy out if OUT or IN OUT parameter
 
          if Ekind (Formal) /= E_In_Parameter then
             Lhs := Outcod;
-            Rhs := New_Occurrence_Of (Temp, Loc);
-            Set_Is_True_Constant (Temp, False);
+
+            if With_Storage_Model then
+               Rhs :=
+                 Make_Explicit_Dereference (Loc,
+                   Prefix => New_Occurrence_Of (Temp, Loc));
+            else
+               Rhs := New_Occurrence_Of (Temp, Loc);
+               Set_Is_True_Constant (Temp, False);
+            end if;
 
             --  Deal with conversion
 
@@ -2064,6 +2119,7 @@ package body Exp_Ch6 is
               Make_Assignment_Statement (Loc,
                 Name       => Lhs,
                 Expression => Rhs));
+            Set_Suppress_Assignment_Checks (Last (Post_Call));
             Set_Assignment_OK (Name (Last (Post_Call)));
          end if;
       end Add_Simple_Call_By_Copy_Code;
@@ -2452,6 +2508,22 @@ package body Exp_Ch6 is
             elsif Is_Ref_To_Bit_Packed_Array (Actual) then
                Add_Simple_Call_By_Copy_Code (Force => True);
 
+            --  If the actual has a nonnative storage model, we need a copy
+
+            elsif Nkind (Actual) = N_Explicit_Dereference
+              and then
+                Has_Designated_Storage_Model_Aspect (Etype (Prefix (Actual)))
+              and then
+                (Present (Storage_Model_Copy_To
+                            (Storage_Model_Object (Etype (Prefix (Actual)))))
+                  or else
+                    (Ekind (Formal) = E_In_Out_Parameter
+                      and then
+                        (Present (Storage_Model_Copy_From
+                           (Storage_Model_Object (Etype (Prefix (Actual))))))))
+            then
+               Add_Simple_Call_By_Copy_Code (Force => True);
+
             --  If a nonscalar actual is possibly bit-aligned, we need a copy
             --  because the back-end cannot cope with such objects. In other
             --  cases where alignment forces a copy, the back-end generates
@@ -2598,6 +2670,17 @@ package body Exp_Ch6 is
             elsif Is_Ref_To_Bit_Packed_Array (Actual) then
                Add_Simple_Call_By_Copy_Code (Force => True);
 
+            --  If the actual has a nonnative storage model, we need a copy
+
+            elsif Nkind (Actual) = N_Explicit_Dereference
+              and then
+                Has_Designated_Storage_Model_Aspect (Etype (Prefix (Actual)))
+              and then
+                Present (Storage_Model_Copy_From
+                           (Storage_Model_Object (Etype (Prefix (Actual)))))
+            then
+               Add_Simple_Call_By_Copy_Code (Force => True);
+
             --  If we have a C++ constructor call, we need to create the object
 
             elsif Is_CPP_Constructor_Call (Actual) then

diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index 80c01bf40fd27cd639bb9d7d7ed11fbb076e03b5..f010dac4978476874facc92f4bff57e4b6f74880 100644 (file)
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -4699,6 +4699,55 @@ package body Exp_Util is
       return Build_Task_Image_Function (Loc, Decls, Stats, Res);
    end Build_Task_Record_Image;
 
+   ----------------------------------------
+   -- Build_Temporary_On_Secondary_Stack --
+   ----------------------------------------
+
+   function Build_Temporary_On_Secondary_Stack
+     (Loc  : Source_Ptr;
+      Typ  : Entity_Id;
+      Code : List_Id) return Entity_Id
+   is
+      Acc_Typ   : Entity_Id;
+      Alloc     : Node_Id;
+      Alloc_Obj : Entity_Id;
+
+   begin
+      pragma Assert (RTE_Available (RE_SS_Pool)
+        and then not Needs_Finalization (Typ));
+
+      Acc_Typ := Make_Temporary (Loc, 'A');
+      Mutate_Ekind (Acc_Typ, E_Access_Type);
+      Set_Associated_Storage_Pool (Acc_Typ, RTE (RE_SS_Pool));
+
+      Append_To (Code,
+        Make_Full_Type_Declaration (Loc,
+          Defining_Identifier => Acc_Typ,
+          Type_Definition     =>
+            Make_Access_To_Object_Definition (Loc,
+              All_Present        => True,
+              Subtype_Indication =>
+                New_Occurrence_Of (Typ, Loc))));
+
+      Alloc :=
+        Make_Allocator (Loc, Expression => New_Occurrence_Of (Typ, Loc));
+      Set_No_Initialization (Alloc);
+
+      Alloc_Obj := Make_Temporary (Loc, 'R');
+
+      Append_To (Code,
+        Make_Object_Declaration (Loc,
+          Defining_Identifier => Alloc_Obj,
+          Constant_Present    => True,
+          Object_Definition   =>
+            New_Occurrence_Of (Acc_Typ, Loc),
+          Expression          => Alloc));
+
+      Set_Uses_Sec_Stack (Current_Scope);
+
+      return Alloc_Obj;
+   end Build_Temporary_On_Secondary_Stack;
+
    ---------------------------------------
    -- Build_Transient_Object_Statements --
    ---------------------------------------

diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index 3dd10d77cea4a5401950b28c698a2ea46c0c9195..eef6800f3713059c141e3a627575bd9def8acc2f 100644 (file)
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -351,6 +351,18 @@ package Exp_Util is
    --  is false, the call is for a stand-alone object, and the generated
    --  function itself must do its own cleanups.
 
+   function Build_Temporary_On_Secondary_Stack
+     (Loc  : Source_Ptr;
+      Typ  : Entity_Id;
+      Code : List_Id) return Entity_Id;
+   --  Build a temporary of type Typ on the secondary stack, appending the
+   --  necessary actions to Code, and return a constant holding the access
+   --  value designating this temporary, under the assumption that Typ does
+   --  not need finalization.
+
+   --  This should be used when Typ can potentially be large, to avoid putting
+   --  too much pressure on the primary stack, for example with storage models.
+
    procedure Build_Transient_Object_Statements
      (Obj_Decl     : Node_Id;
       Fin_Call     : out Node_Id;

diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index ab5a2083a00dbafd69533ee02947e06030de0a6a..27ab0b738cd08f8aaa54ac4ecb4cbc5bb93f9783 100644 (file)
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -324,10 +324,13 @@ package body Sem_Ch5 is
          then
             Opnd_Type := Get_Actual_Subtype (Opnd);
 
-         --  If assignment operand is a component reference, then we get the
-         --  actual subtype of the component for the unconstrained case.
+         --  If the assignment operand is a component reference, then we build
+         --  the actual subtype of the component for the unconstrained case,
+         --  unless there is already one or the type is an unchecked union.
 
-         elsif Nkind (Opnd) in N_Selected_Component | N_Explicit_Dereference
+         elsif (Nkind (Opnd) = N_Selected_Component
+                 or else (Nkind (Opnd) = N_Explicit_Dereference
+                           and then No (Actual_Designated_Subtype (Opnd))))
            and then not Is_Unchecked_Union (Opnd_Type)
          then
             Decl := Build_Actual_Subtype_Of_Component (Opnd_Type, Opnd);

diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads
index 6cacebe777573d6be98bd634f69d81c41572017c..ce54dd3fb9191f349acc9b64046907fa3e7d6926 100644 (file)
--- a/gcc/ada/sinfo.ads
+++ b/gcc/ada/sinfo.ads
@@ -830,7 +830,7 @@ package Sinfo is
    --    an unconstrained packed array and the dereference is the prefix of
    --    a 'Size attribute reference, or 2) when the dereference node is
    --    created for the expansion of an allocator with a subtype_indication
-   --    and the designated subtype is an unconstrained discriminated type.
+   --    and the designated subtype is an unconstrained composite type.
 
    --  Address_Warning_Posted
    --    Present in N_Attribute_Definition nodes. Set to indicate that we have
@@ -2311,7 +2311,7 @@ package Sinfo is
    --    can be set in N_Object_Declaration nodes, to similarly suppress any
    --    checks on the initializing value. In assignment statements it also
    --    suppresses access checks in the generated code for out- and in-out
-   --    parameters in entry calls, as well as length checks.
+   --    parameters in entry calls, as well as discriminant and length checks.
 
    --  Suppress_Loop_Warnings
    --    Used in N_Loop_Statement node to indicate that warnings within the