ada: Restore default size for dynamic allocations of discriminated type

The allocation strategy for objects of a discriminated type with defaulted
discriminants is not the same when the allocation is dynamic as when it is
static (i.e a declaration): in the former case, the compiler allocates the
default size whereas, in the latter case, it allocates the maximum size.

This restores the default size, which was dropped during the refactoring.

gcc/ada/

	* exp_aggr.adb (Build_Array_Aggr_Code): Pass N in the call to
	Build_Initialization_Call.
	(Build_Record_Aggr_Code): Likewise.
	(Convert_Aggr_In_Object_Decl): Likewise.
	(Initialize_Discriminants): Likewise.
	* exp_ch3.ads (Build_Initialization_Call): Replace Loc witn N.
	* exp_ch3.adb (Build_Array_Init_Proc): Pass N in the call to
	Build_Initialization_Call.
	(Build_Default_Initialization): Likewise.
	(Expand_N_Object_Declaration): Likewise.
	(Build_Initialization_Call): Replace Loc witn N parameter and add
	Loc local variable.  Build a default subtype for an allocator of
	a discriminated type with defaulted discriminants.
	(Build_Record_Init_Proc): Pass the declaration of components in the
	call to Build_Initialization_Call.
	* exp_ch6.adb (Make_CPP_Constructor_Call_In_Allocator): Pass the
	allocator in the call to Build_Initialization_Call.

diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 86f304e90bba6e56e640dd0c2445e5940ccb93ad..a4e4d81f0a8f7b5df1aef7d948fa104896aaf9bc 100644 (file)
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -1493,7 +1493,7 @@ package body Exp_Aggr is
               or else Has_Task (Base_Type (Ctype))
             then
                Append_List_To (Stmts,
-                 Build_Initialization_Call (Loc,
+                 Build_Initialization_Call (N,
                    Id_Ref            => Indexed_Comp,
                    Typ               => Ctype,
                    With_Default_Init => True));
@@ -2936,7 +2936,7 @@ package body Exp_Aggr is
 
                if not Is_Interface (Init_Typ) then
                   Append_List_To (L,
-                    Build_Initialization_Call (Loc,
+                    Build_Initialization_Call (N,
                       Id_Ref            => Ref,
                       Typ               => Init_Typ,
                       In_Init_Proc      => Within_Init_Proc,
@@ -2971,7 +2971,7 @@ package body Exp_Aggr is
                Set_Assignment_OK (Ref);
 
                Append_List_To (L,
-                 Build_Initialization_Call (Loc,
+                 Build_Initialization_Call (N,
                    Id_Ref            => Ref,
                    Typ               => Init_Typ,
                    In_Init_Proc      => Within_Init_Proc,
@@ -3148,7 +3148,7 @@ package body Exp_Aggr is
 
          if Is_CPP_Constructor_Call (Expression (Comp)) then
             Append_List_To (L,
-              Build_Initialization_Call (Loc,
+              Build_Initialization_Call (N,
                 Id_Ref            =>
                   Make_Selected_Component (Loc,
                     Prefix        => New_Copy_Tree (Target),
@@ -3217,7 +3217,7 @@ package body Exp_Aggr is
             end;
 
             Append_List_To (L,
-              Build_Initialization_Call (Loc,
+              Build_Initialization_Call (N,
                 Id_Ref            => Make_Selected_Component (Loc,
                                        Prefix        => New_Copy_Tree (Target),
                                        Selector_Name =>
@@ -3747,8 +3747,8 @@ package body Exp_Aggr is
                   Param := First (Parameter_Associations (Stmt));
                   Insert_Actions
                     (Stmt,
-                     Build_Initialization_Call
-                       (Sloc (N), New_Copy_Tree (Param), Etype (Param)));
+                     Build_Initialization_Call (N,
+                       New_Copy_Tree (Param), Etype (Param)));
                end if;
 
                Next (Stmt);
@@ -9279,13 +9279,11 @@ package body Exp_Aggr is
           Present (Variant_Part (Component_List (Type_Definition (Decl))))
         and then Nkind (N) /= N_Extension_Aggregate
       then
-
          --   Call init proc to set discriminants.
          --   There should eventually be a special procedure for this ???
 
          Ref := New_Occurrence_Of (Defining_Identifier (N), Loc);
-         Insert_Actions_After (N,
-           Build_Initialization_Call (Sloc (N), Ref, Typ));
+         Insert_Actions_After (N, Build_Initialization_Call (N, Ref, Typ));
       end if;
    end Initialize_Discriminants;
 

diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 9109d592690588c6f492445b7e1bd18a585b6400..13a0c8e7500f79a8fe294b08d5b10ff9573c2b1a 100644 (file)
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -699,7 +699,7 @@ package body Exp_Ch3 is
             Clean_Task_Names (Comp_Type, Proc_Id);
             return
               Build_Initialization_Call
-                (Loc          => Loc,
+                (N            => Nod,
                  Id_Ref       => Comp,
                  Typ          => Comp_Type,
                  In_Init_Proc => True,
@@ -1080,7 +1080,7 @@ package body Exp_Ch3 is
             end if;
 
             Comp_Init :=
-              Build_Initialization_Call (Loc,
+              Build_Initialization_Call (N,
                 Obj_Ref, Typ, Target_Ref => Target_Ref);
          end if;
       end if;
@@ -2013,7 +2013,7 @@ package body Exp_Ch3 is
    --  end;
 
    function Build_Initialization_Call
-     (Loc                 : Source_Ptr;
+     (N                   : Node_Id;
       Id_Ref              : Node_Id;
       Typ                 : Entity_Id;
       In_Init_Proc        : Boolean   := False;
@@ -2024,7 +2024,8 @@ package body Exp_Ch3 is
       Constructor_Ref     : Node_Id   := Empty;
       Init_Control_Actual : Entity_Id := Empty) return List_Id
    is
-      Res : constant List_Id := New_List;
+      Loc : constant Source_Ptr := Sloc (N);
+      Res : constant List_Id    := New_List;
 
       Full_Type : Entity_Id;
 
@@ -2322,6 +2323,24 @@ package body Exp_Ch3 is
       --  Add discriminant values if discriminants are present
 
       if Has_Discriminants (Full_Init_Type) then
+         --  If an allocated object will be constrained by the default
+         --  values for discriminants, then build a subtype with those
+         --  defaults, and change the allocated subtype to that. Note
+         --  that this happens in fewer cases in Ada 2005 (AI95-0363).
+
+         if Nkind (N) = N_Allocator
+           and then not Is_Constrained (Full_Type)
+           and then
+             Present
+               (Discriminant_Default_Value (First_Discriminant (Full_Type)))
+           and then (Ada_Version < Ada_2005
+                      or else not Object_Type_Has_Constrained_Partial_View
+                                    (Full_Type, Current_Scope))
+         then
+            Full_Type := Build_Default_Subtype (Full_Type, N);
+            Set_Expression (N, New_Occurrence_Of (Full_Type, Loc));
+         end if;
+
          Discr := First_Discriminant (Full_Init_Type);
          while Present (Discr) loop
 
@@ -3715,7 +3734,7 @@ package body Exp_Ch3 is
                   if Is_CPP_Constructor_Call (Expression (Decl)) then
                      Actions :=
                        Build_Initialization_Call
-                         (Comp_Loc,
+                         (Decl,
                           Id_Ref          =>
                             Make_Selected_Component (Comp_Loc,
                               Prefix        =>
@@ -3857,7 +3876,7 @@ package body Exp_Ch3 is
 
                      Init_Call_Stmts :=
                        Build_Initialization_Call
-                         (Comp_Loc,
+                         (Decl,
                           Make_Selected_Component (Comp_Loc,
                             Prefix        =>
                               Make_Identifier (Comp_Loc, Name_uInit),
@@ -4082,7 +4101,7 @@ package body Exp_Ch3 is
 
                Append_List_To (Late_Stmts,
                  Build_Initialization_Call
-                   (Loc                  => Parent_Loc,
+                   (N                    => Parent (Parent_Id),
                     Id_Ref               =>
                       Make_Selected_Component (Parent_Loc,
                         Prefix        => Make_Identifier
@@ -4113,7 +4132,7 @@ package body Exp_Ch3 is
 
                   elsif Has_Non_Null_Base_Init_Proc (Typ) then
                      Append_List_To (Late_Stmts,
-                       Build_Initialization_Call (Comp_Loc,
+                       Build_Initialization_Call (Decl,
                          Make_Selected_Component (Comp_Loc,
                            Prefix        =>
                              Make_Identifier (Comp_Loc, Name_uInit),
@@ -8099,7 +8118,7 @@ package body Exp_Ch3 is
                   Set_Assignment_OK (Id_Ref);
 
                   Insert_Actions_After (Init_After,
-                    Build_Initialization_Call (Loc, Id_Ref, Typ,
+                    Build_Initialization_Call (N, Id_Ref, Typ,
                       Constructor_Ref => Expr));
 
                   --  We remove here the original call to the constructor

diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads
index 095d39394334195c8adf20f4e6a9ee5b7eb54e10..a8018d8dff30a66f153d2715b18c38b26b473cc3 100644 (file)
--- a/gcc/ada/exp_ch3.ads
+++ b/gcc/ada/exp_ch3.ads
@@ -92,7 +92,7 @@ package Exp_Ch3 is
    --  derived type; no new subprograms are constructed in this case.
 
    function Build_Initialization_Call
-     (Loc                 : Source_Ptr;
+     (N                   : Node_Id;
       Id_Ref              : Node_Id;
       Typ                 : Entity_Id;
       In_Init_Proc        : Boolean   := False;
@@ -105,7 +105,7 @@ package Exp_Ch3 is
    --  Builds a call to the initialization procedure for the base type of Typ,
    --  passing it the object denoted by Id_Ref, plus additional parameters as
    --  appropriate for the type (the _Master, for task types, for example).
-   --  Loc is the source location for the constructed tree. In_Init_Proc has
+   --  N is the construct for which the call is to be built. In_Init_Proc has
    --  to be set to True when the call is itself in an init proc in order to
    --  enable the use of discriminals.
    --

diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index de75bd2fa924db53790441edfc557f8aecd6ddfe..a8a70a5759dced5440c1b584a60ef92101b23f7a 100644 (file)
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -9510,7 +9510,7 @@ package body Exp_Ch6 is
       Insert_Action (Allocator, Tmp_Obj);
 
       Insert_List_After_And_Analyze (Tmp_Obj,
-        Build_Initialization_Call (Loc,
+        Build_Initialization_Call (Allocator,
           Id_Ref =>
             Make_Explicit_Dereference (Loc,
               Prefix => New_Occurrence_Of (Return_Obj_Access, Loc)),