[Ada] Propagate DIC, Invariant and Predicate attributes to views
2020-06-09 Eric Botcazou <ebotcazou@adacore.com> 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.
This commit is contained in:
Eric Botcazou
Pierre-Marie de Rodat
parent
bf2480e2fb
commit
b97813ab96
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
|
||||
<<Leave>>
|
||||
|
|
|
|||
|
|
@ -2738,35 +2738,21 @@ 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)
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
||||
|
|
|
|||
|
|
@ -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 --
|
||||
---------------------------------------
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
Loading…
Reference in New Issue