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 <de...@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.
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);
