diff mbox

[Ada] Handle initialization of array aggregate with <> component

Message ID 20131014124521.GA23753@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet Oct. 14, 2013, 12:45 p.m. UTC 
This patch makes sure that initialization of components corresponding
to a <> component clause is handled correctly. There are two cases.
If there is a Default_Component_Value aspect for the array, then this
value is used, otherwise normal default initialization takes place
(including in particular Initialize_Scalars initialization).

The following program compiles quietly as shown and outputs 456.
Before this update, the component printed was uninitialized.

     1. with Text_IO; use Text_IO;
     2. procedure Boxinit is
     3.    type T is new Integer with Default_Value => 123;
     4.    type T_For_Two is array (Boolean) of T
     5.      with Default_Component_Value => 456;
     6.    X : T_For_Two := (others => <>);
     7. begin
     8.    Put_Line (T'Image (X (False)));
     9. end;

The following program compiles quietly as shown and runs
without generating any output (previously Program_Error
was raised, because B_Strange did not get the expected
Initialize_Scalars initialization

     1. pragma Initialize_Scalars;
     2. procedure BoxIS is
     3.    type Boolean_Array is
     4.      array (Natural range <>) of Boolean;
     5.    type Ptr_Boolean_Array is
     6.      access Boolean_Array;
     7.    B_Strange : Ptr_Boolean_Array :=
     8.      new Boolean_Array'(1 .. 5 => <>);
     9.    B_Normal : Ptr_Boolean_Array :=
    10.      new Boolean_Array (1 .. 5);
    11. begin
    12.    if B_Strange.all /= B_Normal.all then
    13.       raise Program_Error;
    14.    end if;
    15. end BoxIS;

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

2013-10-14  Robert Dewar  <dewar@adacore.com>

	* einfo.ads, einfo.adb (Default_Aspect_Component_Value): Is on base type
	only.
	* exp_aggr.adb (Expand_Array_Aggregate): Handle proper
	initialization of <> component.
	* exp_ch3.adb, exp_tss.adb: Minor reformatting
	* sem_ch13.adb (Default_Aspect_Component_Value, Default_Aspect_Value):
	Is on base type only.
	* sinfo.ads: Minor comment revision.
diff mbox

Patch

Index: sinfo.ads
===================================================================
--- sinfo.ads	(revision 203522)
+++ sinfo.ads	(working copy)
@@ -3596,7 +3596,7 @@ 
       --  Sloc points to first selector name
       --  Choices (List1)
       --  Loop_Actions (List2-Sem)
-      --  Expression (Node3)
+      --  Expression (Node3) (empty if Box_Present)
       --  Box_Present (Flag15)
       --  Inherited_Discriminant (Flag13)
 
Index: einfo.adb
===================================================================
--- einfo.adb	(revision 203526)
+++ einfo.adb	(working copy)
@@ -853,13 +853,13 @@ 
    function Default_Aspect_Component_Value (Id : E) return N is
    begin
       pragma Assert (Is_Array_Type (Id));
-      return Node19 (Id);
+      return Node19 (Base_Type (Id));
    end Default_Aspect_Component_Value;
 
    function Default_Aspect_Value (Id : E) return N is
    begin
       pragma Assert (Is_Scalar_Type (Id));
-      return Node19 (Id);
+      return Node19 (Base_Type (Id));
    end Default_Aspect_Value;
 
    function Default_Expr_Function (Id : E) return E is
@@ -3456,13 +3456,13 @@ 
 
    procedure Set_Default_Aspect_Component_Value (Id : E; V : E) is
    begin
-      pragma Assert (Is_Array_Type (Id));
+      pragma Assert (Is_Array_Type (Id) and then Is_Base_Type (Id));
       Set_Node19 (Id, V);
    end Set_Default_Aspect_Component_Value;
 
    procedure Set_Default_Aspect_Value (Id : E; V : E) is
    begin
-      pragma Assert (Is_Scalar_Type (Id));
+      pragma Assert (Is_Scalar_Type (Id) and then Is_Base_Type (Id));
       Set_Node19 (Id, V);
    end Set_Default_Aspect_Value;
 
Index: einfo.ads
===================================================================
--- einfo.ads	(revision 203526)
+++ einfo.ads	(working copy)
@@ -738,13 +738,13 @@ 
 --       subprograms, this returns the {function,procedure}_specification, not
 --       the subprogram_declaration.
 
---    Default_Aspect_Component_Value (Node19)
+--    Default_Aspect_Component_Value (Node19) [base type only]
 --       Defined in array types. Holds the static value specified in a
---       default_component_value aspect specification for the array type.
+--       Default_Component_Value aspect specification for the array type.
 
---    Default_Aspect_Value (Node19)
+--    Default_Aspect_Value (Node19) [base type only]
 --       Defined in scalar types. Holds the static value specified in a
---       default_value aspect specification for the type.
+--       Default_Value aspect specification for the type.
 
 --    Default_Expr_Function (Node21)
 --       Defined in parameters. It holds the entity of the parameterless
@@ -5171,7 +5171,7 @@ 
    --  E_Array_Type
    --  E_Array_Subtype
    --    First_Index                         (Node17)
-   --    Default_Aspect_Component_Value      (Node19)
+   --    Default_Aspect_Component_Value      (Node19)   (base type only)
    --    Component_Type                      (Node20)   (base type only)
    --    Original_Array_Type                 (Node21)
    --    Component_Size                      (Uint22)   (base type only)
@@ -5354,7 +5354,7 @@ 
    --    Lit_Indexes                         (Node15)   (root type only)
    --    Lit_Strings                         (Node16)   (root type only)
    --    First_Literal                       (Node17)
-   --    Default_Aspect_Value                (Node19)
+   --    Default_Aspect_Value                (Node19)   (base type only)
    --    Scalar_Range                        (Node20)
    --    Enum_Pos_To_Rep                     (Node23)   (type only)
    --    Static_Predicate                    (List25)
@@ -5386,7 +5386,7 @@ 
    --  E_Floating_Point_Subtype
    --    Digits_Value                        (Uint17)
    --    Float_Rep                           (Uint10)   (Float_Rep_Kind)
-   --    Default_Aspect_Value                (Node19)
+   --    Default_Aspect_Value                (Node19)   (base type only)
    --    Scalar_Range                        (Node20)
    --    Machine_Emax_Value                  (synth)
    --    Machine_Emin_Value                  (synth)
@@ -5564,7 +5564,7 @@ 
    --  E_Modular_Integer_Type
    --  E_Modular_Integer_Subtype
    --    Modulus                             (Uint17)   (base type only)
-   --    Default_Aspect_Value                (Node19)
+   --    Default_Aspect_Value                (Node19)   (base type only)
    --    Original_Array_Type                 (Node21)
    --    Scalar_Range                        (Node20)
    --    Static_Predicate                    (List25)
@@ -5599,7 +5599,7 @@ 
    --  E_Ordinary_Fixed_Point_Type
    --  E_Ordinary_Fixed_Point_Subtype
    --    Delta_Value                         (Ureal18)
-   --    Default_Aspect_Value                (Node19)
+   --    Default_Aspect_Value                (Node19)   (base type only)
    --    Scalar_Range                        (Node20)
    --    Small_Value                         (Ureal21)
    --    Has_Small_Clause                    (Flag67)
@@ -5853,7 +5853,7 @@ 
 
    --  E_Signed_Integer_Type
    --  E_Signed_Integer_Subtype
-   --    Default_Aspect_Value                (Node19)
+   --    Default_Aspect_Value                (Node19)   (base type only)
    --    Scalar_Range                        (Node20)
    --    Static_Predicate                    (List25)
    --    Has_Biased_Representation           (Flag139)
Index: exp_tss.adb
===================================================================
--- exp_tss.adb	(revision 203521)
+++ exp_tss.adb	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2013, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -211,7 +211,7 @@ 
    begin
       return Present (BIP)
         and then (Restriction_Active (No_Default_Initialization)
-                    or else not Is_Null_Init_Proc (BIP));
+                   or else not Is_Null_Init_Proc (BIP));
    end Has_Non_Null_Base_Init_Proc;
 
    ---------------
Index: exp_aggr.adb
===================================================================
--- exp_aggr.adb	(revision 203521)
+++ exp_aggr.adb	(working copy)
@@ -4878,6 +4878,43 @@ 
          Check_Same_Aggr_Bounds (N, 1);
       end if;
 
+      --  STEP 1d
+
+      --  If we have a default component value, or simple initialization is
+      --  required for the component type, then we replace <> in component
+      --  associations by the required default value.
+
+      declare
+         Default_Val : Node_Id;
+         Assoc       : Node_Id;
+
+      begin
+         if (Present (Default_Aspect_Component_Value (Typ))
+              or else Needs_Simple_Initialization (Ctyp))
+           and then Present (Component_Associations (N))
+         then
+            Assoc := First (Component_Associations (N));
+            while Present (Assoc) loop
+               if Nkind (Assoc) = N_Component_Association
+                 and then Box_Present (Assoc)
+               then
+                  Set_Box_Present (Assoc, False);
+
+                  if Present (Default_Aspect_Component_Value (Typ)) then
+                     Default_Val := Default_Aspect_Component_Value (Typ);
+                  else
+                     Default_Val := Get_Simple_Init_Val (Ctyp, N);
+                  end if;
+
+                  Set_Expression (Assoc, New_Copy_Tree (Default_Val));
+                  Analyze_And_Resolve (Expression (Assoc), Ctyp);
+               end if;
+
+               Next (Assoc);
+            end loop;
+         end if;
+      end;
+
       --  STEP 2
 
       --  Here we test for is packed array aggregate that we can handle at
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb	(revision 203524)
+++ sem_ch13.adb	(working copy)
@@ -770,17 +770,9 @@ 
          Set_Has_Default_Aspect (Base_Type (Ent));
 
          if Is_Scalar_Type (Ent) then
-            Set_Default_Aspect_Value (Ent, Expr);
-
-            --  Place default value of base type as well, because that is
-            --  the semantics of the aspect. It is convenient to link the
-            --  aspect to both the (possibly anonymous) base type and to
-            --  the given first subtype.
-
             Set_Default_Aspect_Value (Base_Type (Ent), Expr);
-
          else
-            Set_Default_Aspect_Component_Value (Ent, Expr);
+            Set_Default_Aspect_Component_Value (Base_Type (Ent), Expr);
          end if;
       end Analyze_Aspect_Default_Value;
 
@@ -9457,6 +9449,7 @@ 
       --  Default_Component_Value
 
       if Is_Array_Type (Typ)
+        and then Is_Base_Type (Typ)
         and then Has_Rep_Item (Typ, Name_Default_Component_Value, False)
         and then Has_Rep_Item (Typ, Name_Default_Component_Value)
       then
@@ -9468,6 +9461,7 @@ 
       --  Default_Value
 
       if Is_Scalar_Type (Typ)
+        and then Is_Base_Type (Typ)
         and then Has_Rep_Item (Typ, Name_Default_Value, False)
         and then Has_Rep_Item (Typ, Name_Default_Value)
       then
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb	(revision 203521)
+++ exp_ch3.adb	(working copy)
@@ -4940,7 +4940,7 @@ 
                Next_Elmt (Discr);
             end loop;
 
-            --  Now collect values of initialized components.
+            --  Now collect values of initialized components
 
             Comp := First_Component (Full_Type);
             while Present (Comp) loop
@@ -4957,11 +4957,11 @@ 
                Next_Component (Comp);
             end loop;
 
-            --  Finally, box-initialize remaining components.
+            --  Finally, box-initialize remaining components
 
             Append_To (Component_Associations (Aggr),
               Make_Component_Association (Loc,
-                Choices => New_List (Make_Others_Choice (Loc)),
+                Choices    => New_List (Make_Others_Choice (Loc)),
                 Expression => Empty));
             Set_Box_Present (Last (Component_Associations (Aggr)));
             Set_Expression (N, Aggr);