This change is a step towards propagating more consistently the DIC,
Invariant and Predicate attributes between different views of the
same type, in particular to the newly built underlying full views.
It also cleans up the handling of the base types for the DIC and
Invariant attributes, which looks obsolete since everything related
to DIC and Invariant is already done on the base types, so doing it
again explicitly on them is superfluous.
Tested on x86_64-pc-linux-gnu, committed on trunk
2020-06-09 Eric Botcazou <ebotca...@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.--- gcc/ada/checks.adb
+++ 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,
--- gcc/ada/einfo.ads
+++ 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
--- gcc/ada/exp_util.adb
+++ 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
--- gcc/ada/sem_ch13.adb
+++ 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);
--- gcc/ada/sem_ch3.adb
+++ 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;
<<Leave>>
--- gcc/ada/sem_ch7.adb
+++ 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)
--- gcc/ada/sem_ch9.adb
+++ 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.
--- gcc/ada/sem_util.adb
+++ 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 --
---------------------------------------
--- gcc/ada/sem_util.ads
+++ 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);
