This patch fixes a compiler abort on a record declaration that includes a
mutable record component whose default value is an aggregate that includes
a box-initialized component whose value depends on a discriminant of the
component.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
2017-09-18 Ed Schonberg <schonb...@adacore.com>
* exp_ch3.adb (Replace_Discriminant_References): New procedure,
subsidiary of Build_Assignment, used to handle the initialization code
for a mutable record component whose default value is an aggregate that
sets the values of the discriminants of the components.
gcc/testsuite/
2017-09-18 Ed Schonberg <schonb...@adacore.com>
* gnat.dg/default_variants.adb: New testcase.
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb (revision 252907)
+++ exp_ch3.adb (working copy)
@@ -1782,6 +1782,42 @@
Lhs : Node_Id;
Res : List_Id;
+ function Replace_Discr_Ref (N : Node_Id) return Traverse_Result;
+ -- Analysis of the aggregate has replaced discriminants by their
+ -- corresponding discriminals, but these are irrelevant when the
+ -- component has a mutable type and is initialized with an aggregate.
+ -- Instead, they must be replaced by the values supplied in the
+ -- aggregate, that will be assigned during the expansion of the
+ -- assignment.
+
+ -----------------------
+ -- Replace_Discr_Ref --
+ -----------------------
+
+ function Replace_Discr_Ref (N : Node_Id) return Traverse_Result is
+ Val : Node_Id;
+ begin
+ if Is_Entity_Name (N)
+ and then Present (Entity (N))
+ and then Is_Formal (Entity (N))
+ and then Present (Discriminal_Link (Entity (N)))
+ then
+ Val :=
+ Make_Selected_Component (N_Loc,
+ Prefix => New_Copy_Tree (Lhs),
+ Selector_Name => New_Occurrence_Of
+ (Discriminal_Link (Entity (N)), N_Loc));
+ if Present (Val) then
+ Rewrite (N, New_Copy_Tree (Val));
+ end if;
+ end if;
+
+ return OK;
+ end Replace_Discr_Ref;
+
+ procedure Replace_Discriminant_References is
+ new Traverse_Proc (Replace_Discr_Ref);
+
begin
Lhs :=
Make_Selected_Component (N_Loc,
@@ -1789,6 +1825,22 @@
Selector_Name => New_Occurrence_Of (Id, N_Loc));
Set_Assignment_OK (Lhs);
+ if Nkind (Exp) = N_Aggregate
+ and then Has_Discriminants (Typ)
+ and then not Is_Constrained (Base_Type (Typ))
+ then
+ -- The aggregate may provide new values for the discriminants
+ -- of the component, and other components may depend on those
+ -- discriminants. Previous analysis of those expressions have
+ -- replaced the discriminants by the formals of the initialization
+ -- procedure for the type, but these are irrelevant in the
+ -- enclosing initialization procedure: those discriminant
+ -- references must be replaced by the values provided in the
+ -- aggregate.
+
+ Replace_Discriminant_References (Exp);
+ end if;
+
-- Case of an access attribute applied to the current instance.
-- Replace the reference to the type by a reference to the actual
-- object. (Note that this handles the case of the top level of
Index: ../testsuite/gnat.dg/default_variants.adb
===================================================================
--- ../testsuite/gnat.dg/default_variants.adb (revision 0)
+++ ../testsuite/gnat.dg/default_variants.adb (revision 0)
@@ -0,0 +1,28 @@
+-- { dg-do compile }
+
+procedure Default_Variants is
+
+ type Variant_Kind is (A, B);
+
+ function Get_Default_Value (Kind : in Variant_Kind) return Natural is (10);
+
+ type Variant_Type (Kind : Variant_Kind := A) is
+ record
+ Common : Natural := Get_Default_Value (Kind);
+ case Kind is
+ when A =>
+ A_Value : Integer := Integer'First;
+ when B =>
+ B_Value : Natural := Natural'First;
+ end case;
+ end record;
+
+ type Containing_Type is tagged
+ record
+ Variant_Data : Variant_Type :=
+ (Kind => B, Common => <>, B_Value => 1);
+ end record;
+
+begin
+ null;
+end Default_Variants;
