https://gcc.gnu.org/g:13754a59ee3ce292d89f014477015ca2f361cef5
commit r17-4766-g13754a59ee3ce292d89f014477015ca2f361cef5 Author: Eric Botcazou <[email protected]> Date: Tue Sep 29 12:11:47 2026 +0200 Ada: Fix missing initialization of parent discriminants in tagged extension This occurs for an aggregate whose nominal subtype is the tagged extension in a simplified case of ACATS cdd2a01. ACATS cdd2a01 is more involved and passes because of an ad-hoc kludge in Expr_Aggr (Initialize_Discriminants) which contains a bogus restriction. Expr_Aggr contains 4 different procedures to initialize discriminants and they tread on each other's toes while not covering all the cases, so this removes 2 of them and keeps only Init_{Parent,Stored}_Discriminants. gcc/ada/ * exp_aggr.adb (Initialize_Discriminants): Delete. (Build_Record_Aggr_Code.Init_Visible_Discriminants): Likewise. (Build_Record_Aggr_Code.Init_Hidden_Discriminants): Rename into... (Build_Record_Aggr_Code.Init_Parent_Discriminants): ...this. Remove the two parameters and initialize all the parent discriminants. (Build_Record_Aggr_Code.Init_Stored_Discriminants): Retrieve the stored discriminants of the base type. (Build_Record_Aggr_Code): Adjust to above changes. (Convert_To_Assignments): Remove calls to Initialize_Discriminants. * sem_aux.ads (First_Stored_Discriminant): Minor tweaks. Diff: --- gcc/ada/exp_aggr.adb | 225 ++++++++++++--------------------------------------- gcc/ada/sem_aux.ads | 10 +-- 2 files changed, 58 insertions(+), 177 deletions(-) diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 453727b63f49..8be767adb024 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -214,18 +214,6 @@ package body Exp_Aggr is -- defaults. An aggregate for a type with mutable components must be -- expanded into individual assignments. - procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id); - -- If the type of the aggregate is a type extension with renamed discrimi- - -- nants, we must initialize the hidden discriminants of the parent. - -- Otherwise, the target object must not be initialized. The discriminants - -- are initialized by calling the initialization procedure for the type. - -- This is incorrect if the initialization of other components has any - -- side effects. We restrict this call to the case where the parent type - -- has a variant part, because this is the only case where the hidden - -- discriminants are accessed, namely when calling discriminant checking - -- functions of the parent type, and when applying a stream attribute to - -- an object of the derived type. - --------------------------------------------------------- -- Local Subprograms for Container Aggregate Expansion -- --------------------------------------------------------- @@ -2282,26 +2270,17 @@ package body Exp_Aggr is -- do not provide discriminants for it, check aggregate components for -- values of the discriminants. - procedure Init_Hidden_Discriminants (Typ : Entity_Id; List : List_Id); - -- If Typ is derived, and constrains discriminants of the parent type, - -- these discriminants are not components of the aggregate, and must be - -- initialized. The assignments are appended to List. The same is done - -- if Typ derives from an already constrained subtype of a discriminated - -- parent type. + procedure Init_Parent_Discriminants; + -- If the type is a tagged extension and constrains discriminants of the + -- parent type, these discriminants are not components of the aggregate, + -- and must be initialized. Likewise if the type derives from an already + -- constrained subtype of a discriminated tagged type. procedure Init_Stored_Discriminants; - -- If the type is derived and has inherited discriminants, generate - -- explicit assignments for each, using the store constraint of the - -- type. Note that both visible and stored discriminants must be - -- initialized in case the derived type has some renamed and some - -- constrained discriminants. - - procedure Init_Visible_Discriminants; - -- If type has discriminants, retrieve their values from aggregate, - -- and generate explicit assignments for each. This does not include - -- discriminants inherited from ancestor, which are handled above. - -- The type of the aggregate is a subtype created ealier using the - -- given values of the discriminant components of the aggregate. + -- If the type has discriminants, retrieve the values of the stored ones + -- from the type of the aggregate, and generate explicit assignments for + -- them. The type of the aggregate is a subtype built earlier using the + -- values of the discriminant components in the aggregate. function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean; -- Check whether Bounds is a range node and its lower and higher bounds @@ -2570,55 +2549,18 @@ package body Exp_Aggr is end Get_Explicit_Discriminant_Value; ------------------------------- - -- Init_Hidden_Discriminants -- + -- Init_Parent_Discriminants -- ------------------------------- - procedure Init_Hidden_Discriminants (Typ : Entity_Id; List : List_Id) is - function Is_Completely_Hidden_Discriminant - (Discr : Entity_Id) return Boolean; - -- Determine whether Discr is a completely hidden discriminant of - -- type Typ. - - --------------------------------------- - -- Is_Completely_Hidden_Discriminant -- - --------------------------------------- - - function Is_Completely_Hidden_Discriminant - (Discr : Entity_Id) return Boolean - is - Item : Entity_Id; - - begin - -- Use First/Next_Entity as First/Next_Discriminant do not yield - -- completely hidden discriminants. - - Item := First_Entity (Typ); - while Present (Item) loop - if Ekind (Item) = E_Discriminant - and then Is_Completely_Hidden (Item) - and then Chars (Original_Record_Component (Item)) = - Chars (Discr) - then - return True; - end if; - - Next_Entity (Item); - end loop; - - return False; - end Is_Completely_Hidden_Discriminant; - - -- Local variables - + procedure Init_Parent_Discriminants is Base_Typ : Entity_Id; Discr : Entity_Id; Discr_Constr : Elmt_Id; - Discr_Init : Node_Id; Discr_Val : Node_Id; In_Aggr_Type : Boolean; Par_Typ : Entity_Id; - -- Start of processing for Init_Hidden_Discriminants + -- Start of processing for Init_Parent_Discriminants begin -- The constraints on the hidden discriminants, if present, are kept @@ -2667,39 +2609,43 @@ package body Exp_Aggr is while Present (Discr) and then Present (Discr_Constr) loop Discr_Val := Node (Discr_Constr); - -- The parent discriminant is renamed in the derived type, - -- nothing to initialize. - - -- type Deriv_Typ (Discr : ...) - -- is new Parent_Typ (Discr => Discr); + -- The parent discriminant is renamed in the derived type if Is_Entity_Name (Discr_Val) and then Ekind (Entity (Discr_Val)) = E_Discriminant then - null; - - -- When the parent discriminant is constrained at the type - -- extension level, it does not appear in the derived type. + Comp_Expr := + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => New_Occurrence_Of (Discr, Loc)); + + Discr_Val := + Get_Discriminant_Value + (Entity (Discr_Val), + Typ, + Discriminant_Constraint (N_Typ)); + + Instr := + Make_OK_Assignment_Statement (Loc, + Name => Comp_Expr, + Expression => New_Copy_Tree (Discr_Val)); - -- type Deriv_Typ (Discr : ...) - -- is new Parent_Typ (Discr => Discr, - -- Hidden_Discr => Expression); + Append_To (L, Instr); - elsif Is_Completely_Hidden_Discriminant (Discr) then - null; - - -- Otherwise initialize the discriminant + -- The parent discriminant is constrained in the derived type else - Discr_Init := + Comp_Expr := + Make_Selected_Component (Loc, + Prefix => New_Copy_Tree (Target), + Selector_Name => New_Occurrence_Of (Discr, Loc)); + + Instr := Make_OK_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Target), - Selector_Name => New_Occurrence_Of (Discr, Loc)), + Name => Comp_Expr, Expression => New_Copy_Tree (Discr_Val)); - Append_To (List, Discr_Init); + Append_To (L, Instr); end if; Next_Elmt (Discr_Constr); @@ -2709,38 +2655,7 @@ package body Exp_Aggr is In_Aggr_Type := False; Base_Typ := Base_Type (Par_Typ); end loop; - end Init_Hidden_Discriminants; - - -------------------------------- - -- Init_Visible_Discriminants -- - -------------------------------- - - procedure Init_Visible_Discriminants is - Discriminant : Entity_Id; - Discriminant_Value : Node_Id; - - begin - Discriminant := First_Discriminant (Typ); - while Present (Discriminant) loop - Comp_Expr := - Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Target), - Selector_Name => New_Occurrence_Of (Discriminant, Loc)); - - Discriminant_Value := - Get_Discriminant_Value - (Discriminant, Typ, Discriminant_Constraint (N_Typ)); - - Instr := - Make_OK_Assignment_Statement (Loc, - Name => Comp_Expr, - Expression => New_Copy_Tree (Discriminant_Value)); - - Append_To (L, Instr); - - Next_Discriminant (Discriminant); - end loop; - end Init_Visible_Discriminants; + end Init_Parent_Discriminants; ------------------------------- -- Init_Stored_Discriminants -- @@ -2751,7 +2666,7 @@ package body Exp_Aggr is Discriminant_Value : Node_Id; begin - Discriminant := First_Stored_Discriminant (Typ); + Discriminant := First_Stored_Discriminant (Base_Type (Typ)); while Present (Discriminant) loop Comp_Expr := Make_Selected_Component (Loc, @@ -2760,7 +2675,7 @@ package body Exp_Aggr is Discriminant_Value := Get_Discriminant_Value - (Discriminant, N_Typ, Discriminant_Constraint (N_Typ)); + (Discriminant, Typ, Discriminant_Constraint (N_Typ)); Instr := Make_OK_Assignment_Statement (Loc, @@ -3137,14 +3052,14 @@ package body Exp_Aggr is end if; end if; - -- Generate assignments of hidden discriminants. If the base type + -- Generate assignments of parent discriminants. If the base type -- is an unchecked union, the discriminants are absent from values -- of the type, so assignments for them are not emitted. if Has_Discriminants (Typ) and then not Is_Unchecked_Union (Base_Type (Typ)) then - Init_Hidden_Discriminants (Typ, L); + Init_Parent_Discriminants; end if; -- If the ancestor part is a subtype mark for a controlled type, @@ -3174,23 +3089,22 @@ package body Exp_Aggr is -- Normal case (not an extension aggregate) else - -- Generate the discriminant expressions, component by component. - -- If the base type is an unchecked union, the discriminants are - -- absent from values of the type, so assignments for them are not - -- emitted. + -- Generate assignments of all the discriminants. If the base type + -- is an unchecked union, the discriminants are absent from values + -- of the type, so assignments for them are not emitted. if Has_Discriminants (Typ) and then not Is_Unchecked_Union (Base_Type (Typ)) then - Init_Hidden_Discriminants (Typ, L); + -- Generate assignments of parent discriminants - -- Generate discriminant init values for the visible discriminants + if Is_Tagged_Type (Typ) then + Init_Parent_Discriminants; + end if; - Init_Visible_Discriminants; + -- Generate assignments of stored discriminants - if Is_Derived_Type (N_Typ) then - Init_Stored_Discriminants; - end if; + Init_Stored_Discriminants; end if; end if; @@ -3900,8 +3814,6 @@ package body Exp_Aggr is Set_No_Initialization (N); - Initialize_Discriminants (N, Typ); - -- Park the generated statements if the declaration requires it and is -- not the node that is wrapped in a transient scope. @@ -4323,6 +4235,7 @@ package body Exp_Aggr is then declare Lhs : constant Node_Id := Name (Parent_Node); + begin -- Apply discriminant check if required @@ -4364,7 +4277,6 @@ package body Exp_Aggr is Set_No_Initialization (Instr); Insert_Action (N, Instr); - Initialize_Discriminants (Instr, Full_Typ); Target_Expr := New_Occurrence_Of (Temp, Loc); Aggr_Code := Build_Record_Aggr_Code (N, Full_Typ, Target_Expr); @@ -9561,37 +9473,6 @@ package body Exp_Aggr is return False; end Has_Mutable_Components; - ------------------------------ - -- Initialize_Discriminants -- - ------------------------------ - - procedure Initialize_Discriminants (N : Node_Id; Typ : Entity_Id) is - Loc : constant Source_Ptr := Sloc (N); - Bas : constant Entity_Id := Base_Type (Typ); - Par : constant Entity_Id := Etype (Bas); - Decl : constant Node_Id := Parent (Par); - Ref : Node_Id; - - begin - if Is_Tagged_Type (Bas) - and then Is_Derived_Type (Bas) - and then Has_Discriminants (Par) - and then Has_Discriminants (Bas) - and then Number_Discriminants (Bas) /= Number_Discriminants (Par) - and then Nkind (Decl) = N_Full_Type_Declaration - and then Nkind (Type_Definition (Decl)) = N_Record_Definition - and then - Present (Variant_Part (Component_List (Type_Definition (Decl)))) - and then Nkind (N) /= N_Extension_Aggregate - then - -- Call init proc to set discriminants. - -- There should eventually be a special procedure for this ??? - - Ref := New_Occurrence_Of (Defining_Identifier (N), Loc); - Insert_Actions_After (N, Build_Initialization_Call (N, Ref, Typ)); - end if; - end Initialize_Discriminants; - ---------------- -- Must_Slide -- ---------------- diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index 3bd3a4664760..7fbcb925d5e1 100644 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -127,13 +127,13 @@ package Sem_Aux is -- stored discriminants are the same as the actual discriminants of the -- type, and hence this function is the same as First_Discriminant. -- - -- For derived untagged types that rename discriminants in the root type + -- For derived untagged types that rename discriminants in the root type, -- this is the first of the discriminants that occur in the root type. To -- be precise, in this case stored discriminants are entities attached to - -- the entity chain of the derived type which are a copy of the - -- discriminants of the root type. Furthermore their Is_Completely_Hidden - -- flag is set since although they are actually stored in the object, they - -- are not in the set of discriminants that is visible in the type. + -- the entity chain of the derived type but which are a mere copy of the + -- discriminants of the root type. Furthermore, their Is_Completely_Hidden + -- flag is set since, although they are actually stored in the object, they + -- are not in the set of discriminants that are visible in the type. -- -- For derived untagged types, the set of stored discriminants are the real -- discriminants from Gigi's standpoint, i.e. those that will be stored in
