[gcc(refs/users/aoliva/heads/testbase)] [Ada] Propagate DIC, Invariant and Predicate attributes to views
Alexandre Oliva
aoliva@gcc.gnu.org
Wed Jun 10 03:09:11 GMT 2020
https://gcc.gnu.org/g:b97813ab96391d0c7bd518d31855a9db4960c770
commit b97813ab96391d0c7bd518d31855a9db4960c770
Author: Eric Botcazou <ebotcazou@adacore.com>
Date: Fri Feb 28 12:46:58 2020 +0100
[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.
Diff:
---
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 eb62b2b05a1..ae62a9d6aae 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 ae6d13fb7ea..97d1d644546 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 47c5b475929..87abe9a6830 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 878b4c5118c..fda31776eb0 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 2c04084b625..83393c880c9 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;
<<Leave>>
diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb
index fa17c8b5cbf..869d0142509 100644
--- a/gcc/ada/sem_ch7.adb
+++ b/gcc/ada/sem_ch7.adb
@@ -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)
diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb
index 5a7e3841804..8991df31087 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 a5a58157c7e..ff52378d560 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 2dfe34d305b..03fcfe4421f 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);
More information about the Gcc-cvs
mailing list