[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 --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb
index eb62b2b05a1c8afd357ee4755bff0be9c82987ae..ae62a9d6aaec5e4082b4f20af59c7d844a3388e5 100644 (file)
--- 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 ae6d13fb7ea631b970597e2a245695d57bafd54f..97d1d64454681ca37bb4cc58f6ffdcb7e50566c9 100644 (file)
--- 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 47c5b4759292f145557652471446f191c8fb9274..87abe9a683054452a3881a86beb07b8d36e8d7c2 100644 (file)
--- 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 878b4c5118cbc28d1289b4ea8225045a359413ff..fda31776eb0a18a791142b2bfbc836bb90fd9fff 100644 (file)
--- 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 2c04084b625464df1b83c79cb43099e2be45e007..83393c880c948818fa37d95be25b3d3c0149ebb5 100644 (file)
--- 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 fa17c8b5cbfe46fa4ce863926b599c2b230dbc88..869d014250992be4474b5a0cbb19faa82acd774c 100644 (file)
--- 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 5a7e3841804fb8d77d8636a38dfe1e798f7ecc8e..8991df31087f1b8cdc3faf0df0328e83c2a654aa 100644 (file)
--- 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 a5a58157c7eb724a9a7ef2d70f0a97f55e39365f..ff52378d56090457b7ba39d1827dd9595747e70e 100644 (file)
--- 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 2dfe34d305b3e7757321f199005a6ee3f84db8b2..03fcfe4421f46ccfc9de74360966b300125d26e7 100644 (file)
--- 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);