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;