| ------------------------------------------------------------------------------ |
| -- -- |
| -- GNAT COMPILER COMPONENTS -- |
| -- -- |
| -- S E M _ A U X -- |
| -- -- |
| -- B o d y -- |
| -- -- |
| -- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- |
| -- -- |
| -- GNAT is free software; you can redistribute it and/or modify it under -- |
| -- terms of the GNU General Public License as published by the Free Soft- -- |
| -- ware Foundation; either version 3, or (at your option) any later ver- -- |
| -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- |
| -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- |
| -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- |
| -- for more details. You should have received a copy of the GNU General -- |
| -- Public License distributed with GNAT; see file COPYING3. If not, go to -- |
| -- http://www.gnu.org/licenses for a complete copy of the license. -- |
| -- -- |
| -- GNAT was originally developed by the GNAT team at New York University. -- |
| -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
| -- -- |
| ------------------------------------------------------------------------------ |
| |
| with Atree; use Atree; |
| with Einfo; use Einfo; |
| with Einfo.Entities; use Einfo.Entities; |
| with Einfo.Utils; use Einfo.Utils; |
| with Nlists; use Nlists; |
| with Sinfo; use Sinfo; |
| with Sinfo.Nodes; use Sinfo.Nodes; |
| with Sinfo.Utils; use Sinfo.Utils; |
| with Snames; use Snames; |
| with Stand; use Stand; |
| with Uintp; use Uintp; |
| |
| package body Sem_Aux is |
| |
| ---------------------- |
| -- Ancestor_Subtype -- |
| ---------------------- |
| |
| function Ancestor_Subtype (Typ : Entity_Id) return Entity_Id is |
| begin |
| -- If this is first subtype, or is a base type, then there is no |
| -- ancestor subtype, so we return Empty to indicate this fact. |
| |
| if Is_First_Subtype (Typ) or else Is_Base_Type (Typ) then |
| return Empty; |
| end if; |
| |
| declare |
| D : constant Node_Id := Declaration_Node (Typ); |
| |
| begin |
| -- If we have a subtype declaration, get the ancestor subtype |
| |
| if Nkind (D) = N_Subtype_Declaration then |
| if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then |
| return Entity (Subtype_Mark (Subtype_Indication (D))); |
| else |
| return Entity (Subtype_Indication (D)); |
| end if; |
| |
| -- If not, then no subtype indication is available |
| |
| else |
| return Empty; |
| end if; |
| end; |
| end Ancestor_Subtype; |
| |
| -------------------- |
| -- Available_View -- |
| -------------------- |
| |
| function Available_View (Ent : Entity_Id) return Entity_Id is |
| begin |
| -- Obtain the non-limited view (if available) |
| |
| if Has_Non_Limited_View (Ent) then |
| return Get_Full_View (Non_Limited_View (Ent)); |
| |
| -- In all other cases, return entity unchanged |
| |
| else |
| return Ent; |
| end if; |
| end Available_View; |
| |
| -------------------- |
| -- Constant_Value -- |
| -------------------- |
| |
| function Constant_Value (Ent : Entity_Id) return Node_Id is |
| D : constant Node_Id := Declaration_Node (Ent); |
| Full_D : Node_Id; |
| |
| begin |
| -- If we have no declaration node, then return no constant value. Not |
| -- clear how this can happen, but it does sometimes and this is the |
| -- safest approach. |
| |
| if No (D) then |
| return Empty; |
| |
| -- Normal case where a declaration node is present |
| |
| elsif Nkind (D) = N_Object_Renaming_Declaration then |
| return Renamed_Object (Ent); |
| |
| -- If this is a component declaration whose entity is a constant, it is |
| -- a prival within a protected function (and so has no constant value). |
| |
| elsif Nkind (D) = N_Component_Declaration then |
| return Empty; |
| |
| -- If there is an expression, return it |
| |
| elsif Present (Expression (D)) then |
| return Expression (D); |
| |
| -- For a constant, see if we have a full view |
| |
| elsif Ekind (Ent) = E_Constant |
| and then Present (Full_View (Ent)) |
| then |
| Full_D := Parent (Full_View (Ent)); |
| |
| -- The full view may have been rewritten as an object renaming |
| |
| if Nkind (Full_D) = N_Object_Renaming_Declaration then |
| return Name (Full_D); |
| else |
| return Expression (Full_D); |
| end if; |
| |
| -- Otherwise we have no expression to return |
| |
| else |
| return Empty; |
| end if; |
| end Constant_Value; |
| |
| --------------------------------- |
| -- Corresponding_Unsigned_Type -- |
| --------------------------------- |
| |
| function Corresponding_Unsigned_Type (Typ : Entity_Id) return Entity_Id is |
| pragma Assert (Is_Signed_Integer_Type (Typ)); |
| Siz : constant Uint := Esize (Base_Type (Typ)); |
| begin |
| if Siz = Esize (Standard_Short_Short_Integer) then |
| return Standard_Short_Short_Unsigned; |
| elsif Siz = Esize (Standard_Short_Integer) then |
| return Standard_Short_Unsigned; |
| elsif Siz = Esize (Standard_Unsigned) then |
| return Standard_Unsigned; |
| elsif Siz = Esize (Standard_Long_Integer) then |
| return Standard_Long_Unsigned; |
| elsif Siz = Esize (Standard_Long_Long_Integer) then |
| return Standard_Long_Long_Unsigned; |
| elsif Siz = Esize (Standard_Long_Long_Long_Integer) then |
| return Standard_Long_Long_Long_Unsigned; |
| else |
| raise Program_Error; |
| end if; |
| end Corresponding_Unsigned_Type; |
| |
| ----------------------------- |
| -- Enclosing_Dynamic_Scope -- |
| ----------------------------- |
| |
| function Enclosing_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is |
| S : Entity_Id; |
| |
| begin |
| -- The following test is an error defense against some syntax errors |
| -- that can leave scopes very messed up. |
| |
| if Ent = Standard_Standard then |
| return Ent; |
| end if; |
| |
| -- Normal case, search enclosing scopes |
| |
| -- Note: the test for Present (S) should not be required, it defends |
| -- against an ill-formed tree. |
| |
| S := Scope (Ent); |
| loop |
| -- If we somehow got an empty value for Scope, the tree must be |
| -- malformed. Rather than blow up we return Standard in this case. |
| |
| if No (S) then |
| return Standard_Standard; |
| |
| -- Quit if we get to standard or a dynamic scope. We must also |
| -- handle enclosing scopes that have a full view; required to |
| -- locate enclosing scopes that are synchronized private types |
| -- whose full view is a task type. |
| |
| elsif S = Standard_Standard |
| or else Is_Dynamic_Scope (S) |
| or else (Is_Private_Type (S) |
| and then Present (Full_View (S)) |
| and then Is_Dynamic_Scope (Full_View (S))) |
| then |
| return S; |
| |
| -- Otherwise keep climbing |
| |
| else |
| S := Scope (S); |
| end if; |
| end loop; |
| end Enclosing_Dynamic_Scope; |
| |
| ------------------------ |
| -- First_Discriminant -- |
| ------------------------ |
| |
| function First_Discriminant (Typ : Entity_Id) return Entity_Id is |
| Ent : Entity_Id; |
| |
| begin |
| pragma Assert |
| (Has_Discriminants (Typ) or else Has_Unknown_Discriminants (Typ)); |
| |
| Ent := First_Entity (Typ); |
| |
| -- The discriminants are not necessarily contiguous, because access |
| -- discriminants will generate itypes. They are not the first entities |
| -- either because the tag must be ahead of them. |
| |
| if Chars (Ent) = Name_uTag then |
| Next_Entity (Ent); |
| end if; |
| |
| -- Skip all hidden stored discriminants if any |
| |
| while Present (Ent) loop |
| exit when Ekind (Ent) = E_Discriminant |
| and then not Is_Completely_Hidden (Ent); |
| |
| Next_Entity (Ent); |
| end loop; |
| |
| -- Call may be on a private type with unknown discriminants, in which |
| -- case Ent is Empty, and as per the spec, we return Empty in this case. |
| |
| -- Historical note: The assertion in previous versions that Ent is a |
| -- discriminant was overly cautious and prevented convenient application |
| -- of this function in the gnatprove context. |
| |
| return Ent; |
| end First_Discriminant; |
| |
| ------------------------------- |
| -- First_Stored_Discriminant -- |
| ------------------------------- |
| |
| function First_Stored_Discriminant (Typ : Entity_Id) return Entity_Id is |
| Ent : Entity_Id; |
| |
| function Has_Completely_Hidden_Discriminant |
| (Typ : Entity_Id) return Boolean; |
| -- Scans the Discriminants to see whether any are Completely_Hidden |
| -- (the mechanism for describing non-specified stored discriminants) |
| -- Note that the entity list for the type may contain anonymous access |
| -- types created by expressions that constrain access discriminants. |
| |
| ---------------------------------------- |
| -- Has_Completely_Hidden_Discriminant -- |
| ---------------------------------------- |
| |
| function Has_Completely_Hidden_Discriminant |
| (Typ : Entity_Id) return Boolean |
| is |
| Ent : Entity_Id; |
| |
| begin |
| pragma Assert (Ekind (Typ) = E_Discriminant); |
| |
| Ent := Typ; |
| while Present (Ent) loop |
| |
| -- Skip anonymous types that may be created by expressions |
| -- used as discriminant constraints on inherited discriminants. |
| |
| if Is_Itype (Ent) then |
| null; |
| |
| elsif Ekind (Ent) = E_Discriminant |
| and then Is_Completely_Hidden (Ent) |
| then |
| return True; |
| end if; |
| |
| Next_Entity (Ent); |
| end loop; |
| |
| return False; |
| end Has_Completely_Hidden_Discriminant; |
| |
| -- Start of processing for First_Stored_Discriminant |
| |
| begin |
| pragma Assert |
| (Has_Discriminants (Typ) |
| or else Has_Unknown_Discriminants (Typ)); |
| |
| Ent := First_Entity (Typ); |
| |
| if Chars (Ent) = Name_uTag then |
| Next_Entity (Ent); |
| end if; |
| |
| if Has_Completely_Hidden_Discriminant (Ent) then |
| while Present (Ent) loop |
| exit when Ekind (Ent) = E_Discriminant |
| and then Is_Completely_Hidden (Ent); |
| Next_Entity (Ent); |
| end loop; |
| end if; |
| |
| pragma Assert (Ekind (Ent) = E_Discriminant); |
| |
| return Ent; |
| end First_Stored_Discriminant; |
| |
| ------------------- |
| -- First_Subtype -- |
| ------------------- |
| |
| function First_Subtype (Typ : Entity_Id) return Entity_Id is |
| B : constant Entity_Id := Base_Type (Typ); |
| F : Node_Id := Freeze_Node (B); |
| Ent : Entity_Id; |
| |
| begin |
| -- The freeze node of a ghost type might have been rewritten in a null |
| -- statement by the time gigi calls First_Subtype on the corresponding |
| -- type. |
| |
| if Nkind (F) = N_Null_Statement then |
| F := Original_Node (F); |
| end if; |
| |
| -- If the base type has no freeze node, it is a type in Standard, and |
| -- always acts as its own first subtype, except where it is one of the |
| -- predefined integer types. If the type is formal, it is also a first |
| -- subtype, and its base type has no freeze node. On the other hand, a |
| -- subtype of a generic formal is not its own first subtype. Its base |
| -- type, if anonymous, is attached to the formal type declaration from |
| -- which the first subtype is obtained. |
| |
| if No (F) then |
| if B = Base_Type (Standard_Integer) then |
| return Standard_Integer; |
| |
| elsif B = Base_Type (Standard_Long_Integer) then |
| return Standard_Long_Integer; |
| |
| elsif B = Base_Type (Standard_Short_Short_Integer) then |
| return Standard_Short_Short_Integer; |
| |
| elsif B = Base_Type (Standard_Short_Integer) then |
| return Standard_Short_Integer; |
| |
| elsif B = Base_Type (Standard_Long_Long_Integer) then |
| return Standard_Long_Long_Integer; |
| |
| elsif B = Base_Type (Standard_Long_Long_Long_Integer) then |
| return Standard_Long_Long_Long_Integer; |
| |
| elsif Is_Generic_Type (Typ) then |
| if Present (Parent (B)) then |
| return Defining_Identifier (Parent (B)); |
| else |
| return Defining_Identifier (Associated_Node_For_Itype (B)); |
| end if; |
| |
| else |
| return B; |
| end if; |
| |
| -- Otherwise we check the freeze node, if it has a First_Subtype_Link |
| -- then we use that link, otherwise (happens with some Itypes), we use |
| -- the base type itself. |
| |
| else |
| Ent := First_Subtype_Link (F); |
| |
| if Present (Ent) then |
| return Ent; |
| else |
| return B; |
| end if; |
| end if; |
| end First_Subtype; |
| |
| ------------------------- |
| -- First_Tag_Component -- |
| ------------------------- |
| |
| function First_Tag_Component (Typ : Entity_Id) return Entity_Id is |
| Comp : Entity_Id; |
| Ctyp : Entity_Id; |
| |
| begin |
| Ctyp := Typ; |
| pragma Assert (Is_Tagged_Type (Ctyp)); |
| |
| if Is_Class_Wide_Type (Ctyp) then |
| Ctyp := Root_Type (Ctyp); |
| end if; |
| |
| if Is_Private_Type (Ctyp) then |
| Ctyp := Underlying_Type (Ctyp); |
| |
| -- If the underlying type is missing then the source program has |
| -- errors and there is nothing else to do (the full-type declaration |
| -- associated with the private type declaration is missing). |
| |
| if No (Ctyp) then |
| return Empty; |
| end if; |
| end if; |
| |
| Comp := First_Entity (Ctyp); |
| while Present (Comp) loop |
| if Is_Tag (Comp) then |
| return Comp; |
| end if; |
| |
| Next_Entity (Comp); |
| end loop; |
| |
| -- No tag component found |
| |
| return Empty; |
| end First_Tag_Component; |
| |
| ----------------------- |
| -- Get_Called_Entity -- |
| ----------------------- |
| |
| function Get_Called_Entity (Call : Node_Id) return Entity_Id is |
| Nam : constant Node_Id := Name (Call); |
| Id : Entity_Id; |
| |
| begin |
| if Nkind (Nam) = N_Explicit_Dereference then |
| Id := Etype (Nam); |
| pragma Assert (Ekind (Id) = E_Subprogram_Type); |
| |
| elsif Nkind (Nam) = N_Selected_Component then |
| Id := Entity (Selector_Name (Nam)); |
| |
| elsif Nkind (Nam) = N_Indexed_Component then |
| Id := Entity (Selector_Name (Prefix (Nam))); |
| |
| else |
| Id := Entity (Nam); |
| end if; |
| |
| return Id; |
| end Get_Called_Entity; |
| |
| ------------------ |
| -- Get_Rep_Item -- |
| ------------------ |
| |
| function Get_Rep_Item |
| (E : Entity_Id; |
| Nam : Name_Id; |
| Check_Parents : Boolean := True) return Node_Id |
| is |
| N : Node_Id; |
| |
| begin |
| N := First_Rep_Item (E); |
| while Present (N) loop |
| |
| -- Only one of Priority / Interrupt_Priority can be specified, so |
| -- return whichever one is present to catch illegal duplication. |
| |
| if Nkind (N) = N_Pragma |
| and then |
| (Pragma_Name_Unmapped (N) = Nam |
| or else (Nam = Name_Priority |
| and then Pragma_Name (N) = |
| Name_Interrupt_Priority) |
| or else (Nam = Name_Interrupt_Priority |
| and then Pragma_Name (N) = Name_Priority)) |
| then |
| if Check_Parents then |
| return N; |
| |
| -- If Check_Parents is False, return N if the pragma doesn't |
| -- appear in the Rep_Item chain of the parent. |
| |
| else |
| declare |
| Par : constant Entity_Id := Nearest_Ancestor (E); |
| -- This node represents the parent type of type E (if any) |
| |
| begin |
| if No (Par) then |
| return N; |
| |
| elsif not Present_In_Rep_Item (Par, N) then |
| return N; |
| end if; |
| end; |
| end if; |
| |
| elsif Nkind (N) = N_Attribute_Definition_Clause |
| and then |
| (Chars (N) = Nam |
| or else (Nam = Name_Priority |
| and then Chars (N) = Name_Interrupt_Priority)) |
| then |
| if Check_Parents or else Entity (N) = E then |
| return N; |
| end if; |
| |
| elsif Nkind (N) = N_Aspect_Specification |
| and then |
| (Chars (Identifier (N)) = Nam |
| or else |
| (Nam = Name_Priority |
| and then Chars (Identifier (N)) = Name_Interrupt_Priority)) |
| then |
| if Check_Parents then |
| return N; |
| |
| elsif Entity (N) = E then |
| return N; |
| end if; |
| |
| -- A Ghost-related aspect, if disabled, may have been replaced by a |
| -- null statement. |
| |
| elsif Nkind (N) = N_Null_Statement then |
| N := Original_Node (N); |
| end if; |
| |
| Next_Rep_Item (N); |
| end loop; |
| |
| return Empty; |
| end Get_Rep_Item; |
| |
| function Get_Rep_Item |
| (E : Entity_Id; |
| Nam1 : Name_Id; |
| Nam2 : Name_Id; |
| Check_Parents : Boolean := True) return Node_Id |
| is |
| Nam1_Item : constant Node_Id := Get_Rep_Item (E, Nam1, Check_Parents); |
| Nam2_Item : constant Node_Id := Get_Rep_Item (E, Nam2, Check_Parents); |
| |
| N : Node_Id; |
| |
| begin |
| -- Check both Nam1_Item and Nam2_Item are present |
| |
| if No (Nam1_Item) then |
| return Nam2_Item; |
| elsif No (Nam2_Item) then |
| return Nam1_Item; |
| end if; |
| |
| -- Return the first node encountered in the list |
| |
| N := First_Rep_Item (E); |
| while Present (N) loop |
| if N = Nam1_Item or else N = Nam2_Item then |
| return N; |
| end if; |
| |
| Next_Rep_Item (N); |
| end loop; |
| |
| return Empty; |
| end Get_Rep_Item; |
| |
| -------------------- |
| -- Get_Rep_Pragma -- |
| -------------------- |
| |
| function Get_Rep_Pragma |
| (E : Entity_Id; |
| Nam : Name_Id; |
| Check_Parents : Boolean := True) return Node_Id |
| is |
| N : constant Node_Id := Get_Rep_Item (E, Nam, Check_Parents); |
| |
| begin |
| if Present (N) and then Nkind (N) = N_Pragma then |
| return N; |
| end if; |
| |
| return Empty; |
| end Get_Rep_Pragma; |
| |
| function Get_Rep_Pragma |
| (E : Entity_Id; |
| Nam1 : Name_Id; |
| Nam2 : Name_Id; |
| Check_Parents : Boolean := True) return Node_Id |
| is |
| Nam1_Item : constant Node_Id := Get_Rep_Pragma (E, Nam1, Check_Parents); |
| Nam2_Item : constant Node_Id := Get_Rep_Pragma (E, Nam2, Check_Parents); |
| |
| N : Node_Id; |
| |
| begin |
| -- Check both Nam1_Item and Nam2_Item are present |
| |
| if No (Nam1_Item) then |
| return Nam2_Item; |
| elsif No (Nam2_Item) then |
| return Nam1_Item; |
| end if; |
| |
| -- Return the first node encountered in the list |
| |
| N := First_Rep_Item (E); |
| while Present (N) loop |
| if N = Nam1_Item or else N = Nam2_Item then |
| return N; |
| end if; |
| |
| Next_Rep_Item (N); |
| end loop; |
| |
| return Empty; |
| end Get_Rep_Pragma; |
| |
| --------------------------------- |
| -- Has_External_Tag_Rep_Clause -- |
| --------------------------------- |
| |
| function Has_External_Tag_Rep_Clause (T : Entity_Id) return Boolean is |
| begin |
| pragma Assert (Is_Tagged_Type (T)); |
| return Has_Rep_Item (T, Name_External_Tag, Check_Parents => False); |
| end Has_External_Tag_Rep_Clause; |
| |
| ------------------ |
| -- Has_Rep_Item -- |
| ------------------ |
| |
| function Has_Rep_Item |
| (E : Entity_Id; |
| Nam : Name_Id; |
| Check_Parents : Boolean := True) return Boolean |
| is |
| begin |
| return Present (Get_Rep_Item (E, Nam, Check_Parents)); |
| end Has_Rep_Item; |
| |
| function Has_Rep_Item |
| (E : Entity_Id; |
| Nam1 : Name_Id; |
| Nam2 : Name_Id; |
| Check_Parents : Boolean := True) return Boolean |
| is |
| begin |
| return Present (Get_Rep_Item (E, Nam1, Nam2, Check_Parents)); |
| end Has_Rep_Item; |
| |
| -------------------- |
| -- Has_Rep_Pragma -- |
| -------------------- |
| |
| function Has_Rep_Pragma |
| (E : Entity_Id; |
| Nam : Name_Id; |
| Check_Parents : Boolean := True) return Boolean |
| is |
| begin |
| return Present (Get_Rep_Pragma (E, Nam, Check_Parents)); |
| end Has_Rep_Pragma; |
| |
| function Has_Rep_Pragma |
| (E : Entity_Id; |
| Nam1 : Name_Id; |
| Nam2 : Name_Id; |
| Check_Parents : Boolean := True) return Boolean |
| is |
| begin |
| return Present (Get_Rep_Pragma (E, Nam1, Nam2, Check_Parents)); |
| end Has_Rep_Pragma; |
| |
| -------------------------------- |
| -- Has_Unconstrained_Elements -- |
| -------------------------------- |
| |
| function Has_Unconstrained_Elements (T : Entity_Id) return Boolean is |
| U_T : constant Entity_Id := Underlying_Type (T); |
| begin |
| if No (U_T) then |
| return False; |
| elsif Is_Record_Type (U_T) then |
| return Has_Discriminants (U_T) and then not Is_Constrained (U_T); |
| elsif Is_Array_Type (U_T) then |
| return Has_Unconstrained_Elements (Component_Type (U_T)); |
| else |
| return False; |
| end if; |
| end Has_Unconstrained_Elements; |
| |
| ---------------------- |
| -- Has_Variant_Part -- |
| ---------------------- |
| |
| function Has_Variant_Part (Typ : Entity_Id) return Boolean is |
| FSTyp : Entity_Id; |
| Decl : Node_Id; |
| TDef : Node_Id; |
| CList : Node_Id; |
| |
| begin |
| if not Is_Type (Typ) then |
| return False; |
| end if; |
| |
| FSTyp := First_Subtype (Typ); |
| |
| if not Has_Discriminants (FSTyp) then |
| return False; |
| end if; |
| |
| -- Proceed with cautious checks here, return False if tree is not |
| -- as expected (may be caused by prior errors). |
| |
| Decl := Declaration_Node (FSTyp); |
| |
| if Nkind (Decl) /= N_Full_Type_Declaration then |
| return False; |
| end if; |
| |
| TDef := Type_Definition (Decl); |
| |
| if Nkind (TDef) /= N_Record_Definition then |
| return False; |
| end if; |
| |
| CList := Component_List (TDef); |
| |
| if Nkind (CList) /= N_Component_List then |
| return False; |
| else |
| return Present (Variant_Part (CList)); |
| end if; |
| end Has_Variant_Part; |
| |
| --------------------- |
| -- In_Generic_Body -- |
| --------------------- |
| |
| function In_Generic_Body (Id : Entity_Id) return Boolean is |
| S : Entity_Id; |
| |
| begin |
| -- Climb scopes looking for generic body |
| |
| S := Id; |
| while Present (S) and then S /= Standard_Standard loop |
| |
| -- Generic package body |
| |
| if Ekind (S) = E_Generic_Package |
| and then In_Package_Body (S) |
| then |
| return True; |
| |
| -- Generic subprogram body |
| |
| elsif Is_Subprogram (S) |
| and then Nkind (Unit_Declaration_Node (S)) = |
| N_Generic_Subprogram_Declaration |
| then |
| return True; |
| end if; |
| |
| S := Scope (S); |
| end loop; |
| |
| -- False if top of scope stack without finding a generic body |
| |
| return False; |
| end In_Generic_Body; |
| |
| ------------------------------- |
| -- Initialization_Suppressed -- |
| ------------------------------- |
| |
| function Initialization_Suppressed (Typ : Entity_Id) return Boolean is |
| begin |
| return Suppress_Initialization (Typ) |
| or else Suppress_Initialization (Base_Type (Typ)); |
| end Initialization_Suppressed; |
| |
| ---------------- |
| -- Initialize -- |
| ---------------- |
| |
| procedure Initialize is |
| begin |
| Obsolescent_Warnings.Init; |
| end Initialize; |
| |
| ------------- |
| -- Is_Body -- |
| ------------- |
| |
| function Is_Body (N : Node_Id) return Boolean is |
| begin |
| return Nkind (N) in |
| N_Body_Stub | N_Entry_Body | N_Package_Body | N_Protected_Body | |
| N_Subprogram_Body | N_Task_Body; |
| end Is_Body; |
| |
| --------------------- |
| -- Is_By_Copy_Type -- |
| --------------------- |
| |
| function Is_By_Copy_Type (Ent : Entity_Id) return Boolean is |
| begin |
| -- If Id is a private type whose full declaration has not been seen, |
| -- we assume for now that it is not a By_Copy type. Clearly this |
| -- attribute should not be used before the type is frozen, but it is |
| -- needed to build the associated record of a protected type. Another |
| -- place where some lookahead for a full view is needed ??? |
| |
| return |
| Is_Elementary_Type (Ent) |
| or else (Is_Private_Type (Ent) |
| and then Present (Underlying_Type (Ent)) |
| and then Is_Elementary_Type (Underlying_Type (Ent))); |
| end Is_By_Copy_Type; |
| |
| -------------------------- |
| -- Is_By_Reference_Type -- |
| -------------------------- |
| |
| function Is_By_Reference_Type (Ent : Entity_Id) return Boolean is |
| Btype : constant Entity_Id := Base_Type (Ent); |
| |
| begin |
| if Is_Private_Type (Btype) then |
| declare |
| Utyp : constant Entity_Id := Underlying_Type (Btype); |
| begin |
| if No (Utyp) then |
| return False; |
| else |
| return Is_By_Reference_Type (Utyp); |
| end if; |
| end; |
| |
| elsif Is_Incomplete_Type (Btype) then |
| declare |
| Ftyp : constant Entity_Id := Full_View (Btype); |
| begin |
| -- Return true for a tagged incomplete type built as a shadow |
| -- entity in Build_Limited_Views. It can appear in the profile |
| -- of a thunk and the back end needs to know how it is passed. |
| |
| if No (Ftyp) then |
| return Is_Tagged_Type (Btype); |
| else |
| return Is_By_Reference_Type (Ftyp); |
| end if; |
| end; |
| |
| elsif Is_Concurrent_Type (Btype) then |
| return True; |
| |
| elsif Is_Record_Type (Btype) then |
| if Is_Limited_Record (Btype) |
| or else Is_Tagged_Type (Btype) |
| or else Is_Volatile (Btype) |
| then |
| return True; |
| |
| else |
| declare |
| C : Entity_Id; |
| |
| begin |
| C := First_Component (Btype); |
| while Present (C) loop |
| |
| -- For each component, test if its type is a by reference |
| -- type and if its type is volatile. Also test the component |
| -- itself for being volatile. This happens for example when |
| -- a Volatile aspect is added to a component. |
| |
| if Is_By_Reference_Type (Etype (C)) |
| or else Is_Volatile (Etype (C)) |
| or else Is_Volatile (C) |
| then |
| return True; |
| end if; |
| |
| Next_Component (C); |
| end loop; |
| end; |
| |
| return False; |
| end if; |
| |
| elsif Is_Array_Type (Btype) then |
| return |
| Is_Volatile (Btype) |
| or else Is_By_Reference_Type (Component_Type (Btype)) |
| or else Is_Volatile (Component_Type (Btype)) |
| or else Has_Volatile_Components (Btype); |
| |
| else |
| return False; |
| end if; |
| end Is_By_Reference_Type; |
| |
| ------------------------- |
| -- Is_Definite_Subtype -- |
| ------------------------- |
| |
| function Is_Definite_Subtype (T : Entity_Id) return Boolean is |
| pragma Assert (Is_Type (T)); |
| K : constant Entity_Kind := Ekind (T); |
| |
| begin |
| if Is_Constrained (T) then |
| return True; |
| |
| elsif K in Array_Kind |
| or else K in Class_Wide_Kind |
| or else Has_Unknown_Discriminants (T) |
| then |
| return False; |
| |
| -- Known discriminants: definite if there are default values. Note that |
| -- if any discriminant has a default, they all do. |
| |
| elsif Has_Discriminants (T) then |
| return Present (Discriminant_Default_Value (First_Discriminant (T))); |
| |
| else |
| return True; |
| end if; |
| end Is_Definite_Subtype; |
| |
| --------------------- |
| -- Is_Derived_Type -- |
| --------------------- |
| |
| function Is_Derived_Type (Ent : E) return B is |
| Par : Node_Id; |
| |
| begin |
| if Is_Type (Ent) |
| and then Base_Type (Ent) /= Root_Type (Ent) |
| and then not Is_Class_Wide_Type (Ent) |
| |
| -- An access_to_subprogram whose result type is a limited view can |
| -- appear in a return statement, without the full view of the result |
| -- type being available. Do not interpret this as a derived type. |
| |
| and then Ekind (Ent) /= E_Subprogram_Type |
| then |
| if not Is_Numeric_Type (Root_Type (Ent)) then |
| return True; |
| |
| else |
| Par := Parent (First_Subtype (Ent)); |
| |
| return Present (Par) |
| and then Nkind (Par) = N_Full_Type_Declaration |
| and then Nkind (Type_Definition (Par)) = |
| N_Derived_Type_Definition; |
| end if; |
| |
| else |
| return False; |
| end if; |
| end Is_Derived_Type; |
| |
| ----------------------- |
| -- Is_Generic_Formal -- |
| ----------------------- |
| |
| function Is_Generic_Formal (E : Entity_Id) return Boolean is |
| Kind : Node_Kind; |
| |
| begin |
| if No (E) then |
| return False; |
| else |
| -- Formal derived types are rewritten as private extensions, so |
| -- examine original node. |
| |
| Kind := Nkind (Original_Node (Parent (E))); |
| |
| return |
| Kind in N_Formal_Object_Declaration | N_Formal_Type_Declaration |
| or else Is_Formal_Subprogram (E) |
| or else |
| (Ekind (E) = E_Package |
| and then Nkind (Original_Node (Unit_Declaration_Node (E))) = |
| N_Formal_Package_Declaration); |
| end if; |
| end Is_Generic_Formal; |
| |
| ------------------------------- |
| -- Is_Immutably_Limited_Type -- |
| ------------------------------- |
| |
| function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is |
| Btype : constant Entity_Id := Available_View (Base_Type (Ent)); |
| |
| begin |
| if Is_Limited_Record (Btype) then |
| return True; |
| |
| elsif Ekind (Btype) = E_Limited_Private_Type |
| and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration |
| then |
| return not In_Package_Body (Scope ((Btype))); |
| |
| elsif Is_Private_Type (Btype) then |
| |
| -- AI05-0063: A type derived from a limited private formal type is |
| -- not immutably limited in a generic body. |
| |
| if Is_Derived_Type (Btype) |
| and then Is_Generic_Type (Etype (Btype)) |
| then |
| if not Is_Limited_Type (Etype (Btype)) then |
| return False; |
| |
| -- A descendant of a limited formal type is not immutably limited |
| -- in the generic body, or in the body of a generic child. |
| |
| elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then |
| return not In_Package_Body (Scope (Btype)); |
| |
| else |
| return False; |
| end if; |
| |
| else |
| declare |
| Utyp : constant Entity_Id := Underlying_Type (Btype); |
| begin |
| if No (Utyp) then |
| return False; |
| else |
| return Is_Immutably_Limited_Type (Utyp); |
| end if; |
| end; |
| end if; |
| |
| elsif Is_Concurrent_Type (Btype) then |
| return True; |
| |
| else |
| return False; |
| end if; |
| end Is_Immutably_Limited_Type; |
| |
| --------------------- |
| -- Is_Limited_Type -- |
| --------------------- |
| |
| function Is_Limited_Type (Ent : Entity_Id) return Boolean is |
| Btype : Entity_Id; |
| Rtype : Entity_Id; |
| |
| begin |
| if not Is_Type (Ent) then |
| return False; |
| end if; |
| |
| Btype := Base_Type (Ent); |
| Rtype := Root_Type (Btype); |
| |
| if Ekind (Btype) = E_Limited_Private_Type |
| or else Is_Limited_Composite (Btype) |
| then |
| return True; |
| |
| elsif Is_Concurrent_Type (Btype) then |
| return True; |
| |
| -- The Is_Limited_Record flag normally indicates that the type is |
| -- limited. The exception is that a type does not inherit limitedness |
| -- from its interface ancestor. So the type may be derived from a |
| -- limited interface, but is not limited. |
| |
| elsif Is_Limited_Record (Ent) |
| and then not Is_Interface (Ent) |
| then |
| return True; |
| |
| -- Otherwise we will look around to see if there is some other reason |
| -- for it to be limited, except that if an error was posted on the |
| -- entity, then just assume it is non-limited, because it can cause |
| -- trouble to recurse into a murky entity resulting from other errors. |
| |
| elsif Error_Posted (Ent) then |
| return False; |
| |
| elsif Is_Record_Type (Btype) then |
| |
| if Is_Limited_Interface (Ent) then |
| return True; |
| |
| -- AI-419: limitedness is not inherited from a limited interface |
| |
| elsif Is_Limited_Record (Rtype) then |
| return not Is_Interface (Rtype) |
| or else Is_Protected_Interface (Rtype) |
| or else Is_Synchronized_Interface (Rtype) |
| or else Is_Task_Interface (Rtype); |
| |
| elsif Is_Class_Wide_Type (Btype) then |
| return Is_Limited_Type (Rtype); |
| |
| else |
| declare |
| C : E; |
| |
| begin |
| C := First_Component (Btype); |
| while Present (C) loop |
| if Is_Limited_Type (Etype (C)) then |
| return True; |
| end if; |
| |
| Next_Component (C); |
| end loop; |
| end; |
| |
| return False; |
| end if; |
| |
| elsif Is_Array_Type (Btype) then |
| return Is_Limited_Type (Component_Type (Btype)); |
| |
| else |
| return False; |
| end if; |
| end Is_Limited_Type; |
| |
| --------------------- |
| -- Is_Limited_View -- |
| --------------------- |
| |
| function Is_Limited_View (Ent : Entity_Id) return Boolean is |
| Btype : constant Entity_Id := Available_View (Base_Type (Ent)); |
| |
| begin |
| if Is_Limited_Record (Btype) then |
| return True; |
| |
| elsif Ekind (Btype) = E_Limited_Private_Type |
| and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration |
| then |
| return not In_Package_Body (Scope ((Btype))); |
| |
| elsif Is_Private_Type (Btype) then |
| |
| -- AI05-0063: A type derived from a limited private formal type is |
| -- not immutably limited in a generic body. |
| |
| if Is_Derived_Type (Btype) |
| and then Is_Generic_Type (Etype (Btype)) |
| then |
| if not Is_Limited_Type (Etype (Btype)) then |
| return False; |
| |
| -- A descendant of a limited formal type is not immutably limited |
| -- in the generic body, or in the body of a generic child. |
| |
| elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then |
| return not In_Package_Body (Scope (Btype)); |
| |
| else |
| return False; |
| end if; |
| |
| else |
| declare |
| Utyp : constant Entity_Id := Underlying_Type (Btype); |
| begin |
| if No (Utyp) then |
| return False; |
| else |
| return Is_Limited_View (Utyp); |
| end if; |
| end; |
| end if; |
| |
| elsif Is_Concurrent_Type (Btype) then |
| return True; |
| |
| elsif Is_Record_Type (Btype) then |
| |
| -- Note that we return True for all limited interfaces, even though |
| -- (unsynchronized) limited interfaces can have descendants that are |
| -- nonlimited, because this is a predicate on the type itself, and |
| -- things like functions with limited interface results need to be |
| -- handled as build in place even though they might return objects |
| -- of a type that is not inherently limited. |
| |
| if Is_Class_Wide_Type (Btype) then |
| return Is_Limited_View (Root_Type (Btype)); |
| |
| else |
| declare |
| C : Entity_Id; |
| |
| begin |
| C := First_Component (Btype); |
| while Present (C) loop |
| |
| -- Don't consider components with interface types (which can |
| -- only occur in the case of a _parent component anyway). |
| -- They don't have any components, plus it would cause this |
| -- function to return true for nonlimited types derived from |
| -- limited interfaces. |
| |
| if not Is_Interface (Etype (C)) |
| and then Is_Limited_View (Etype (C)) |
| then |
| return True; |
| end if; |
| |
| Next_Component (C); |
| end loop; |
| end; |
| |
| return False; |
| end if; |
| |
| elsif Is_Array_Type (Btype) then |
| return Is_Limited_View (Component_Type (Btype)); |
| |
| else |
| return False; |
| end if; |
| end Is_Limited_View; |
| |
| ------------------------------- |
| -- Is_Record_Or_Limited_Type -- |
| ------------------------------- |
| |
| function Is_Record_Or_Limited_Type (Typ : Entity_Id) return Boolean is |
| begin |
| return Is_Record_Type (Typ) or else Is_Limited_Type (Typ); |
| end Is_Record_Or_Limited_Type; |
| |
| ---------------------- |
| -- Nearest_Ancestor -- |
| ---------------------- |
| |
| function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is |
| D : constant Node_Id := Original_Node (Declaration_Node (Typ)); |
| -- We use the original node of the declaration, because derived |
| -- types from record subtypes are rewritten as record declarations, |
| -- and it is the original declaration that carries the ancestor. |
| |
| begin |
| -- If we have a subtype declaration, get the ancestor subtype |
| |
| if Nkind (D) = N_Subtype_Declaration then |
| if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then |
| return Entity (Subtype_Mark (Subtype_Indication (D))); |
| else |
| return Entity (Subtype_Indication (D)); |
| end if; |
| |
| -- If derived type declaration, find who we are derived from |
| |
| elsif Nkind (D) = N_Full_Type_Declaration |
| and then Nkind (Type_Definition (D)) = N_Derived_Type_Definition |
| then |
| declare |
| DTD : constant Entity_Id := Type_Definition (D); |
| SI : constant Entity_Id := Subtype_Indication (DTD); |
| begin |
| if Is_Entity_Name (SI) then |
| return Entity (SI); |
| else |
| return Entity (Subtype_Mark (SI)); |
| end if; |
| end; |
| |
| -- If this is a concurrent declaration with a nonempty interface list, |
| -- get the first progenitor. Account for case of a record type created |
| -- for a concurrent type (which is the only case that seems to occur |
| -- in practice). |
| |
| elsif Nkind (D) = N_Full_Type_Declaration |
| and then (Is_Concurrent_Type (Defining_Identifier (D)) |
| or else Is_Concurrent_Record_Type (Defining_Identifier (D))) |
| and then Is_Non_Empty_List (Interface_List (Type_Definition (D))) |
| then |
| return Entity (First (Interface_List (Type_Definition (D)))); |
| |
| -- If derived type and private type, get the full view to find who we |
| -- are derived from. |
| |
| elsif Is_Derived_Type (Typ) |
| and then Is_Private_Type (Typ) |
| and then Present (Full_View (Typ)) |
| then |
| return Nearest_Ancestor (Full_View (Typ)); |
| |
| -- Otherwise, nothing useful to return, return Empty |
| |
| else |
| return Empty; |
| end if; |
| end Nearest_Ancestor; |
| |
| --------------------------- |
| -- Nearest_Dynamic_Scope -- |
| --------------------------- |
| |
| function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id is |
| begin |
| if Is_Dynamic_Scope (Ent) then |
| return Ent; |
| else |
| return Enclosing_Dynamic_Scope (Ent); |
| end if; |
| end Nearest_Dynamic_Scope; |
| |
| ------------------------ |
| -- Next_Tag_Component -- |
| ------------------------ |
| |
| function Next_Tag_Component (Tag : Entity_Id) return Entity_Id is |
| Comp : Entity_Id; |
| |
| begin |
| pragma Assert (Is_Tag (Tag)); |
| |
| -- Loop to look for next tag component |
| |
| Comp := Next_Entity (Tag); |
| while Present (Comp) loop |
| if Is_Tag (Comp) then |
| pragma Assert (Chars (Comp) /= Name_uTag); |
| return Comp; |
| end if; |
| |
| Next_Entity (Comp); |
| end loop; |
| |
| -- No tag component found |
| |
| return Empty; |
| end Next_Tag_Component; |
| |
| -------------------------- |
| -- Number_Discriminants -- |
| -------------------------- |
| |
| function Number_Discriminants (Typ : Entity_Id) return Pos is |
| N : Nat := 0; |
| Discr : Entity_Id := First_Discriminant (Typ); |
| |
| begin |
| while Present (Discr) loop |
| N := N + 1; |
| Next_Discriminant (Discr); |
| end loop; |
| |
| return N; |
| end Number_Discriminants; |
| |
| ---------------------------------------------- |
| -- Object_Type_Has_Constrained_Partial_View -- |
| ---------------------------------------------- |
| |
| function Object_Type_Has_Constrained_Partial_View |
| (Typ : Entity_Id; |
| Scop : Entity_Id) return Boolean |
| is |
| begin |
| return Has_Constrained_Partial_View (Typ) |
| or else (In_Generic_Body (Scop) |
| and then Is_Generic_Type (Base_Type (Typ)) |
| and then (Is_Private_Type (Base_Type (Typ)) |
| or else Is_Derived_Type (Base_Type (Typ))) |
| and then not Is_Tagged_Type (Typ) |
| and then not (Is_Array_Type (Typ) |
| and then not Is_Constrained (Typ)) |
| and then Has_Discriminants (Typ)); |
| end Object_Type_Has_Constrained_Partial_View; |
| |
| ------------------ |
| -- Package_Body -- |
| ------------------ |
| |
| function Package_Body (E : Entity_Id) return Node_Id is |
| Body_Decl : Node_Id; |
| Body_Id : constant Opt_E_Package_Body_Id := |
| Corresponding_Body (Package_Spec (E)); |
| |
| begin |
| if Present (Body_Id) then |
| Body_Decl := Parent (Body_Id); |
| |
| if Nkind (Body_Decl) = N_Defining_Program_Unit_Name then |
| Body_Decl := Parent (Body_Decl); |
| end if; |
| |
| pragma Assert (Nkind (Body_Decl) = N_Package_Body); |
| |
| return Body_Decl; |
| else |
| return Empty; |
| end if; |
| end Package_Body; |
| |
| ------------------ |
| -- Package_Spec -- |
| ------------------ |
| |
| function Package_Spec (E : Entity_Id) return Node_Id is |
| begin |
| return Parent (Package_Specification (E)); |
| end Package_Spec; |
| |
| --------------------------- |
| -- Package_Specification -- |
| --------------------------- |
| |
| function Package_Specification (E : Entity_Id) return Node_Id is |
| N : Node_Id; |
| |
| begin |
| pragma Assert (Is_Package_Or_Generic_Package (E)); |
| |
| N := Parent (E); |
| |
| if Nkind (N) = N_Defining_Program_Unit_Name then |
| N := Parent (N); |
| end if; |
| |
| pragma Assert (Nkind (N) = N_Package_Specification); |
| |
| return N; |
| end Package_Specification; |
| |
| --------------------- |
| -- Subprogram_Body -- |
| --------------------- |
| |
| function Subprogram_Body (E : Entity_Id) return Node_Id is |
| Body_E : constant Entity_Id := Subprogram_Body_Entity (E); |
| |
| begin |
| if No (Body_E) then |
| return Empty; |
| else |
| return Parent (Subprogram_Specification (Body_E)); |
| end if; |
| end Subprogram_Body; |
| |
| ---------------------------- |
| -- Subprogram_Body_Entity -- |
| ---------------------------- |
| |
| function Subprogram_Body_Entity (E : Entity_Id) return Entity_Id is |
| N : constant Node_Id := Parent (Subprogram_Specification (E)); |
| -- Declaration for E |
| |
| begin |
| -- If this declaration is not a subprogram body, then it must be a |
| -- subprogram declaration or body stub, from which we can retrieve the |
| -- entity for the corresponding subprogram body if any, or an abstract |
| -- subprogram declaration, for which we return Empty. |
| |
| case Nkind (N) is |
| when N_Subprogram_Body => |
| return E; |
| |
| when N_Subprogram_Body_Stub |
| | N_Subprogram_Declaration |
| => |
| return Corresponding_Body (N); |
| |
| when others => |
| return Empty; |
| end case; |
| end Subprogram_Body_Entity; |
| |
| --------------------- |
| -- Subprogram_Spec -- |
| --------------------- |
| |
| function Subprogram_Spec (E : Entity_Id) return Node_Id is |
| N : constant Node_Id := Parent (Subprogram_Specification (E)); |
| -- Declaration for E |
| |
| begin |
| -- This declaration is either subprogram declaration or a subprogram |
| -- body, in which case return Empty. |
| |
| if Nkind (N) = N_Subprogram_Declaration then |
| return N; |
| else |
| return Empty; |
| end if; |
| end Subprogram_Spec; |
| |
| ------------------------------ |
| -- Subprogram_Specification -- |
| ------------------------------ |
| |
| function Subprogram_Specification (E : Entity_Id) return Node_Id is |
| N : Node_Id; |
| |
| begin |
| N := Parent (E); |
| |
| if Nkind (N) = N_Defining_Program_Unit_Name then |
| N := Parent (N); |
| end if; |
| |
| -- If the Parent pointer of E is not a subprogram specification node |
| -- (going through an intermediate N_Defining_Program_Unit_Name node |
| -- for subprogram units), then E is an inherited operation. Its parent |
| -- points to the type derivation that produces the inheritance: that's |
| -- the node that generates the subprogram specification. Its alias |
| -- is the parent subprogram, and that one points to a subprogram |
| -- declaration, or to another type declaration if this is a hierarchy |
| -- of derivations. |
| |
| if Nkind (N) not in N_Subprogram_Specification then |
| pragma Assert (Present (Alias (E))); |
| N := Subprogram_Specification (Alias (E)); |
| end if; |
| |
| return N; |
| end Subprogram_Specification; |
| |
| -------------------- |
| -- Ultimate_Alias -- |
| -------------------- |
| |
| function Ultimate_Alias (Prim : Entity_Id) return Entity_Id is |
| E : Entity_Id := Prim; |
| |
| begin |
| while Present (Alias (E)) loop |
| pragma Assert (Alias (E) /= E); |
| E := Alias (E); |
| end loop; |
| |
| return E; |
| end Ultimate_Alias; |
| |
| -------------------------- |
| -- Unit_Declaration_Node -- |
| -------------------------- |
| |
| function Unit_Declaration_Node (Unit_Id : Entity_Id) return Node_Id is |
| N : Node_Id := Parent (Unit_Id); |
| |
| begin |
| -- Predefined operators do not have a full function declaration |
| |
| if Ekind (Unit_Id) = E_Operator then |
| return N; |
| end if; |
| |
| -- Isn't there some better way to express the following ??? |
| |
| while Nkind (N) /= N_Abstract_Subprogram_Declaration |
| and then Nkind (N) /= N_Entry_Body |
| and then Nkind (N) /= N_Entry_Declaration |
| and then Nkind (N) /= N_Formal_Package_Declaration |
| and then Nkind (N) /= N_Function_Instantiation |
| and then Nkind (N) /= N_Generic_Package_Declaration |
| and then Nkind (N) /= N_Generic_Subprogram_Declaration |
| and then Nkind (N) /= N_Package_Declaration |
| and then Nkind (N) /= N_Package_Body |
| and then Nkind (N) /= N_Package_Instantiation |
| and then Nkind (N) /= N_Package_Renaming_Declaration |
| and then Nkind (N) /= N_Procedure_Instantiation |
| and then Nkind (N) /= N_Protected_Body |
| and then Nkind (N) /= N_Protected_Type_Declaration |
| and then Nkind (N) /= N_Subprogram_Declaration |
| and then Nkind (N) /= N_Subprogram_Body |
| and then Nkind (N) /= N_Subprogram_Body_Stub |
| and then Nkind (N) /= N_Subprogram_Renaming_Declaration |
| and then Nkind (N) /= N_Task_Body |
| and then Nkind (N) /= N_Task_Type_Declaration |
| and then Nkind (N) not in N_Formal_Subprogram_Declaration |
| and then Nkind (N) not in N_Generic_Renaming_Declaration |
| loop |
| N := Parent (N); |
| |
| -- We don't use Assert here, because that causes an infinite loop |
| -- when assertions are turned off. Better to crash. |
| |
| if No (N) then |
| raise Program_Error; |
| end if; |
| end loop; |
| |
| return N; |
| end Unit_Declaration_Node; |
| |
| end Sem_Aux; |
