[Ada] Implement aspect No_Controlled_Parts

Message ID 20210507093823.GA140607@adacore.com
State New
Headers show
Series
  • [Ada] Implement aspect No_Controlled_Parts
Related show

Commit Message

Pierre-Marie de Rodat May 7, 2021, 9:38 a.m.
This patch implements the No_Controlled_Parts aspect defined in
AI12-0256 which when specified for a type will verify such type or any
ancestors of such type with contain no controlled components.

Tested on x86_64-pc-linux-gnu, committed on trunk

gcc/ada/

	* aspects.ads: Add entries to register
	Aspect_No_Controlled_Parts.
	* freeze.adb (Check_No_Controlled_Parts_Violations): Added to
	check requirements of aspect No_Controlled_Parts after a type
	has been frozen.
	(Freeze_Entity): Add call to
	Check_No_Controlled_Parts_Violations.
	(Find_Aspect_No_Controlled_Parts): Created to obtain the aspect
	specification for No_Controlled_Parts on a given type when
	present.
	(Find_Aspect_No_Controlled_Parts_Value): Protect against invalid
	value.
	(Has_Aspect_No_Controlled_Parts): Created as a prediate function
	to check if No_Controlled_Parts has been specified on a type for
	Get_Anacestor_Types_With_Specification.
	(Get_Aspect_No_Controlled_Parts_Value): Created to obtain the
	value of the aspect No_Controlled_Parts when specified on a
	given type.
	(Get_Generic_Formal_Types_In_Hierarchy): Created to collect
	formal types in a given type's hierarchy.
	(Get_Types_With_Aspect_In_Hierarchy): Created to collect types
	in a given type's hierarchy with No_Controlled_Parts specified.
	* sem_ch13.adb (Analyze_One_Aspect): Add processing for
	No_Controlled_Parts, and fix error in check for allowed pragmas
	for formal types.
	(Check_Expr_Is_OK_Static_Expression): Created to enforce
	checking of static expressions in the same vein as
	Analyze_Pragma.Check_Expr_OK_Static_Expression.
	* sem_util.adb (Collect_Types_In_Hierarchy): Created to collect
	types in a given type's hierarchy that match a given predicate
	function.
	* sem_util.ads: Fix typo.
	* snames.ads-tmpl: Add entry for No_Controlled_Parts.

Patch

diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
--- a/gcc/ada/aspects.ads
+++ b/gcc/ada/aspects.ads
@@ -116,6 +116,7 @@  package Aspects is
       Aspect_Max_Entry_Queue_Length,
       Aspect_Max_Queue_Length,              -- GNAT
       Aspect_No_Caching,                    -- GNAT
+      Aspect_No_Controlled_Parts,
       Aspect_Object_Size,                   -- GNAT
       Aspect_Obsolescent,                   -- GNAT
       Aspect_Output,
@@ -403,6 +404,7 @@  package Aspects is
       Aspect_Max_Entry_Queue_Length     => Expression,
       Aspect_Max_Queue_Length           => Expression,
       Aspect_No_Caching                 => Optional_Expression,
+      Aspect_No_Controlled_Parts        => Optional_Expression,
       Aspect_Object_Size                => Expression,
       Aspect_Obsolescent                => Optional_Expression,
       Aspect_Output                     => Name,
@@ -505,6 +507,7 @@  package Aspects is
       Aspect_Max_Entry_Queue_Length       => False,
       Aspect_Max_Queue_Length             => False,
       Aspect_No_Caching                   => False,
+      Aspect_No_Controlled_Parts          => False,
       Aspect_Object_Size                  => True,
       Aspect_Obsolescent                  => False,
       Aspect_Output                       => False,
@@ -666,6 +669,7 @@  package Aspects is
       Aspect_Max_Entry_Queue_Length       => Name_Max_Entry_Queue_Length,
       Aspect_Max_Queue_Length             => Name_Max_Queue_Length,
       Aspect_No_Caching                   => Name_No_Caching,
+      Aspect_No_Controlled_Parts          => Name_No_Controlled_Parts,
       Aspect_No_Elaboration_Code_All      => Name_No_Elaboration_Code_All,
       Aspect_No_Inline                    => Name_No_Inline,
       Aspect_No_Return                    => Name_No_Return,
@@ -960,6 +964,7 @@  package Aspects is
       Aspect_Max_Entry_Queue_Length       => Never_Delay,
       Aspect_Max_Queue_Length             => Never_Delay,
       Aspect_No_Caching                   => Never_Delay,
+      Aspect_No_Controlled_Parts          => Never_Delay,
       Aspect_No_Elaboration_Code_All      => Never_Delay,
       Aspect_No_Tagged_Streams            => Never_Delay,
       Aspect_Obsolescent                  => Never_Delay,


diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
--- a/gcc/ada/freeze.adb
+++ b/gcc/ada/freeze.adb
@@ -2192,6 +2192,11 @@  package body Freeze is
       --  which is the current instance type can only be applied when the type
       --  is limited.
 
+      procedure Check_No_Controlled_Parts_Violations (Typ : Entity_Id);
+      --  Check that Typ does not violate the semantics of aspect
+      --  No_Controlled_Parts when it is specified on Typ or one of its
+      --  ancestors.
+
       procedure Check_Suspicious_Convention (Rec_Type : Entity_Id);
       --  Give a warning for pragma Convention with language C or C++ applied
       --  to a discriminated record type. This is suppressed for the unchecked
@@ -2412,6 +2417,361 @@  package body Freeze is
          end if;
       end Check_Current_Instance;
 
+      ------------------------------------------
+      -- Check_No_Controlled_Parts_Violations --
+      ------------------------------------------
+
+      procedure Check_No_Controlled_Parts_Violations (Typ : Entity_Id) is
+
+         function Find_Aspect_No_Controlled_Parts
+           (Typ : Entity_Id) return Node_Id;
+         --  Search for aspect No_Controlled_Parts on a given type. When
+         --  the aspect is not explicity specified Empty is returned.
+
+         function Get_Aspect_No_Controlled_Parts_Value
+           (Typ : Entity_Id) return Entity_Id;
+         --  Obtain the value for the No_Controlled_Parts aspect on a given
+         --  type. When the aspect is not explicitly specified Empty is
+         --  returned.
+
+         function Has_Aspect_No_Controlled_Parts
+           (Typ : Entity_Id) return Boolean;
+         --  Predicate function which identifies whether No_Controlled_Parts
+         --  is explicitly specified on a given type.
+
+         -------------------------------------
+         -- Find_Aspect_No_Controlled_Parts --
+         -------------------------------------
+
+         function Find_Aspect_No_Controlled_Parts
+           (Typ : Entity_Id) return Node_Id
+         is
+            Partial_View : constant Entity_Id :=
+              Incomplete_Or_Partial_View (Typ);
+
+            Aspect_Spec : Entity_Id :=
+              Find_Aspect (Typ, Aspect_No_Controlled_Parts);
+            Curr_Aspect_Spec : Entity_Id;
+         begin
+
+            --  Examine Typ's associated node, when present, since aspect
+            --  specifications do not get transferred when nodes get rewritten.
+
+            --  For example, this can happen in the expansion of array types
+
+            if No (Aspect_Spec)
+              and then Present (Associated_Node_For_Itype (Typ))
+              and then Nkind (Associated_Node_For_Itype (Typ))
+                         = N_Full_Type_Declaration
+            then
+               Aspect_Spec :=
+                 Find_Aspect
+                   (Id => Defining_Identifier
+                            (Associated_Node_For_Itype (Typ)),
+                    A  => Aspect_No_Controlled_Parts);
+            end if;
+
+            --  Examine aspects specifications on private type declarations
+
+            --  Should Find_Aspect be improved to handle this case ???
+
+            if No (Aspect_Spec)
+              and then Present (Partial_View)
+              and then Present
+                         (Aspect_Specifications
+                           (Declaration_Node
+                             (Partial_View)))
+            then
+               Curr_Aspect_Spec :=
+                 First
+                   (Aspect_Specifications
+                     (Declaration_Node
+                       (Partial_View)));
+
+               --  Search through aspects present on the private type
+
+               while Present (Curr_Aspect_Spec) loop
+                  if Get_Aspect_Id (Curr_Aspect_Spec)
+                       = Aspect_No_Controlled_Parts
+                  then
+                     Aspect_Spec := Curr_Aspect_Spec;
+                     exit;
+                  end if;
+
+                  Next (Curr_Aspect_Spec);
+               end loop;
+
+            end if;
+
+            --  When errors are posted on the aspect return Empty
+
+            if Error_Posted (Aspect_Spec) then
+               return Empty;
+            end if;
+
+            return Aspect_Spec;
+         end Find_Aspect_No_Controlled_Parts;
+
+         ------------------------------------------
+         -- Get_Aspect_No_Controlled_Parts_Value --
+         ------------------------------------------
+
+         function Get_Aspect_No_Controlled_Parts_Value
+           (Typ : Entity_Id) return Entity_Id
+         is
+            Aspect_Spec : constant Entity_Id :=
+              Find_Aspect_No_Controlled_Parts (Typ);
+         begin
+
+            --  Return the value of the aspect when present
+
+            if Present (Aspect_Spec) then
+
+               --  No expression is the same as True
+
+               if No (Expression (Aspect_Spec)) then
+                  return Standard_True;
+               end if;
+
+               --  Assume its expression has already been constant folded into
+               --  a Boolean value and return its value.
+
+               return Entity (Expression (Aspect_Spec));
+            end if;
+
+            --  Otherwise, the aspect is not specified - so return Empty
+
+            return Empty;
+         end Get_Aspect_No_Controlled_Parts_Value;
+
+         ------------------------------------
+         -- Has_Aspect_No_Controlled_Parts --
+         ------------------------------------
+
+         function Has_Aspect_No_Controlled_Parts
+           (Typ : Entity_Id) return Boolean
+         is (Present (Find_Aspect_No_Controlled_Parts (Typ)));
+
+         --  Generic instances
+
+         -------------------------------------------
+         -- Get_Generic_Formal_Types_In_Hierarchy --
+         -------------------------------------------
+
+         function Get_Generic_Formal_Types_In_Hierarchy
+           is new Collect_Types_In_Hierarchy (Predicate => Is_Generic_Formal);
+         --  Return a list of all types within a given type's hierarchy which
+         --  are generic formals.
+
+         ----------------------------------------
+         -- Get_Types_With_Aspect_In_Hierarchy --
+         ----------------------------------------
+
+         function Get_Types_With_Aspect_In_Hierarchy
+           is new Collect_Types_In_Hierarchy
+                    (Predicate => Has_Aspect_No_Controlled_Parts);
+         --  Returns a list of all types within a given type's hierarchy which
+         --  have the aspect No_Controlled_Parts specified.
+
+         --  Local declarations
+
+         Types_With_Aspect : Elist_Id :=
+           Get_Types_With_Aspect_In_Hierarchy (Typ);
+
+         Aspect_Value     : Entity_Id;
+         Curr_Value       : Entity_Id;
+         Curr_Typ_Elmt    : Elmt_Id;
+         Curr_Body_Elmt   : Elmt_Id;
+         Curr_Formal_Elmt : Elmt_Id;
+         Gen_Bodies       : Elist_Id;
+         Gen_Formals      : Elist_Id;
+         Scop             : Entity_Id;
+
+      --  Start of processing for Check_No_Controlled_Parts_Violations
+
+      begin
+         --  There are no types with No_Controlled_Parts specified, so there
+         --  is nothing to check.
+
+         if Is_Empty_Elmt_List (Types_With_Aspect)
+           or else not Comes_From_Source (Typ)
+         then
+            return;
+         end if;
+
+         --  Obtain the aspect value for No_Controlled_Parts for comparison
+
+         Aspect_Value :=
+           Get_Aspect_No_Controlled_Parts_Value
+             (Node (First_Elmt (Types_With_Aspect)));
+
+         --  When the value is True and there are controlled parts or the type
+         --  itself is controlled, trigger the appropriate error.
+
+         if Aspect_Value = Standard_True
+           and then (Is_Controlled (Typ)
+                      or else Has_Controlled_Component (Typ))
+         then
+            Error_Msg_N
+              ("aspect No_Controlled_Parts applied to controlled type &", Typ);
+         end if;
+
+         --  Move through Types_With_Aspect - checking that the value specified
+         --  for their corresponding No_Controlled_Parts aspects do not
+         --  override each other.
+
+         Curr_Typ_Elmt := First_Elmt (Types_With_Aspect);
+         while Present (Curr_Typ_Elmt) loop
+            Curr_Value :=
+              Get_Aspect_No_Controlled_Parts_Value (Node (Curr_Typ_Elmt));
+
+            --  Compare the aspect value against the current type
+
+            if Curr_Value /= Aspect_Value then
+               Error_Msg_NE
+                 ("cannot override aspect No_Controlled_Parts of "
+                   & "ancestor type &", Typ, Node (Curr_Typ_Elmt));
+               return;
+            end if;
+
+            Next_Elmt (Curr_Typ_Elmt);
+         end loop;
+
+         --  Issue an error if the aspect applies to a type declared inside a
+         --  generic body and if said type derives from or has a component of
+         --  a generic formal type - since those are considered to be both
+         --  controlled and have aspect No_Controlled_Parts specified as False
+         --  by default (RM H.4.1(4/5)).
+
+         --  We do not check tagged types since deriving from a formal type
+         --  within an enclosing generic unit is already illegal
+         --  (RM 3.9.1 (4/2)).
+
+         if Aspect_Value = Standard_True
+           and then In_Generic_Body (Typ)
+           and then not Is_Tagged_Type (Typ)
+         then
+            Gen_Bodies  := New_Elmt_List;
+            Gen_Formals :=
+              Get_Generic_Formal_Types_In_Hierarchy
+                (Typ                => Typ,
+                 Examine_Components => True);
+
+            --  Climb scopes collecting generic bodies
+
+            Scop := Scope (Typ);
+            while Present (Scop) and then Scop /= Standard_Standard loop
+
+               --  Generic package body
+
+               if Ekind (Scop) = E_Generic_Package
+                 and then In_Package_Body (Scop)
+               then
+                  Append_Elmt (Scop, Gen_Bodies);
+
+               --  Generic subprogram body
+
+               elsif Is_Generic_Subprogram (Scop) then
+                  Append_Elmt (Scop, Gen_Bodies);
+               end if;
+
+               Scop := Scope (Scop);
+            end loop;
+
+            --  Warn about the improper use of No_Controlled_Parts on a type
+            --  declaration deriving from or that has a component of a generic
+            --  formal type within the formal type's corresponding generic
+            --  body by moving through all formal types in Typ's hierarchy and
+            --  checking if they are formals in any of the enclosing generic
+            --  bodies.
+
+            --  However, a special exception gets made for formal types which
+            --  derive from a type which has No_Controlled_Parts True.
+
+            --  For example:
+
+            --  generic
+            --     type Form is private;
+            --  package G is
+            --     type Type_A is new Form with No_Controlled_Parts; --  OK
+            --  end;
+            --
+            --  package body G is
+            --     type Type_B is new Form with No_Controlled_Parts; --  ERROR
+            --  end;
+
+            --  generic
+            --     type Form is private;
+            --  package G is
+            --     type Type_A is record C : Form; end record
+            --       with No_Controlled_Parts;                       --  OK
+            --  end;
+            --
+            --  package body G is
+            --     type Type_B is record C : Form; end record
+            --       with No_Controlled_Parts;                       --  ERROR
+            --  end;
+
+            --  type Root is tagged null record with No_Controlled_Parts;
+            --
+            --  generic
+            --     type Form is new Root with private;
+            --  package G is
+            --     type Type_A is record C : Form; end record
+            --       with No_Controlled_Parts;                       --  OK
+            --  end;
+            --
+            --  package body G is
+            --     type Type_B is record C : Form; end record
+            --       with No_Controlled_Parts;                       --  OK
+            --  end;
+
+            Curr_Formal_Elmt := First_Elmt (Gen_Formals);
+            while Present (Curr_Formal_Elmt) loop
+
+               Curr_Body_Elmt := First_Elmt (Gen_Bodies);
+               while Present (Curr_Body_Elmt) loop
+
+                  --  Obtain types in the formal type's hierarchy which have
+                  --  the aspect specified.
+
+                  Types_With_Aspect :=
+                    Get_Types_With_Aspect_In_Hierarchy
+                      (Node (Curr_Formal_Elmt));
+
+                  --  We found a type declaration in a generic body where both
+                  --  No_Controlled_Parts is true and one of its ancestors is a
+                  --  generic formal type.
+
+                  if Scope (Node (Curr_Formal_Elmt)) =
+                       Node (Curr_Body_Elmt)
+
+                    --  Check that no ancestors of the formal type have
+                    --  No_Controlled_Parts True before issuing the error.
+
+                    and then (Is_Empty_Elmt_List (Types_With_Aspect)
+                               or else
+                                 Get_Aspect_No_Controlled_Parts_Value
+                                   (Node (First_Elmt (Types_With_Aspect)))
+                                  = Standard_False)
+                  then
+                     Error_Msg_Node_1 := Typ;
+                     Error_Msg_Node_2 := Node (Curr_Formal_Elmt);
+                     Error_Msg
+                       ("aspect No_Controlled_Parts cannot be applied to "
+                         & "type & which has an ancestor or component of "
+                         & "formal type & within the formal type's "
+                         & "corresponding generic body", Sloc (Typ));
+                  end if;
+
+                  Next_Elmt (Curr_Body_Elmt);
+               end loop;
+
+               Next_Elmt (Curr_Formal_Elmt);
+            end loop;
+         end if;
+      end Check_No_Controlled_Parts_Violations;
+
       ---------------------------------
       -- Check_Suspicious_Convention --
       ---------------------------------
@@ -6801,6 +7161,16 @@  package body Freeze is
             end;
          end if;
 
+         --  Verify at this point that No_Controlled_Parts, when specified on
+         --  the current type or one of its ancestors, has not been overridden
+         --  and that no violation of the aspect has occurred.
+
+         --  It is important that we perform the checks here after the type has
+         --  been processed because if said type depended on a private type it
+         --  will not have been marked controlled.
+
+         Check_No_Controlled_Parts_Violations (E);
+
          --  End of freeze processing for type entities
       end if;
 


diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -1816,6 +1816,13 @@  package body Sem_Ch13 is
       Aspect := First (L);
       Aspect_Loop : while Present (Aspect) loop
          Analyze_One_Aspect : declare
+
+            Aspect_Exit : exception;
+            --  This exception is used to exit aspect processing completely. It
+            --  is used when an error is detected, and no further processing is
+            --  required. It is also used if an earlier error has left the tree
+            --  in a state where the aspect should not be processed.
+
             Expr : constant Node_Id    := Expression (Aspect);
             Id   : constant Node_Id    := Identifier (Aspect);
             Loc  : constant Source_Ptr := Sloc (Aspect);
@@ -1854,6 +1861,17 @@  package body Sem_Ch13 is
             procedure Analyze_Aspect_Static;
             --  Ada 202x (AI12-0075): Perform analysis of aspect Static
 
+            procedure Check_Expr_Is_OK_Static_Expression
+              (Expr : Node_Id;
+               Typ  : Entity_Id := Empty);
+            --  Check the specified expression Expr to make sure that it is a
+            --  static expression of the given type (i.e. it will be analyzed
+            --  and resolved using this type, which can be any valid argument
+            --  to Resolve, e.g. Any_Integer is OK). If not, give an error
+            --  and raise Aspect_Exit. If Typ is left Empty, then any static
+            --  expression is allowed. Includes checking that the expression
+            --  does not raise Constraint_Error.
+
             function Make_Aitem_Pragma
               (Pragma_Argument_Associations : List_Id;
                Pragma_Name                  : Name_Id) return Node_Id;
@@ -2711,6 +2729,42 @@  package body Sem_Ch13 is
                end if;
             end Analyze_Aspect_Yield;
 
+            ----------------------------------------
+            -- Check_Expr_Is_OK_Static_Expression --
+            ----------------------------------------
+
+            procedure Check_Expr_Is_OK_Static_Expression
+              (Expr : Node_Id;
+               Typ  : Entity_Id := Empty)
+            is
+            begin
+               if Present (Typ) then
+                  Analyze_And_Resolve (Expr, Typ);
+               else
+                  Analyze_And_Resolve (Expr);
+               end if;
+
+               --  An expression cannot be considered static if its resolution
+               --  failed or if it's erroneous. Stop the analysis of the
+               --  related aspect.
+
+               if Etype (Expr) = Any_Type or else Error_Posted (Expr) then
+                  raise Aspect_Exit;
+
+               elsif Is_OK_Static_Expression (Expr) then
+                  return;
+
+               --  Finally, we have a real error
+
+               else
+                  Error_Msg_Name_1 := Nam;
+                  Flag_Non_Static_Expr
+                    ("entity for aspect% must be a static expression",
+                     Expr);
+                  raise Aspect_Exit;
+               end if;
+            end Check_Expr_Is_OK_Static_Expression;
+
             -----------------------
             -- Make_Aitem_Pragma --
             -----------------------
@@ -2874,7 +2928,10 @@  package body Sem_Ch13 is
                --  versions of the language. Allowed for them only for
                --  shared variable control aspects.
 
-               if Nkind (N) = N_Formal_Type_Declaration then
+               --  Original node is used in case expansion rewrote the node -
+               --  as is the case with generic derived types.
+
+               if Nkind (Original_Node (N)) = N_Formal_Type_Declaration then
                   if Ada_Version < Ada_2020 then
                      Error_Msg_N
                        ("aspect % not allowed for formal type declaration",
@@ -3883,6 +3940,32 @@  package body Sem_Ch13 is
                   Insert_Pragma (Aitem);
                   goto Continue;
 
+               --  No_Controlled_Parts
+
+               when Aspect_No_Controlled_Parts =>
+
+                  --  Check appropriate type argument
+
+                  if not Is_Type (E) then
+                     Error_Msg_N
+                       ("aspect % can only be applied to types", E);
+                  end if;
+
+                  --  Disallow subtypes
+
+                  if Nkind (Declaration_Node (E)) = N_Subtype_Declaration then
+                     Error_Msg_N
+                       ("aspect % cannot be applied to subtypes", E);
+                  end if;
+
+                  --  Resolve the expression to a boolean
+
+                  if Present (Expr) then
+                     Check_Expr_Is_OK_Static_Expression (Expr, Any_Boolean);
+                  end if;
+
+                  goto Continue;
+
                --  Obsolescent
 
                when Aspect_Obsolescent => declare
@@ -4860,6 +4943,8 @@  package body Sem_Ch13 is
                   end if;
                end;
             end if;
+         exception
+            when Aspect_Exit => null;
          end Analyze_One_Aspect;
 
          Next (Aspect);
@@ -10996,6 +11081,7 @@  package body Sem_Ch13 is
             | Aspect_Max_Entry_Queue_Length
             | Aspect_Max_Queue_Length
             | Aspect_No_Caching
+            | Aspect_No_Controlled_Parts
             | Aspect_Obsolescent
             | Aspect_Part_Of
             | Aspect_Post


diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -6654,6 +6654,99 @@  package body Sem_Util is
       return N;
    end Compile_Time_Constraint_Error;
 
+   --------------------------------
+   -- Collect_Types_In_Hierarchy --
+   --------------------------------
+
+   function Collect_Types_In_Hierarchy
+     (Typ                : Entity_Id;
+      Examine_Components : Boolean := False) return Elist_Id
+   is
+      Results : Elist_Id;
+
+      procedure Process_Type (Typ : Entity_Id);
+      --  Collect type Typ if it satisfies function Predicate. Do so for its
+      --  parent type, base type, progenitor types, and any component types.
+
+      ------------------
+      -- Process_Type --
+      ------------------
+
+      procedure Process_Type (Typ : Entity_Id) is
+         Comp       : Entity_Id;
+         Iface_Elmt : Elmt_Id;
+
+      begin
+         if not Is_Type (Typ) or else Error_Posted (Typ) then
+            return;
+         end if;
+
+         --  Collect the current type if it satisfies the predicate
+
+         if Predicate (Typ) then
+            Append_Elmt (Typ, Results);
+         end if;
+
+         --  Process component types
+
+         if Examine_Components then
+
+            --  Examine components and discriminants
+
+            if Is_Concurrent_Type (Typ)
+              or else Is_Incomplete_Or_Private_Type (Typ)
+              or else Is_Record_Type (Typ)
+              or else Has_Discriminants (Typ)
+            then
+               Comp := First_Component_Or_Discriminant (Typ);
+
+               while Present (Comp) loop
+                  Process_Type (Etype (Comp));
+
+                  Next_Component_Or_Discriminant (Comp);
+               end loop;
+
+            --  Examine array components
+
+            elsif Ekind (Typ) = E_Array_Type then
+               Process_Type (Component_Type (Typ));
+            end if;
+         end if;
+
+         --  Examine parent type
+
+         if Etype (Typ) /= Typ then
+            Process_Type (Etype (Typ));
+         end if;
+
+         --  Examine base type
+
+         if Base_Type (Typ) /= Typ then
+            Process_Type (Base_Type (Typ));
+         end if;
+
+         --  Examine interfaces
+
+         if Is_Record_Type (Typ)
+           and then Present (Interfaces (Typ))
+         then
+            Iface_Elmt := First_Elmt (Interfaces (Typ));
+            while Present (Iface_Elmt) loop
+               Process_Type (Node (Iface_Elmt));
+
+               Next_Elmt (Iface_Elmt);
+            end loop;
+         end if;
+      end Process_Type;
+
+   --  Start of processing for Collect_Types_In_Hierarchy
+
+   begin
+      Results := New_Elmt_List;
+      Process_Type (Typ);
+      return Results;
+   end Collect_Types_In_Hierarchy;
+
    -----------------------
    -- Conditional_Delay --
    -----------------------


diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -581,6 +581,18 @@  package Sem_Util is
    --  emitted immediately after the main message (and before output of any
    --  message indicating that Constraint_Error will be raised).
 
+   generic
+      with function Predicate (Typ : Entity_Id) return Boolean;
+   function Collect_Types_In_Hierarchy
+     (Typ                : Entity_Id;
+      Examine_Components : Boolean := False) return Elist_Id;
+   --  Inspect the ancestor and progenitor types of Typ and Typ itself -
+   --  collecting those for which function Predicate is True. The resulting
+   --  list is ordered in a type-to-ultimate-ancestor fashion.
+
+   --  When Examine_Components is True, components types in the hierarchy also
+   --  get collected.
+
    procedure Conditional_Delay (New_Ent, Old_Ent : Entity_Id);
    --  Sets the Has_Delayed_Freeze flag of New_Ent if the Delayed_Freeze flag
    --  of Old_Ent is set and Old_Ent has not yet been Frozen (i.e. Is_Frozen is


diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -145,6 +145,7 @@  package Snames is
    Name_Exclusive_Functions            : constant Name_Id := N + $;
    Name_Full_Access_Only               : constant Name_Id := N + $;
    Name_Integer_Literal                : constant Name_Id := N + $;
+   Name_No_Controlled_Parts            : constant Name_Id := N + $;
    Name_Real_Literal                   : constant Name_Id := N + $;
    Name_Relaxed_Initialization         : constant Name_Id := N + $;
    Name_Stable_Properties              : constant Name_Id := N + $;