From fc4c73488f8254c0d787a4ec06c135a4ce029b33 Mon Sep 17 00:00:00 2001 From: Piotr Trojanek Date: Sat, 7 Mar 2020 22:59:24 +0100 Subject: [PATCH] [Ada] Create constrained itypes for nested record aggregates 2020-06-11 Piotr Trojanek gcc/ada/ * sem_aggr.adb (Build_Constrained_Itype): Previously a declare block, now a separate procedure; the only change is that now New_Assoc_List might include components and an others clause, which we ignore (while we deal with discriminants exactly as we did before); extend a ??? comment about how this routine is different from the Build_Subtype (Resolve_Record_Aggregate): Create a constrained itype not just for the outermost record aggregate, but for its inner record aggregates as well. --- gcc/ada/sem_aggr.adb | 164 ++++++++++++++++++++++++++----------------- 1 file changed, 101 insertions(+), 63 deletions(-) diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 505ddfe2d59..5d56fd701c6 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -3315,6 +3315,29 @@ package body Sem_Aggr is -- part of the enclosing aggregate. Assoc_List provides the discriminant -- associations of the current type or of some enclosing record. + procedure Build_Constrained_Itype + (N : Node_Id; + Typ : Entity_Id; + New_Assoc_List : List_Id); + -- Build a constrained itype for the newly created record aggregate N + -- and set it as a type of N. The itype will have Typ as its base type + -- and will be constrained by the values of discriminants from the + -- component association list New_Assoc_List. + + -- ??? This code used to be pretty much a copy of Sem_Ch3.Build_Subtype, + -- but now those two routines behave differently for types with unknown + -- discriminants. They should really be exported in sem_util or some + -- such and used in sem_ch3 and here rather than have a copy of the + -- code which is a maintenance nightmare. + + -- ??? Performance WARNING. The current implementation creates a new + -- itype for all aggregates whose base type is discriminated. This means + -- that for record aggregates nested inside an array aggregate we will + -- create a new itype for each record aggregate if the array component + -- type has discriminants. For large aggregates this may be a problem. + -- What should be done in this case is to reuse itypes as much as + -- possible. + function Discriminant_Present (Input_Discr : Entity_Id) return Boolean; -- If aggregate N is a regular aggregate this routine will return True. -- Otherwise, if N is an extension aggregate, then Input_Discr denotes @@ -3474,6 +3497,78 @@ package body Sem_Aggr is end loop; end Add_Discriminant_Values; + ----------------------------- + -- Build_Constrained_Itype -- + ----------------------------- + + procedure Build_Constrained_Itype + (N : Node_Id; + Typ : Entity_Id; + New_Assoc_List : List_Id) + is + Constrs : constant List_Id := New_List; + Loc : constant Source_Ptr := Sloc (N); + Def_Id : Entity_Id; + Indic : Node_Id; + New_Assoc : Node_Id; + Subtyp_Decl : Node_Id; + + begin + New_Assoc := First (New_Assoc_List); + while Present (New_Assoc) loop + + -- There is exactly one choice in the component association (and + -- it is either a discriminant, a component or the others clause). + pragma Assert (List_Length (Choices (New_Assoc)) = 1); + + -- Duplicate expression for the discriminant and put it on the + -- list of constraints for the itype declaration. + + if Is_Entity_Name (First (Choices (New_Assoc))) + and then + Ekind (Entity (First (Choices (New_Assoc)))) = E_Discriminant + then + Append_To (Constrs, Duplicate_Subexpr (Expression (New_Assoc))); + end if; + + Next (New_Assoc); + end loop; + + if Has_Unknown_Discriminants (Typ) + and then Present (Underlying_Record_View (Typ)) + then + Indic := + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (Underlying_Record_View (Typ), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => Constrs)); + else + Indic := + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (Base_Type (Typ), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => Constrs)); + end if; + + Def_Id := Create_Itype (Ekind (Typ), N); + + Subtyp_Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Def_Id, + Subtype_Indication => Indic); + Set_Parent (Subtyp_Decl, Parent (N)); + + -- Itypes must be analyzed with checks off (see itypes.ads) + + Analyze (Subtyp_Decl, Suppress => All_Checks); + + Set_Etype (N, Def_Id); + end Build_Constrained_Itype; + -------------------------- -- Discriminant_Present -- -------------------------- @@ -3833,6 +3928,8 @@ package body Sem_Aggr is Add_Discriminant_Values (New_Aggr, Assoc_List); Propagate_Discriminants (New_Aggr, Assoc_List); + Build_Constrained_Itype + (New_Aggr, T, Component_Associations (New_Aggr)); else Needs_Box := True; end if; @@ -4378,73 +4475,11 @@ package body Sem_Aggr is -- STEP 4: Set the Etype of the record aggregate - -- ??? This code is pretty much a copy of Sem_Ch3.Build_Subtype. That - -- routine should really be exported in sem_util or some such and used - -- in sem_ch3 and here rather than have a copy of the code which is a - -- maintenance nightmare. - - -- ??? Performance WARNING. The current implementation creates a new - -- itype for all aggregates whose base type is discriminated. This means - -- that for record aggregates nested inside an array aggregate we will - -- create a new itype for each record aggregate if the array component - -- type has discriminants. For large aggregates this may be a problem. - -- What should be done in this case is to reuse itypes as much as - -- possible. - if Has_Discriminants (Typ) or else (Has_Unknown_Discriminants (Typ) and then Present (Underlying_Record_View (Typ))) then - Build_Constrained_Itype : declare - Constrs : constant List_Id := New_List; - Loc : constant Source_Ptr := Sloc (N); - Def_Id : Entity_Id; - Indic : Node_Id; - New_Assoc : Node_Id; - Subtyp_Decl : Node_Id; - - begin - New_Assoc := First (New_Assoc_List); - while Present (New_Assoc) loop - Append_To (Constrs, Duplicate_Subexpr (Expression (New_Assoc))); - Next (New_Assoc); - end loop; - - if Has_Unknown_Discriminants (Typ) - and then Present (Underlying_Record_View (Typ)) - then - Indic := - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Occurrence_Of (Underlying_Record_View (Typ), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => Constrs)); - else - Indic := - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Occurrence_Of (Base_Type (Typ), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => Constrs)); - end if; - - Def_Id := Create_Itype (Ekind (Typ), N); - - Subtyp_Decl := - Make_Subtype_Declaration (Loc, - Defining_Identifier => Def_Id, - Subtype_Indication => Indic); - Set_Parent (Subtyp_Decl, Parent (N)); - - -- Itypes must be analyzed with checks off (see itypes.ads) - - Analyze (Subtyp_Decl, Suppress => All_Checks); - - Set_Etype (N, Def_Id); - end Build_Constrained_Itype; - + Build_Constrained_Itype (N, Typ, New_Assoc_List); else Set_Etype (N, Typ); end if; @@ -4875,6 +4910,9 @@ package body Sem_Aggr is Propagate_Discriminants (Expr, Component_Associations (Expr)); + Build_Constrained_Itype + (Expr, Ctyp, Component_Associations (Expr)); + else declare Comp : Entity_Id; -- 2.30.2