From patchwork Fri May 7 09:38:23 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Pierre-Marie de Rodat X-Patchwork-Id: 1475427 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (sender SPF authorized) smtp.mailfrom=gcc.gnu.org (client-ip=8.43.85.97; helo=sourceware.org; envelope-from=gcc-patches-bounces@gcc.gnu.org; receiver=) Received: from sourceware.org (server2.sourceware.org [8.43.85.97]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange X25519 server-signature RSA-PSS (4096 bits) server-digest SHA256) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 4Fc54n0JMyz9sj5 for ; Fri, 7 May 2021 19:39:21 +1000 (AEST) Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 3F1B1393A40A; Fri, 7 May 2021 09:38:33 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from rock.gnat.com (rock.gnat.com [IPv6:2620:20:4000:0:a9e:1ff:fe9b:1d1]) by sourceware.org (Postfix) with ESMTP id 4749038930F1 for ; Fri, 7 May 2021 09:38:23 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.3.2 sourceware.org 4749038930F1 Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=adacore.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=derodat@adacore.com Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 1F7255635B; Fri, 7 May 2021 05:38:23 -0400 (EDT) X-Virus-Scanned: Debian amavisd-new at gnat.com Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id vCQA7iYZ54oZ; Fri, 7 May 2021 05:38:23 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [IPv6:2620:20:4000:0:46a8:42ff:fe0e:e294]) by rock.gnat.com (Postfix) with ESMTP id 0B4C156357; Fri, 7 May 2021 05:38:23 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4862) id 0A711FA; Fri, 7 May 2021 05:38:23 -0400 (EDT) Date: Fri, 7 May 2021 05:38:23 -0400 From: Pierre-Marie de Rodat To: gcc-patches@gcc.gnu.org Subject: [Ada] Implement aspect No_Controlled_Parts Message-ID: <20210507093823.GA140607@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) X-Spam-Status: No, score=-12.1 required=5.0 tests=BAYES_00, GIT_PATCH_0, KAM_ASCII_DIVIDERS, KAM_DMARC_STATUS, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.2 X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Cc: Justin Squirek Errors-To: gcc-patches-bounces@gcc.gnu.org Sender: "Gcc-patches" 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. 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 + $;