From b97813ab96391d0c7bd518d31855a9db4960c770 Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Fri, 28 Feb 2020 12:46:58 +0100 Subject: [PATCH] [Ada] Propagate DIC, Invariant and Predicate attributes to views 2020-06-09 Eric Botcazou gcc/ada/ * checks.adb (Apply_Predicate_Check): Extend trick used for aggregates to qualified aggregates and object declarations * einfo.ads (Has_Own_DIC): Mention the underlying full view. (Has_Own_Invariants): Likewise. (Has_Predicates): Likewise. * exp_util.adb (Build_DIC_Procedure_Declaration): Do not deal with base types explicitly but with underlying full views. (Build_Invariant_Procedure_Declaration): Likewise. * sem_ch13.adb (Build_Predicate_Functions): Do not deal with the full view manually but call Propagate_Predicate_Attributes to propagate attributes to views. (Build_Predicate_Function_Declaration): Likewise. * sem_ch3.adb (Build_Assertion_Bodies_For_Type): Build bodies for private full views with an underlying full view. (Build_Derived_Private_Type): Small comment tweak. (Complete_Private_Subtype): Call Propagate_Predicate_Attributes. (Process_Full_View): Do not deal with base types explicitly for DIC and Invariant attributes. Deal with underlying full views for them. Call Propagate_Predicate_Attributes and deal with underlying full views for them. * sem_ch7.adb (Preserve_Full_Attributes): Do not cross propagate DIC and Invariant attributes between full type and its base type. Propagate Predicate attributes from the full to the private view. * sem_ch9.adb (Analyze_Protected_Type_Declaration): Likewise. (Analyze_Task_Type_Declaration): Likewise. * sem_util.ads (Get_Views): Remove Full_Base parameter and add UFull_Typ parameter. (Propagate_Predicate_Attributes): New procedure. * sem_util.adb (Get_Views): Remove Full_Base parameter and add UFull_Typ parameter. Retrieve the Corresponding_Record_Type from the underlying full view, if any. (Propagate_DIC_Attributes): Remove useless tests. (Propagate_Invariant_Attributes): Likewise. (Propagate_Predicate_Attributes): New procedure. --- gcc/ada/checks.adb | 42 +++++++++++++++++-------- gcc/ada/einfo.ads | 13 +++++--- gcc/ada/exp_util.adb | 33 ++++++++++++-------- gcc/ada/sem_ch13.adb | 66 ++++++++++++++++++++++++++++++---------- gcc/ada/sem_ch3.adb | 60 ++++++++++++++++++------------------ gcc/ada/sem_ch7.adb | 24 +++------------ gcc/ada/sem_ch9.adb | 10 ++++++ gcc/ada/sem_util.adb | 86 ++++++++++++++++++++++++++++++++++++++-------------- gcc/ada/sem_util.ads | 16 +++++++--- 9 files changed, 230 insertions(+), 120 deletions(-) diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index eb62b2b..ae62a9d 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -2711,7 +2711,8 @@ package body Checks is Typ : Entity_Id; Fun : Entity_Id := Empty) is - S : Entity_Id; + Par : Node_Id; + S : Entity_Id; begin if Predicate_Checks_Suppressed (Empty) then @@ -2807,6 +2808,11 @@ package body Checks is return; end if; + Par := Parent (N); + if Nkind (Par) = N_Qualified_Expression then + Par := Parent (Par); + end if; + -- For an entity of the type, generate a call to the predicate -- function, unless its type is an actual subtype, which is not -- visible outside of the enclosing subprogram. @@ -2818,24 +2824,36 @@ package body Checks is Make_Predicate_Check (Typ, New_Occurrence_Of (Entity (N), Sloc (N)))); - -- If the expression is not an entity it may have side effects, - -- and the following call will create an object declaration for - -- it. We disable checks during its analysis, to prevent an - -- infinite recursion. - - -- If the prefix is an aggregate in an assignment, apply the - -- check to the LHS after assignment, rather than create a + -- If the expression is an aggregate in an assignment, apply the + -- check to the LHS after the assignment, rather than create a -- redundant temporary. This is only necessary in rare cases -- of array types (including strings) initialized with an -- aggregate with an "others" clause, either coming from source -- or generated by an Initialize_Scalars pragma. - elsif Nkind (N) = N_Aggregate - and then Nkind (Parent (N)) = N_Assignment_Statement + elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) + and then Nkind (Par) = N_Assignment_Statement then - Insert_Action_After (Parent (N), + Insert_Action_After (Par, Make_Predicate_Check - (Typ, Duplicate_Subexpr (Name (Parent (N))))); + (Typ, Duplicate_Subexpr (Name (Par)))); + + -- Similarly, if the expression is an aggregate in an object + -- declaration, apply it to the object after the declaration. + -- This is only necessary in rare cases of tagged extensions + -- initialized with an aggregate with an "others => <>" clause. + + elsif Nkind_In (N, N_Aggregate, N_Extension_Aggregate) + and then Nkind (Par) = N_Object_Declaration + then + Insert_Action_After (Par, + Make_Predicate_Check (Typ, + New_Occurrence_Of (Defining_Identifier (Par), Sloc (N)))); + + -- If the expression is not an entity it may have side effects, + -- and the following call will create an object declaration for + -- it. We disable checks during its analysis, to prevent an + -- infinite recursion. else Insert_Action (N, diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index ae6d13f..97d1d64 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1848,12 +1848,16 @@ package Einfo is -- Has_Own_DIC (Flag3) [base type only] -- Defined in all type entities. Set for a private type and its full view --- when the type is subject to pragma Default_Initial_Condition. +-- (and its underlying full view, if the full view is itsef private) when +-- the type is subject to pragma Default_Initial_Condition. -- Has_Own_Invariants (Flag232) [base type only] -- Defined in all type entities. Set on any type that defines at least --- one invariant of its own. The flag is also set on the full view of a --- private type for completeness. +-- one invariant of its own. + +-- Note: this flag is set on both partial and full view of types to which +-- an Invariant pragma or aspect applies, and on the underlying full view +-- if the full view is private. -- Has_Partial_Visible_Refinement (Flag296) -- Defined in E_Abstract_State entities. Set when a state has at least @@ -1973,7 +1977,8 @@ package Einfo is -- Predicate aspect from its parent or progenitor types. -- -- Note: this flag is set on both partial and full view of types to which --- a Predicate pragma or aspect applies. +-- a Predicate pragma or aspect applies, and on the underlying full view +-- if the full view is private. -- Has_Primitive_Operations (Flag120) [base type only] -- Defined in all type entities. Set if at least one primitive operation diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 47c5b47..87abe9a 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1961,9 +1961,6 @@ package body Exp_Util is CRec_Typ : Entity_Id; -- The corresponding record type of Full_Typ - Full_Base : Entity_Id; - -- The base type of Full_Typ - Full_Typ : Entity_Id; -- The full view of working type @@ -1973,6 +1970,9 @@ package body Exp_Util is Priv_Typ : Entity_Id; -- The partial view of working type + UFull_Typ : Entity_Id; + -- The underlying full view of Full_Typ + Work_Typ : Entity_Id; -- The working type @@ -2063,13 +2063,13 @@ package body Exp_Util is -- Obtain all views of the input type - Get_Views (Work_Typ, Priv_Typ, Full_Typ, Full_Base, CRec_Typ); + Get_Views (Work_Typ, Priv_Typ, Full_Typ, UFull_Typ, CRec_Typ); - -- Associate the DIC procedure and various relevant flags with all views + -- Associate the DIC procedure and various flags with all views Propagate_DIC_Attributes (Priv_Typ, From_Typ => Work_Typ); Propagate_DIC_Attributes (Full_Typ, From_Typ => Work_Typ); - Propagate_DIC_Attributes (Full_Base, From_Typ => Work_Typ); + Propagate_DIC_Attributes (UFull_Typ, From_Typ => Work_Typ); Propagate_DIC_Attributes (CRec_Typ, From_Typ => Work_Typ); -- The declaration of the DIC procedure must be inserted after the @@ -3087,11 +3087,18 @@ package body Exp_Util is begin Work_Typ := Typ; + -- Do not process the underlying full view of a private type. There is + -- no way to get back to the partial view, plus the body will be built + -- by the full view or the base type. + + if Is_Underlying_Full_View (Work_Typ) then + return; + -- The input type denotes the implementation base type of a constrained -- array type. Work with the first subtype as all invariant pragmas are -- on its rep item chain. - if Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then + elsif Ekind (Work_Typ) = E_Array_Type and then Is_Itype (Work_Typ) then Work_Typ := First_Subtype (Work_Typ); -- The input type denotes the corresponding record type of a protected @@ -3420,9 +3427,6 @@ package body Exp_Util is CRec_Typ : Entity_Id; -- The corresponding record type of Full_Typ - Full_Base : Entity_Id; - -- The base type of Full_Typ - Full_Typ : Entity_Id; -- The full view of working type @@ -3435,6 +3439,9 @@ package body Exp_Util is Priv_Typ : Entity_Id; -- The partial view of working type + UFull_Typ : Entity_Id; + -- The underlying full view of Full_Typ + Work_Typ : Entity_Id; -- The working type @@ -3520,13 +3527,13 @@ package body Exp_Util is -- Obtain all views of the input type - Get_Views (Work_Typ, Priv_Typ, Full_Typ, Full_Base, CRec_Typ); + Get_Views (Work_Typ, Priv_Typ, Full_Typ, UFull_Typ, CRec_Typ); - -- Associate the invariant procedure with all views + -- Associate the invariant procedure and various flags with all views Propagate_Invariant_Attributes (Priv_Typ, From_Typ => Work_Typ); Propagate_Invariant_Attributes (Full_Typ, From_Typ => Work_Typ); - Propagate_Invariant_Attributes (Full_Base, From_Typ => Work_Typ); + Propagate_Invariant_Attributes (UFull_Typ, From_Typ => Work_Typ); Propagate_Invariant_Attributes (CRec_Typ, From_Typ => Work_Typ); -- The declaration of the invariant procedure is inserted after the diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 878b4c5..fda3177 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -9077,12 +9077,6 @@ package body Sem_Ch13 is Set_Ekind (SIdB, E_Function); Set_Is_Predicate_Function (SIdB); - -- The predicate function is shared between views of a type - - if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then - Set_Predicate_Function (Full_View (Typ), SId); - end if; - -- Build function body Spec := @@ -9196,6 +9190,18 @@ package body Sem_Ch13 is FDecl : Node_Id; BTemp : Entity_Id; + CRec_Typ : Entity_Id; + -- The corresponding record type of Full_Typ + + Full_Typ : Entity_Id; + -- The full view of Typ + + Priv_Typ : Entity_Id; + -- The partial view of Typ + + UFull_Typ : Entity_Id; + -- The underlying full view of Full_Typ + begin -- Mark any raise expressions for special expansion @@ -9207,11 +9213,16 @@ package body Sem_Ch13 is Set_Is_Predicate_Function_M (SId); Set_Predicate_Function_M (Typ, SId); - -- The predicate function is shared between views of a type + -- Obtain all views of the input type - if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then - Set_Predicate_Function_M (Full_View (Typ), SId); - end if; + Get_Views (Typ, Priv_Typ, Full_Typ, UFull_Typ, CRec_Typ); + + -- Associate the predicate function with all views + + Propagate_Predicate_Attributes (Priv_Typ, From_Typ => Typ); + Propagate_Predicate_Attributes (Full_Typ, From_Typ => Typ); + Propagate_Predicate_Attributes (UFull_Typ, From_Typ => Typ); + Propagate_Predicate_Attributes (CRec_Typ, From_Typ => Typ); Spec := Make_Function_Specification (Loc, @@ -9391,6 +9402,18 @@ package body Sem_Ch13 is Func_Id : Entity_Id; Spec : Node_Id; + CRec_Typ : Entity_Id; + -- The corresponding record type of Full_Typ + + Full_Typ : Entity_Id; + -- The full view of Typ + + Priv_Typ : Entity_Id; + -- The partial view of Typ + + UFull_Typ : Entity_Id; + -- The underlying full view of Full_Typ + begin -- The related type may be subject to pragma Ghost. Set the mode now to -- ensure that the predicate functions are properly marked as Ghost. @@ -9401,6 +9424,12 @@ package body Sem_Ch13 is Make_Defining_Identifier (Loc, Chars => New_External_Name (Chars (Typ), "Predicate")); + Set_Ekind (Func_Id, E_Function); + Set_Etype (Func_Id, Standard_Boolean); + Set_Is_Internal (Func_Id); + Set_Is_Predicate_Function (Func_Id); + Set_Predicate_Function (Typ, Func_Id); + -- The predicate function requires debug info when the predicates are -- subject to Source Coverage Obligations. @@ -9408,6 +9437,17 @@ package body Sem_Ch13 is Set_Debug_Info_Needed (Func_Id); end if; + -- Obtain all views of the input type + + Get_Views (Typ, Priv_Typ, Full_Typ, UFull_Typ, CRec_Typ); + + -- Associate the predicate function and various flags with all views + + Propagate_Predicate_Attributes (Priv_Typ, From_Typ => Typ); + Propagate_Predicate_Attributes (Full_Typ, From_Typ => Typ); + Propagate_Predicate_Attributes (UFull_Typ, From_Typ => Typ); + Propagate_Predicate_Attributes (CRec_Typ, From_Typ => Typ); + Spec := Make_Function_Specification (Loc, Defining_Unit_Name => Func_Id, @@ -9420,12 +9460,6 @@ package body Sem_Ch13 is Func_Decl := Make_Subprogram_Declaration (Loc, Specification => Spec); - Set_Ekind (Func_Id, E_Function); - Set_Etype (Func_Id, Standard_Boolean); - Set_Is_Internal (Func_Id); - Set_Is_Predicate_Function (Func_Id); - Set_Predicate_Function (Typ, Func_Id); - Insert_After (Parent (Typ), Func_Decl); Analyze (Func_Decl); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 2c04084..83393c8 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2332,7 +2332,8 @@ package body Sem_Ch3 is -- potential errors. elsif Decls = Private_Declarations (Context) - and then not Is_Private_Type (Typ) + and then (not Is_Private_Type (Typ) + or else Present (Underlying_Full_View (Typ))) and then Has_Private_Declaration (Typ) and then Has_Invariants (Typ) then @@ -7929,7 +7930,7 @@ package body Sem_Ch3 is -- completion, the derived private type being built is a full view -- and the full derivation can only be its underlying full view. - -- ??? If the parent is untagged private and its completion is + -- ??? If the parent type is untagged private and its completion is -- tagged, this mechanism will not work because we cannot derive from -- the tagged full view unless we have an extension. @@ -12346,15 +12347,7 @@ package body Sem_Ch3 is -- Propagate predicates - if Has_Predicates (Full_Base) then - Set_Has_Predicates (Full); - - if Present (Predicate_Function (Full_Base)) - and then No (Predicate_Function (Full)) - then - Set_Predicate_Function (Full, Predicate_Function (Full_Base)); - end if; - end if; + Propagate_Predicate_Attributes (Full, Full_Base); end if; -- It is unsafe to share the bounds of a scalar type, because the Itype @@ -12499,15 +12492,7 @@ package body Sem_Ch3 is -- of the type or at the end of the visible part, and we must avoid -- generating them twice. - if Has_Predicates (Priv) then - Set_Has_Predicates (Full); - - if Present (Predicate_Function (Priv)) - and then No (Predicate_Function (Full)) - then - Set_Predicate_Function (Full, Predicate_Function (Priv)); - end if; - end if; + Propagate_Predicate_Attributes (Full, Priv); if Has_Delayed_Aspects (Priv) then Set_Has_Delayed_Aspects (Full); @@ -20801,16 +20786,32 @@ package body Sem_Ch3 is end if; -- Propagate Default_Initial_Condition-related attributes from the - -- partial view to the full view and its base type. + -- partial view to the full view. Propagate_DIC_Attributes (Full_T, From_Typ => Priv_T); - Propagate_DIC_Attributes (Base_Type (Full_T), From_Typ => Priv_T); + + -- And to the underlying full view, if any + + if Is_Private_Type (Full_T) + and then Present (Underlying_Full_View (Full_T)) + then + Propagate_DIC_Attributes + (Underlying_Full_View (Full_T), From_Typ => Priv_T); + end if; -- Propagate invariant-related attributes from the partial view to the - -- full view and its base type. + -- full view. Propagate_Invariant_Attributes (Full_T, From_Typ => Priv_T); - Propagate_Invariant_Attributes (Base_Type (Full_T), From_Typ => Priv_T); + + -- And to the underlying full view, if any + + if Is_Private_Type (Full_T) + and then Present (Underlying_Full_View (Full_T)) + then + Propagate_Invariant_Attributes + (Underlying_Full_View (Full_T), From_Typ => Priv_T); + end if; -- AI12-0041: Detect an attempt to inherit a class-wide type invariant -- in the full view without advertising the inheritance in the partial @@ -20841,12 +20842,13 @@ package body Sem_Ch3 is -- view cannot be frozen yet, and the predicate function has not been -- built. Still it is a cheap check and seems safer to make it. - if Has_Predicates (Priv_T) then - Set_Has_Predicates (Full_T); + Propagate_Predicate_Attributes (Full_T, Priv_T); - if Present (Predicate_Function (Priv_T)) then - Set_Predicate_Function (Full_T, Predicate_Function (Priv_T)); - end if; + if Is_Private_Type (Full_T) + and then Present (Underlying_Full_View (Full_T)) + then + Propagate_Predicate_Attributes + (Underlying_Full_View (Full_T), Priv_T); end if; <> diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index fa17c8b..869d014 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -2739,34 +2739,20 @@ package body Sem_Ch7 is Set_Freeze_Node (Priv, Freeze_Node (Full)); -- Propagate Default_Initial_Condition-related attributes from the - -- base type of the full view to the full view and vice versa. This - -- may seem strange, but is necessary depending on which type - -- triggered the generation of the DIC procedure body. As a result, - -- both the full view and its base type carry the same DIC-related - -- information. - - Propagate_DIC_Attributes (Full, From_Typ => Full_Base); - Propagate_DIC_Attributes (Full_Base, From_Typ => Full); - - -- Propagate Default_Initial_Condition-related attributes from the -- full view to the private view. Propagate_DIC_Attributes (Priv, From_Typ => Full); - -- Propagate invariant-related attributes from the base type of the - -- full view to the full view and vice versa. This may seem strange, - -- but is necessary depending on which type triggered the generation - -- of the invariant procedure body. As a result, both the full view - -- and its base type carry the same invariant-related information. - - Propagate_Invariant_Attributes (Full, From_Typ => Full_Base); - Propagate_Invariant_Attributes (Full_Base, From_Typ => Full); - -- Propagate invariant-related attributes from the full view to the -- private view. Propagate_Invariant_Attributes (Priv, From_Typ => Full); + -- Propagate predicate-related attributes from the full view to the + -- private view. + + Propagate_Predicate_Attributes (Priv, From_Typ => Full); + if Is_Tagged_Type (Priv) and then Is_Tagged_Type (Full) and then not Error_Posted (Full) diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 5a7e384..8991df3 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -2250,6 +2250,11 @@ package body Sem_Ch9 is Propagate_Invariant_Attributes (T, From_Typ => Def_Id); + -- Propagate predicate-related attributes from the private type to + -- the protected type. + + Propagate_Predicate_Attributes (T, From_Typ => Def_Id); + -- Create corresponding record now, because some private dependents -- may be subtypes of the partial view. @@ -3246,6 +3251,11 @@ package body Sem_Ch9 is Propagate_Invariant_Attributes (T, From_Typ => Def_Id); + -- Propagate predicate-related attributes from the private type to + -- task type. + + Propagate_Predicate_Attributes (T, From_Typ => Def_Id); + -- Create corresponding record now, because some private dependents -- may be subtypes of the partial view. diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index a5a5815..ff52378 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -10289,7 +10289,7 @@ package body Sem_Util is (Typ : Entity_Id; Priv_Typ : out Entity_Id; Full_Typ : out Entity_Id; - Full_Base : out Entity_Id; + UFull_Typ : out Entity_Id; CRec_Typ : out Entity_Id) is IP_View : Entity_Id; @@ -10299,7 +10299,7 @@ package body Sem_Util is Priv_Typ := Empty; Full_Typ := Empty; - Full_Base := Empty; + UFull_Typ := Empty; CRec_Typ := Empty; -- The input type is the corresponding record type of a protected or a @@ -10308,10 +10308,9 @@ package body Sem_Util is if Ekind (Typ) = E_Record_Type and then Is_Concurrent_Record_Type (Typ) then - CRec_Typ := Typ; - Full_Typ := Corresponding_Concurrent_Type (CRec_Typ); - Full_Base := Base_Type (Full_Typ); - Priv_Typ := Incomplete_Or_Partial_View (Full_Typ); + CRec_Typ := Typ; + Full_Typ := Corresponding_Concurrent_Type (CRec_Typ); + Priv_Typ := Incomplete_Or_Partial_View (Full_Typ); -- Otherwise the input type denotes an arbitrary type @@ -10336,10 +10335,19 @@ package body Sem_Util is Full_Typ := Typ; end if; - if Present (Full_Typ) then - Full_Base := Base_Type (Full_Typ); + if Present (Full_Typ) and then Is_Private_Type (Full_Typ) then + UFull_Typ := Underlying_Full_View (Full_Typ); - if Ekind_In (Full_Typ, E_Protected_Type, E_Task_Type) then + if Present (UFull_Typ) + and then Ekind_In (UFull_Typ, E_Protected_Type, E_Task_Type) + then + CRec_Typ := Corresponding_Record_Type (UFull_Typ); + end if; + + else + if Present (Full_Typ) + and then Ekind_In (Full_Typ, E_Protected_Type, E_Task_Type) + then CRec_Typ := Corresponding_Record_Type (Full_Typ); end if; end if; @@ -23927,13 +23935,11 @@ package body Sem_Util is -- The setting of the attributes is intentionally conservative. This -- prevents accidental clobbering of enabled attributes. - if Has_Inherited_DIC (From_Typ) - and then not Has_Inherited_DIC (Typ) - then + if Has_Inherited_DIC (From_Typ) then Set_Has_Inherited_DIC (Typ); end if; - if Has_Own_DIC (From_Typ) and then not Has_Own_DIC (Typ) then + if Has_Own_DIC (From_Typ) then Set_Has_Own_DIC (Typ); end if; @@ -23971,21 +23977,15 @@ package body Sem_Util is -- The setting of the attributes is intentionally conservative. This -- prevents accidental clobbering of enabled attributes. - if Has_Inheritable_Invariants (From_Typ) - and then not Has_Inheritable_Invariants (Typ) - then + if Has_Inheritable_Invariants (From_Typ) then Set_Has_Inheritable_Invariants (Typ); end if; - if Has_Inherited_Invariants (From_Typ) - and then not Has_Inherited_Invariants (Typ) - then + if Has_Inherited_Invariants (From_Typ) then Set_Has_Inherited_Invariants (Typ); end if; - if Has_Own_Invariants (From_Typ) - and then not Has_Own_Invariants (Typ) - then + if Has_Own_Invariants (From_Typ) then Set_Has_Own_Invariants (Typ); end if; @@ -24000,6 +24000,48 @@ package body Sem_Util is end if; end Propagate_Invariant_Attributes; + ------------------------------------ + -- Propagate_Predicate_Attributes -- + ------------------------------------ + + procedure Propagate_Predicate_Attributes + (Typ : Entity_Id; + From_Typ : Entity_Id) + is + Pred_Func : Entity_Id; + Pred_Func_M : Entity_Id; + + begin + if Present (Typ) and then Present (From_Typ) then + pragma Assert (Is_Type (Typ) and then Is_Type (From_Typ)); + + -- Nothing to do if both the source and the destination denote the + -- same type. + + if From_Typ = Typ then + return; + end if; + + Pred_Func := Predicate_Function (From_Typ); + Pred_Func_M := Predicate_Function_M (From_Typ); + + -- The setting of the attributes is intentionally conservative. This + -- prevents accidental clobbering of enabled attributes. + + if Has_Predicates (From_Typ) then + Set_Has_Predicates (Typ); + end if; + + if Present (Pred_Func) and then No (Predicate_Function (Typ)) then + Set_Predicate_Function (Typ, Pred_Func); + end if; + + if Present (Pred_Func_M) and then No (Predicate_Function_M (Typ)) then + Set_Predicate_Function_M (Typ, Pred_Func_M); + end if; + end if; + end Propagate_Predicate_Attributes; + --------------------------------------- -- Record_Possible_Part_Of_Reference -- --------------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 2dfe34d..03fcfe4 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1171,15 +1171,15 @@ package Sem_Util is (Typ : Entity_Id; Priv_Typ : out Entity_Id; Full_Typ : out Entity_Id; - Full_Base : out Entity_Id; + UFull_Typ : out Entity_Id; CRec_Typ : out Entity_Id); - -- Obtain the partial and full view of type Typ and in addition any extra - -- types the full view may have. The return entities are as follows: + -- Obtain the partial and full views of type Typ and in addition any extra + -- types the full views may have. The return entities are as follows: -- -- Priv_Typ - the partial view (a private type) -- Full_Typ - the full view - -- Full_Base - the base type of the full view - -- CRec_Typ - the corresponding record type of the full view + -- UFull_Typ - the underlying full view, if the full view is private + -- CRec_Typ - the corresponding record type of the full views function Has_Access_Values (T : Entity_Id) return Boolean; -- Returns true if type or subtype T is an access type, or has a component @@ -2547,6 +2547,12 @@ package Sem_Util is -- Inherit all invariant-related attributes form type From_Typ. Typ is the -- destination type. + procedure Propagate_Predicate_Attributes + (Typ : Entity_Id; + From_Typ : Entity_Id); + -- Inherit some predicate-related attributes form type From_Typ. Typ is the + -- destination type. Probably to be completed with more attributes??? + procedure Record_Possible_Part_Of_Reference (Var_Id : Entity_Id; Ref : Node_Id); -- 2.7.4