The compiler may crash processing a constant object declaration whose
expression is a nested aggregate. After this patch the following test
compiles without errors.
package Test_Nested_Aggregate is
type T_Comp (Validity : Boolean := False) is record
null;
end record;
type T_Root is abstract tagged record
Comp_1 : Natural;
Comp_2 : T_Comp;
end record;
type T_Deriv is new T_Root with record
null;
end record;
K_Value : constant T_Deriv :=
(Comp_1 => 0,
Comp_2 => (Validity => false) );
procedure Dummy;
end;
package body Test_Nested_Aggregate is
procedure Dummy is begin null; end;
end;
Command: gcc -c test_nested_aggregate.adb
Tested on x86_64-pc-linux-gnu, committed on trunk
2011-08-29 Javier Miranda <[email protected]>
* exp_aggr.adb (Expand_Record_Aggregate): Use the top-level enclosing
aggregate to take a consistent decision on the need to convert into
assignments aggregates that initialize constant objects.
Index: exp_aggr.adb
===================================================================
--- exp_aggr.adb (revision 178156)
+++ exp_aggr.adb (working copy)
@@ -5099,6 +5099,16 @@
-- semantics of Ada complicate the analysis and lead to anomalies in
-- the gcc back-end if the aggregate is not expanded into assignments.
+ function Has_Visible_Private_Ancestor (Id : E) return Boolean;
+ -- If any ancestor of the current type is private, the aggregate
+ -- cannot be built in place. We canot rely on Has_Private_Ancestor,
+ -- because it will not be set when type and its parent are in the
+ -- same scope, and the parent component needs expansion.
+
+ function Top_Level_Aggregate (N : Node_Id) return Node_Id;
+ -- For nested aggregates return the ultimate enclosing aggregate; for
+ -- non-nested aggregates return N.
+
----------------------------------
-- Component_Not_OK_For_Backend --
----------------------------------
@@ -5178,18 +5188,6 @@
return False;
end Component_Not_OK_For_Backend;
- -- Remaining Expand_Record_Aggregate variables
-
- Tag_Value : Node_Id;
- Comp : Entity_Id;
- New_Comp : Node_Id;
-
- function Has_Visible_Private_Ancestor (Id : E) return Boolean;
- -- If any ancestor of the current type is private, the aggregate
- -- cannot be built in place. We canot rely on Has_Private_Ancestor,
- -- because it will not be set when type and its parent are in the
- -- same scope, and the parent component needs expansion.
-
-----------------------------------
-- Has_Visible_Private_Ancestor --
-----------------------------------
@@ -5197,6 +5195,7 @@
function Has_Visible_Private_Ancestor (Id : E) return Boolean is
R : constant Entity_Id := Root_Type (Id);
T1 : Entity_Id := Id;
+
begin
loop
if Is_Private_Type (T1) then
@@ -5211,6 +5210,31 @@
end loop;
end Has_Visible_Private_Ancestor;
+ -------------------------
+ -- Top_Level_Aggregate --
+ -------------------------
+
+ function Top_Level_Aggregate (N : Node_Id) return Node_Id is
+ Aggr : Node_Id := N;
+
+ begin
+ while Present (Parent (Aggr))
+ and then Nkind_In (Parent (Aggr), N_Component_Association,
+ N_Aggregate)
+ loop
+ Aggr := Parent (Aggr);
+ end loop;
+
+ return Aggr;
+ end Top_Level_Aggregate;
+
+ -- Local variables
+
+ Top_Level_Aggr : constant Node_Id := Top_Level_Aggregate (N);
+ Tag_Value : Node_Id;
+ Comp : Entity_Id;
+ New_Comp : Node_Id;
+
-- Start of processing for Expand_Record_Aggregate
begin
@@ -5317,8 +5341,8 @@
elsif Has_Mutable_Components (Typ)
and then
- (Nkind (Parent (N)) /= N_Object_Declaration
- or else not Constant_Present (Parent (N)))
+ (Nkind (Parent (Top_Level_Aggr)) /= N_Object_Declaration
+ or else not Constant_Present (Parent (Top_Level_Aggr)))
then
Convert_To_Assignments (N, Typ);
