From c5b55e683cace7be98536c413a70f854a70faaa7 Mon Sep 17 00:00:00 2001 From: Piotr Trojanek Date: Tue, 17 Mar 2020 14:16:28 +0100 Subject: [PATCH] [Ada] Move duplicated routines for building itypes to Sem_Util 2020-06-11 Piotr Trojanek gcc/ada/ * sem_aggr.adb (Build_Constrained_Itype): Move to Sem_Util. * sem_ch3.adb (Build_Subtype, Inherit_Predicate_Flags): Move... * sem_util.adb (Build_Subtype): Here. Add parameters for references to objects previously declared in enclosing scopes. (Inherit_Predicate_Flags): And here, because it is called by Build_Subtype. * sem_util.ads (Build_Overriding_Spec): Reorder alphabetically. (Build_Subtype): Moved from Sem_Ch3; comments updated. (Build_Constrained_Itype): Moved from Sem_Aggr; comments updated. --- gcc/ada/sem_aggr.adb | 95 ----------------------- gcc/ada/sem_ch3.adb | 112 +-------------------------- gcc/ada/sem_util.adb | 180 +++++++++++++++++++++++++++++++++++++++++++ gcc/ada/sem_util.ads | 57 ++++++++++++-- 4 files changed, 231 insertions(+), 213 deletions(-) diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 9ef0eb8f22c..b80810dffad 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -3313,29 +3313,6 @@ 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 @@ -3495,78 +3472,6 @@ 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 -- -------------------------- diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 0c79faced9d..026bcefdba3 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -563,10 +563,6 @@ package body Sem_Ch3 is -- copying the record declaration for the derived base. In the tagged case -- the value returned is irrelevant. - procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id); - -- Propagate static and dynamic predicate flags from a parent to the - -- subtype in a subtype declaration with and without constraints. - function Is_EVF_Procedure (Subp : Entity_Id) return Boolean; -- Subsidiary to Check_Abstract_Overriding and Derive_Subprogram. -- Determine whether subprogram Subp is a procedure subject to pragma @@ -13078,10 +13074,6 @@ package body Sem_Ch3 is -- Ditto for access types. Makes use of previous two functions, to -- constrain designated type. - function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id; - -- T is an array or discriminated type, C is a list of constraints - -- that apply to T. This routine builds the constrained subtype. - function Is_Discriminant (Expr : Node_Id) return Boolean; -- Returns True if Expr is a discriminant @@ -13229,7 +13221,7 @@ package body Sem_Ch3 is Next_Index (Old_Index); end loop; - return Build_Subtype (Old_Type, Constr_List); + return Build_Subtype (Related_Node, Loc, Old_Type, Constr_List); else return Old_Type; @@ -13294,81 +13286,13 @@ package body Sem_Ch3 is Next_Elmt (Old_Constraint); end loop; - return Build_Subtype (Old_Type, Constr_List); + return Build_Subtype (Related_Node, Loc, Old_Type, Constr_List); else return Old_Type; end if; end Build_Constrained_Discriminated_Type; - ------------------- - -- Build_Subtype -- - ------------------- - - function Build_Subtype (T : Entity_Id; C : List_Id) return Entity_Id is - Indic : Node_Id; - Subtyp_Decl : Node_Id; - Def_Id : Entity_Id; - Btyp : Entity_Id := Base_Type (T); - - begin - -- The Related_Node better be here or else we won't be able to - -- attach new itypes to a node in the tree. - - pragma Assert (Present (Related_Node)); - - -- If the view of the component's type is incomplete or private - -- with unknown discriminants, then the constraint must be applied - -- to the full type. - - if Has_Unknown_Discriminants (Btyp) - and then Present (Underlying_Type (Btyp)) - then - Btyp := Underlying_Type (Btyp); - end if; - - Indic := - Make_Subtype_Indication (Loc, - Subtype_Mark => New_Occurrence_Of (Btyp, Loc), - Constraint => Make_Index_Or_Discriminant_Constraint (Loc, C)); - - Def_Id := Create_Itype (Ekind (T), Related_Node); - - Subtyp_Decl := - Make_Subtype_Declaration (Loc, - Defining_Identifier => Def_Id, - Subtype_Indication => Indic); - - Set_Parent (Subtyp_Decl, Parent (Related_Node)); - - -- Itypes must be analyzed with checks off (see package Itypes) - - Analyze (Subtyp_Decl, Suppress => All_Checks); - - if Is_Itype (Def_Id) and then Has_Predicates (T) then - Inherit_Predicate_Flags (Def_Id, T); - - -- Indicate where the predicate function may be found - - if Is_Itype (T) then - if Present (Predicate_Function (Def_Id)) then - null; - - elsif Present (Predicate_Function (T)) then - Set_Predicate_Function (Def_Id, Predicate_Function (T)); - - else - Set_Predicated_Parent (Def_Id, Predicated_Parent (T)); - end if; - - elsif No (Predicate_Function (Def_Id)) then - Set_Predicated_Parent (Def_Id, T); - end if; - end if; - - return Def_Id; - end Build_Subtype; - --------------------- -- Get_Discr_Value -- --------------------- @@ -18483,38 +18407,6 @@ package body Sem_Ch3 is return Assoc_List; end Inherit_Components; - ----------------------------- - -- Inherit_Predicate_Flags -- - ----------------------------- - - procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id) is - begin - if Present (Predicate_Function (Subt)) then - return; - end if; - - Set_Has_Predicates (Subt, Has_Predicates (Par)); - Set_Has_Static_Predicate_Aspect - (Subt, Has_Static_Predicate_Aspect (Par)); - Set_Has_Dynamic_Predicate_Aspect - (Subt, Has_Dynamic_Predicate_Aspect (Par)); - - -- A named subtype does not inherit the predicate function of its - -- parent but an itype declared for a loop index needs the discrete - -- predicate information of its parent to execute the loop properly. - -- A non-discrete type may has a static predicate (for example True) - -- but has no static_discrete_predicate. - - if Is_Itype (Subt) and then Present (Predicate_Function (Par)) then - Set_Subprograms_For_Type (Subt, Subprograms_For_Type (Par)); - - if Has_Static_Predicate (Par) and then Is_Discrete_Type (Par) then - Set_Static_Discrete_Predicate - (Subt, Static_Discrete_Predicate (Par)); - end if; - end if; - end Inherit_Predicate_Flags; - ---------------------- -- Is_EVF_Procedure -- ---------------------- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index c6c8d10c796..d1c63abc9d4 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -36,6 +36,7 @@ with Exp_Ch11; use Exp_Ch11; with Exp_Util; use Exp_Util; with Fname; use Fname; with Freeze; use Freeze; +with Itypes; use Itypes; with Lib; use Lib; with Lib.Xref; use Lib.Xref; with Namet.Sp; use Namet.Sp; @@ -1683,6 +1684,78 @@ package body Sem_Util is return Decl; end Build_Component_Subtype; + ----------------------------- + -- 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; + --------------------------- -- Build_Default_Subtype -- --------------------------- @@ -2120,6 +2193,81 @@ package body Sem_Util is return New_Spec; end Build_Overriding_Spec; + ------------------- + -- Build_Subtype -- + ------------------- + + function Build_Subtype + (Related_Node : Node_Id; + Loc : Source_Ptr; + Typ : Entity_Id; + Constraints : List_Id) + return Entity_Id + is + Indic : Node_Id; + Subtyp_Decl : Node_Id; + Def_Id : Entity_Id; + Btyp : Entity_Id := Base_Type (Typ); + + begin + -- The Related_Node better be here or else we won't be able to + -- attach new itypes to a node in the tree. + + pragma Assert (Present (Related_Node)); + + -- If the view of the component's type is incomplete or private + -- with unknown discriminants, then the constraint must be applied + -- to the full type. + + if Has_Unknown_Discriminants (Btyp) + and then Present (Underlying_Type (Btyp)) + then + Btyp := Underlying_Type (Btyp); + end if; + + Indic := + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Btyp, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, Constraints)); + + Def_Id := Create_Itype (Ekind (Typ), Related_Node); + + Subtyp_Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Def_Id, + Subtype_Indication => Indic); + + Set_Parent (Subtyp_Decl, Parent (Related_Node)); + + -- Itypes must be analyzed with checks off (see package Itypes) + + Analyze (Subtyp_Decl, Suppress => All_Checks); + + if Is_Itype (Def_Id) and then Has_Predicates (Typ) then + Inherit_Predicate_Flags (Def_Id, Typ); + + -- Indicate where the predicate function may be found + + if Is_Itype (Typ) then + if Present (Predicate_Function (Def_Id)) then + null; + + elsif Present (Predicate_Function (Typ)) then + Set_Predicate_Function (Def_Id, Predicate_Function (Typ)); + + else + Set_Predicated_Parent (Def_Id, Predicated_Parent (Typ)); + end if; + + elsif No (Predicate_Function (Def_Id)) then + Set_Predicated_Parent (Def_Id, Typ); + end if; + end if; + + return Def_Id; + end Build_Subtype; + ----------------------------------- -- Cannot_Raise_Constraint_Error -- ----------------------------------- @@ -13236,6 +13384,38 @@ package body Sem_Util is return Off * (Expr_Value (Exp) - Expr_Value (Low_Bound ((Ind)))); end Indexed_Component_Bit_Offset; + ----------------------------- + -- Inherit_Predicate_Flags -- + ----------------------------- + + procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id) is + begin + if Present (Predicate_Function (Subt)) then + return; + end if; + + Set_Has_Predicates (Subt, Has_Predicates (Par)); + Set_Has_Static_Predicate_Aspect + (Subt, Has_Static_Predicate_Aspect (Par)); + Set_Has_Dynamic_Predicate_Aspect + (Subt, Has_Dynamic_Predicate_Aspect (Par)); + + -- A named subtype does not inherit the predicate function of its + -- parent but an itype declared for a loop index needs the discrete + -- predicate information of its parent to execute the loop properly. + -- A non-discrete type may has a static predicate (for example True) + -- but has no static_discrete_predicate. + + if Is_Itype (Subt) and then Present (Predicate_Function (Par)) then + Set_Subprograms_For_Type (Subt, Subprograms_For_Type (Par)); + + if Has_Static_Predicate (Par) and then Is_Discrete_Type (Par) then + Set_Static_Discrete_Predicate + (Subt, Static_Discrete_Predicate (Par)); + end if; + end if; + end Inherit_Predicate_Flags; + ---------------------------- -- Inherit_Rep_Item_Chain -- ---------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 25318441270..07619fcde36 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -273,6 +273,27 @@ package Sem_Util is -- through a type-specific wrapper for all inherited subprograms that -- may have a modified condition. + 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 Build_Subtype, but now + -- those two routines behave differently for types with unknown + -- discriminants. They are both exported in from this package in the hope + -- to eventually unify them (a not duplicate them even more until then). + + -- ??? 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 Build_Default_Subtype (T : Entity_Id; N : Node_Id) return Entity_Id; @@ -291,14 +312,6 @@ package Sem_Util is -- the compilation unit, and install it in the Elaboration_Entity field -- of Spec_Id, the entity for the compilation unit. - function Build_Overriding_Spec - (Op : Node_Id; - Typ : Entity_Id) return Node_Id; - -- Build a subprogram specification for the wrapper of an inherited - -- operation with a modified pre- or postcondition (See AI12-0113). - -- Op is the parent operation, and Typ is the descendant type that - -- inherits the operation. - procedure Build_Explicit_Dereference (Expr : Node_Id; Disc : Entity_Id); @@ -308,6 +321,30 @@ package Sem_Util is -- loaded with both interpretations, and the dereference interpretation -- carries the name of the reference discriminant. + function Build_Overriding_Spec + (Op : Node_Id; + Typ : Entity_Id) return Node_Id; + -- Build a subprogram specification for the wrapper of an inherited + -- operation with a modified pre- or postcondition (See AI12-0113). + -- Op is the parent operation, and Typ is the descendant type that + -- inherits the operation. + + function Build_Subtype + (Related_Node : Node_Id; + Loc : Source_Ptr; + Typ : Entity_Id; + Constraints : List_Id) + return Entity_Id; + -- Typ is an array or discriminated type, Constraints is a list of + -- constraints that apply to Typ. This routine builds the constrained + -- subtype using Loc as the source location and attached this subtype + -- declaration to Related_Node. The returned subtype inherits predicates + -- from Typ. + + -- ??? The routine is mostly a duplicate of Build_Constrained_Itype, so be + -- careful which of the two better suits your needs (and certainly do not + -- duplicate their code). + function Cannot_Raise_Constraint_Error (Expr : Node_Id) return Boolean; -- Returns True if the expression cannot possibly raise Constraint_Error. -- The response is conservative in the sense that a result of False does @@ -1485,6 +1522,10 @@ package Sem_Util is -- either the value is not yet known before back-end processing or it is -- not known at compile time after back-end processing. + procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id); + -- Propagate static and dynamic predicate flags from a parent to the + -- subtype in a subtype declaration with and without constraints. + procedure Inherit_Rep_Item_Chain (Typ : Entity_Id; From_Typ : Entity_Id); -- Inherit the rep item chain of type From_Typ without clobbering any -- existing rep items on Typ's chain. Typ is the destination type. -- 2.30.2