------------------------------------------------------------------------------ -- -- -- ASIS-for-GNAT IMPLEMENTATION COMPONENTS -- -- -- -- A 4 G . E X P R _ S E M -- -- -- -- B o d y -- -- -- -- Copyright (C) 1995-2012, Free Software Foundation, Inc. -- -- -- -- ASIS-for-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 -- -- Software Foundation; either version 2, or (at your option) any later -- -- version. ASIS-for-GNAT is distributed in the hope that it will be use- -- -- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- -- -- CHANTABILITY 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 ASIS-for-GNAT; see file -- -- COPYING. If not, write to the Free Software Foundation, 51 Franklin -- -- Street, Fifth Floor, Boston, MA 02110-1301, USA. -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the -- -- Software Engineering Laboratory of the Swiss Federal Institute of -- -- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the -- -- Scientific Research Computer Center of Moscow State University (SRCC -- -- MSU), Russia, with funding partially provided by grants from the Swiss -- -- National Science Foundation and the Swiss Academy of Engineering -- -- Sciences. ASIS-for-GNAT is now maintained by AdaCore -- -- (http://www.adacore.com). -- -- -- ------------------------------------------------------------------------------ with Ada.Wide_Characters.Unicode; with Asis.Clauses; use Asis.Clauses; with Asis.Compilation_Units; use Asis.Compilation_Units; with Asis.Declarations; use Asis.Declarations; with Asis.Elements; use Asis.Elements; with Asis.Expressions; use Asis.Expressions; with Asis.Extensions; use Asis.Extensions; with Asis.Iterator; use Asis.Iterator; with Asis.Statements; use Asis.Statements; with Asis.Set_Get; use Asis.Set_Get; with A4G.A_Debug; use A4G.A_Debug; with A4G.A_Output; use A4G.A_Output; with A4G.A_Sem; use A4G.A_Sem; with A4G.A_Stand; use A4G.A_Stand; with A4G.A_Types; use A4G.A_Types; with A4G.Asis_Tables; use A4G.Asis_Tables; with A4G.Contt.UT; use A4G.Contt.UT; with A4G.Int_Knds; use A4G.Int_Knds; with A4G.Knd_Conv; use A4G.Knd_Conv; with A4G.Mapping; use A4G.Mapping; with Atree; use Atree; with Einfo; use Einfo; with Namet; use Namet; with Nlists; use Nlists; with Output; use Output; with Sem_Aux; use Sem_Aux; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Types; use Types; package body A4G.Expr_Sem is ----------------------- -- Local subprograms -- ----------------------- function Explicit_Type_Declaration (Entity_Node : Node_Id) return Node_Id; -- Taking the Entity node obtained as a result of some call to Etype -- function, this function yields the node for corresponding explicit -- type or subtype declaration. This means that this function traverses all -- the internal types generated by the compiler. -- -- In case of an anonymous access type, this function returns the entity -- node which is created by the compiler for this type (there is no tree -- type structure for the type declaration in this case), and a caller is -- responsible for further analysis -- -- SHOULD WE MOVE THIS FUNCTION IN THE SPEC??? function Explicit_Type_Declaration_Unwound (Entity_Node : Node_Id; Reference_Node : Node_Id := Empty) return Node_Id; -- Does the same as Explicit_Type_Declaration and unwinds all the -- subtypings (if any), resulting in a root type declaration. -- Reference_Node is a node representing a "place" from which this function -- is called. If the result type is private, but from the "place" of the -- call the full view is visible, the full view is returned. If -- Reference_Node is Empty, no private/full view check is made function Explicit_Type_Declaration_Unwound_Unaccess (Entity_Node : Node_Id; Reference_Node : Node_Id := Empty) return Node_Id; -- Does the same as Explicit_Type_Declaration_Unwound and in case of access -- types goes from the access to the designated type. --??? -- -- In case of an anonymous access type returns directly designated type. function Rewritten_Image (Selector_Name : Node_Id) return Node_Id; pragma Unreferenced (Rewritten_Image); -- this is an example of the tricky programming needed because of the -- tree rewriting. The problem is, that in the original tree structure -- for a record aggregate a N_Identifier node for a component selector -- name does not have an Entity field set. So we have to go to the -- corresponding (that is, to representing the same component selector -- name) node in the rewritten structure. -- -- It is an error to use this function for a node which is does not -- represent a component selector name in the original tree structure -- for a record aggregate -- -- This function is not used now, it is replaced by Search_Record_Comp function Search_Record_Comp (Selector_Name : Node_Id) return Entity_Id; -- This function looks for the entity node corresponding to a name from a -- choices list from a record or extension aggregate. The problem here is -- that an aggregate node is rewritten, and in the original tree structure -- the nodes corresponding to component names do not have the Entity -- field set. This function locates the corresponding entity node by -- detecting the aggregate type and searching the component defining -- identifier with the same name in the record definition. -- It might be the case (because of the absence of some semantic -- information in the tree or because of the ASIS bug) that Selector_Name -- actually does not represent a name from the aggregate choice list, in -- this case this function raises Assert_Failure or (if assertions are off) -- returns the Empty node. function Get_Statement_Identifier (Def_Id : Node_Id) return Node_Id; -- For Int_Node which should represent the defining identifier from an -- implicit declaration of a label (or a statement name?) (otherwise it -- is an error to use this function), this function returns the "defining" -- name representing the definition of this statement identifier in the -- ASIS sense. function GFP_Declaration (Par_Id : Node_Id) return Node_Id; -- this is (I hope, temporary) fix for the problem 14: the Entity -- field is not set for N_Identifier node representing the parameter -- name in a named generic association, so we need this function to -- compute the Entity for such an N_Identifier node. -- ??? what about formal parameters in associations like -- ??? "*" => Some_Function -- -- This function is supposed to be called for an actual representing -- the name of a generic formal parameter in a named formal parameter -- association (it's an error to call it for any other actual) function Is_Explicit_Type_Component (Comp_Def_Name : Node_Id; Type_Decl : Node_Id) return Boolean; -- Expects Comp_Def_Name to be a defining identifier of a record component -- and Type_Decl to be a type declaration. Checks if Comp_Def_Name denotes -- a component explicitly declared by this type declaration. (This function -- is useful for discriminants and components explicitly declared in -- derived type declarations. function Is_Type_Discriminant (Discr_Node : Node_Id; Type_Node : Node_Id) return Boolean; -- Assuming that Discr_Node is N_Defining_Identifier node and Type_Node -- represents a type declaration, this function checks if Discr_Node is -- a discriminant of this type (we cannot just use Parent to check this -- because of tree rewriting for discriminant types. function Full_View_Visible (Priv_Type : Node_Id; Ref : Node_Id) return Boolean; -- Assuming that Priv_Type is a node representing a private type -- declaration, checks, that in place of Ref the full view of the type is -- visible function Reset_To_Full_View (Full_View : Node_Id; Discr : Node_Id) return Node_Id; -- Assuming that Full_View is the full type declaration for some private -- type and Discr is a defining name of a discriminant of the type -- (probably, from its private view), this function returns the defining -- name of this discriminant in the full view function Is_Part_Of_Defining_Unit_Name (Name_Node : Node_Id) return Boolean; -- Assuming that Name_Node is of N_Identifier kind, this function checks, -- if it is a part of a defining program unit name function Reset_To_Spec (Name_Node : Node_Id) return Node_Id; -- Assuming that Name_Node is a part of a defining unit name which in turn -- is a part of a compilation unit body (for such nodes Entity field is not -- set), this function resets it to the node pointing to the same part of -- the defining unit name, but in the spec of the corresponding library -- unit function Reference_Kind (Name : Asis.Element) return Internal_Element_Kinds; -- If Name is of A_Defining_Name kind then this function returns the kind -- of An_Expression elements which may be simple-name-form references to -- the given name (that is, A_Defining_Identifier -> An_Identifier, -- A_Defining_And_Operator -> An_And_Operator), otherwise returns -- Not_An_Element. Note, that the result can never be -- A_Selected_Component, because only references which are simple names -- are considered. function Get_Specificed_Component (Comp : Node_Id; Rec_Type : Entity_Id) return Entity_Id; -- Provided that Comp is the reference to a record component from the -- component clause being a component of a record representation clause -- for the record type Rec_Type, this function computes the corresponding -- component entity function Get_Entity_From_Long_Name (N : Node_Id) return Entity_Id; -- Supposing that N denotes some component of a long expanded name -- and for N and for its prefix the Entity fields are not set, this -- function computes the corresponding entity node by traversing -- the "chain" of definitions corresponding to this expanded name function Get_Rewritten_Discr_Ref (N : Node_Id) return Node_Id; pragma Unreferenced (Get_Rewritten_Discr_Ref); -- This function is supposed to be called for a discriminant reference -- from the discriminant constraint from derived type, in case if the -- parent type is a task or protected type. In this case -- N_Subtype_Indication node from the derived type definition is rewritten -- in a subtype mark pointing to the internal subtype. The original -- structure is not decorated, so we have to go to the corresponding -- node in the definition of this internal subtype to get the semantic -- information. See F407-011 -- Do we need this after fixing the regression caused by K120-031 function Get_Discriminant_From_Type (N : Node_Id) return Entity_Id; -- Starting from the reference to discriminant in a discriminant -- constraint, tries to compute the corresponding discriminant entity by -- getting to the declaration of the corresponding type and traversing -- its discriminant part. function Is_Limited_Withed (E : Entity_Id; Reference : Asis.Element) return Boolean; -- Assuming that Reference is an_Identifier Element and E is the entity -- node for the entity denoted by Reference, checks if this entity is -- defined in a compilation unit that is limited withed by the unit -- containing Reference function To_Upper_Case (S : Wide_String) return Wide_String; -- Folds the argument to upper case, may be used for string normalization -- before comparing strings if the casing is not important for comparing -- (Copied from ASIS_UL.Misc to avoid dependencies on ASIS UL in "pure" -- ASIS. --------------------------------------- -- Character_Literal_Name_Definition -- --------------------------------------- function Character_Literal_Name_Definition (Reference_Ch : Element) return Asis.Defining_Name is -- for now, the code is very similar to the code -- for Identifier_Name_Definition. Any aggregation has been -- put off till everything will work Arg_Node : Node_Id; Special_Case : Special_Cases := Not_A_Special_Case; Result_Element : Asis.Defining_Name := Nil_Element; Is_Inherited : Boolean := False; Association_Type : Node_Id := Empty; Set_Char_Code : Boolean := False; Result_Node : Node_Id; Result_Unit : Compilation_Unit; Result_Kind : constant Internal_Element_Kinds := A_Defining_Character_Literal; begin -- We have to distinguish and to treat separately four (???) -- different situations: -- -- 1. a literal from user-defined character type (fully implemented -- for now); -- -- 2. a literal from a type derived from some user-defined character -- type (not implemented for now as related to Implicit Elements); -- -- 3. a literal from a character type defined in Standard (not -- implemented for now); -- -- 4. a literal from a type derived a character type defined in -- Standard (not implemented for now as related to Implicit -- Elements); Arg_Node := Node (Reference_Ch); -- if Reference_Ch is a Selector_Name in some N_Expanded_Name, -- the corresponding Entity field is set not for the Node on which -- this Reference_En is based, but for the whole expanded name. -- (The same for Etype) So: if Nkind (Parent (Arg_Node)) = N_Expanded_Name or else Nkind (Parent (Arg_Node)) = N_Character_Literal then -- the last alternative of the condition corresponds to an expanded -- name of a predefined character literal or to an expanded name -- of a literal of a type derived from a predefined character type - -- such an expanded name is rewritten into (another) "instance" -- of the same literal Arg_Node := Parent (Arg_Node); end if; Result_Node := Entity (Arg_Node); -- will be Empty for any character literal belonging to -- Standard.Character, Standard.Whide_Character or any type -- derived (directly or indirectly) from any of these types Association_Type := Etype (Arg_Node); if No (Result_Node) and then No (Association_Type) and then Is_From_Unknown_Pragma (R_Node (Reference_Ch)) then return Nil_Element; end if; if No (Association_Type) then -- this may be the case if some character literals are -- rewritten into a string constant Association_Type := Arg_Node; while Present (Association_Type) loop exit when Nkind (Association_Type) = N_String_Literal; Association_Type := Parent (Association_Type); end loop; pragma Assert (Present (Association_Type)); Association_Type := Etype (Association_Type); Association_Type := Component_Type (Association_Type); end if; Association_Type := Explicit_Type_Declaration_Unwound (Association_Type); if No (Result_Node) then Set_Char_Code := True; Result_Node := Association_Type; Result_Node := Sinfo.Type_Definition (Result_Node); if Char_Defined_In_Standard (Arg_Node) then Special_Case := Stand_Char_Literal; else Is_Inherited := True; end if; elsif not Comes_From_Source (Result_Node) then Is_Inherited := True; end if; if Char_Defined_In_Standard (Arg_Node) then Result_Unit := Get_Comp_Unit (Standard_Id, Encl_Cont_Id (Reference_Ch)); else Result_Unit := Enclosing_Unit (Encl_Cont_Id (Reference_Ch), Result_Node); end if; Result_Element := Node_To_Element_New (Node => Result_Node, Node_Field_1 => Association_Type, Internal_Kind => Result_Kind, Spec_Case => Special_Case, Inherited => Is_Inherited, In_Unit => Result_Unit); if Set_Char_Code then Set_Character_Code (Result_Element, Character_Code (Reference_Ch)); end if; return Result_Element; end Character_Literal_Name_Definition; --------------------------------- -- Collect_Overloaded_Entities -- --------------------------------- procedure Collect_Overloaded_Entities (Reference : Asis.Element) is Arg_Node : Node_Id; Arg_Pragma_Chars : Name_Id; Next_Entity : Entity_Id; Result_Unit : Asis.Compilation_Unit; Result_Context : constant Context_Id := Encl_Cont_Id (Reference); Res_Node : Node_Id; Res_NF_1 : Node_Id; Res_Ekind : Entity_Kind; Res_Inherited : Boolean; Is_Program_Unit_Pragma : Boolean := False; Enclosing_Scope_Entity : Entity_Id; Enclosing_List : List_Id; function Should_Be_Collected (Ent : Entity_Id) return Boolean; -- When traversing the chain of homonyms potentially referred by -- Reference, it checks if Ent should be used to create the next -- Element in the Result list function Should_Be_Collected (Ent : Entity_Id) return Boolean is Result : Boolean := False; N : Node_Id; begin if not (Ekind (Ent) = E_Operator and then Is_Predefined (Ent)) then if Is_Program_Unit_Pragma then Result := Scope (Ent) = Enclosing_Scope_Entity; else N := Parent (Ent); while Present (N) and then not (Is_List_Member (N)) loop N := Parent (N); end loop; if Present (N) and then Is_List_Member (N) then Result := List_Containing (N) = Enclosing_List; end if; end if; end if; return Result; end Should_Be_Collected; begin -- First, we decide what kind of pragma we have, because the search -- depends on this: Arg_Node := Node (Reference); Arg_Pragma_Chars := Pragma_Name (Parent (Parent (Arg_Node))); if Arg_Pragma_Chars = Name_Inline then Is_Program_Unit_Pragma := True; -- ??? is it enough? what about GNAT-specific pragmas? -- In this case we have to search in the same declarative region -- (in the same scope): Enclosing_Scope_Entity := Scope (Entity (Arg_Node)); -- This is no more than a trick: actually, we have to compute -- the scope node for the declarative region which encloses -- Arg_Node, but entry bodies makes a serious problem (at the -- moment of writing this code there is no semantic links between -- protected entry declarations and bodies). So we just assume -- that Arg_Node has the Entity field set, and this field -- points to some correct (from the point of view of -- Corresponding_Name_Definition_List query) entity, so we -- just take the Scope of this entity... else Enclosing_List := List_Containing (Parent (Parent (Arg_Node))); end if; Next_Entity := Entity (Arg_Node); while Present (Next_Entity) and then Should_Be_Collected (Next_Entity) loop Result_Unit := Enclosing_Unit (Result_Context, Next_Entity); Res_Ekind := Ekind (Next_Entity); if Res_Ekind in Subprogram_Kind then if Comes_From_Source (Next_Entity) then Res_Node := Next_Entity; Res_NF_1 := Empty; Res_Inherited := False; else Res_Node := Alias (Next_Entity); while Present (Alias (Res_Node)) loop Res_Node := Alias (Res_Node); end loop; Res_NF_1 := Next_Entity; Res_Inherited := True; end if; Asis_Element_Table.Append (Node_To_Element_New (Node => Res_Node, Node_Field_1 => Res_NF_1, Inherited => Res_Inherited, In_Unit => Result_Unit)); end if; Next_Entity := Homonym (Next_Entity); end loop; end Collect_Overloaded_Entities; --------------------------- -- Correct_Impl_Form_Par -- --------------------------- procedure Correct_Impl_Form_Par (Result : in out Element; Reference : Element) is Res_Node : Node_Id := Node (Result); Subprogram_Name : Element; Subprogram_Node : Node_Id := Node (Result); Res_Sloc : Source_Ptr; Top_Node : Node_Id; Result_Unit : Compilation_Unit; begin Res_Node := Defining_Identifier (Parent (Res_Node)); Subprogram_Name := Enclosing_Element (Enclosing_Element (Reference)); case Int_Kind (Subprogram_Name) is when A_Function_Call => Subprogram_Name := Prefix (Subprogram_Name); when A_Procedure_Call_Statement | An_Entry_Call_Statement => Subprogram_Name := Called_Name (Subprogram_Name); when others => null; pragma Assert (False); end case; Subprogram_Node := Node (Subprogram_Name); Subprogram_Node := Associated_Node (Subprogram_Node); Top_Node := Parent (Subprogram_Node); while Nkind (Top_Node) /= N_Compilation_Unit loop Top_Node := Parent (Top_Node); end loop; Res_Sloc := Sloc (Res_Node) - Sloc (Top_Node); Result_Unit := Enclosing_Unit (Encl_Cont_Id (Reference), Subprogram_Node); Set_Node (Result, Res_Node); Set_R_Node (Result, Res_Node); Set_From_Implicit (Result, True); Set_From_Inherited (Result, True); Set_From_Instance (Result, Is_From_Instance (Subprogram_Node)); Set_Node_Field_1 (Result, Subprogram_Node); Set_Rel_Sloc (Result, Res_Sloc); Set_Encl_Unit_Id (Result, Get_Unit_Id (Result_Unit)); end Correct_Impl_Form_Par; -------------------- -- Correct_Result -- -------------------- procedure Correct_Result (Result : in out Element; Reference : Element) is Enclosing_Generic : Element := Nil_Element; Tmp : Element; Tmp_Generic : Element; Is_From_Body : Boolean := False; Instance : Element := Nil_Element; procedure Check_Number_Name (Element : Asis.Element; Control : in out Traverse_Control; State : in out No_State); -- Check if the argument is the defining name of the named number -- defining the same named number as Result, but in the template. -- As soon as the check is successful, replace Result with this -- defining name and terminates the traversal Control : Traverse_Control := Continue; State : No_State := Not_Used; procedure Traverse_Instance is new Traverse_Element (State_Information => No_State, Pre_Operation => Check_Number_Name, Post_Operation => No_Op); procedure Check_Number_Name (Element : Asis.Element; Control : in out Traverse_Control; State : in out No_State) is pragma Unreferenced (State); El_Kind : constant Internal_Element_Kinds := Int_Kind (Element); begin case El_Kind is when A_Defining_Identifier => if Int_Kind (Enclosing_Element (Element)) in An_Integer_Number_Declaration .. A_Real_Number_Declaration and then Chars (Node (Result)) = Chars (Node (Element)) then Result := Element; Control := Terminate_Immediately; end if; when An_Integer_Number_Declaration | A_Real_Number_Declaration | A_Procedure_Body_Declaration | A_Function_Body_Declaration | A_Package_Declaration | A_Package_Body_Declaration | A_Task_Body_Declaration | A_Protected_Body_Declaration | An_Entry_Body_Declaration | A_Generic_Package_Declaration | A_Block_Statement => null; when others => Control := Abandon_Children; end case; end Check_Number_Name; begin -- First, check if Result is declared in a template Tmp := Enclosing_Element (Result); while not Is_Nil (Tmp) loop if Int_Kind (Tmp) in An_Internal_Generic_Declaration or else (Int_Kind (Tmp) in A_Procedure_Body_Declaration .. A_Package_Body_Declaration and then Int_Kind (Corresponding_Declaration (Tmp)) in An_Internal_Generic_Declaration) then if Int_Kind (Tmp) in A_Procedure_Body_Declaration .. A_Package_Body_Declaration then Enclosing_Generic := Corresponding_Declaration (Tmp); Is_From_Body := True; else Enclosing_Generic := Tmp; end if; exit; end if; Tmp := Enclosing_Element (Tmp); end loop; if Is_Nil (Enclosing_Generic) then -- No need to correct anything! return; end if; -- Now, traversing the instantiation chain from the Reference, looking -- for the instantiation of Enlosing_Generic: Tmp := Enclosing_Element (Reference); while not Is_Nil (Tmp) loop if Int_Kind (Tmp) in An_Internal_Generic_Instantiation then Tmp_Generic := Generic_Unit_Name (Tmp); if Int_Kind (Tmp_Generic) = A_Selected_Component then Tmp_Generic := Selector (Tmp_Generic); end if; Tmp_Generic := Corresponding_Name_Declaration (Tmp_Generic); if Is_Equal (Enclosing_Generic, Tmp_Generic) then Instance := Tmp; exit; end if; end if; Tmp := Enclosing_Element (Tmp); end loop; if Is_Nil (Instance) then -- No need to correct anything - we do not have a nested generics! return; end if; -- And now we have to find the "image' of Result in expanded Instance if Is_From_Body then Instance := Corresponding_Body (Instance); else Instance := Corresponding_Declaration (Instance); end if; Traverse_Instance (Instance, Control, State); end Correct_Result; ------------------------------- -- Explicit_Type_Declaration -- ------------------------------- function Explicit_Type_Declaration (Entity_Node : Node_Id) return Node_Id is Next_Node : Node_Id; Result_Node : Node_Id; Res_Ekind : Entity_Kind; function Is_Explicit_Type_Declaration (Type_Entity_Node : Node_Id) return Boolean; -- checks if Type_Entity_Node corresponds to the explicit type -- declaration which is looked for (that is, the needed type declaration -- node is Parent (Type_Entity_Node) ) function Is_Explicit_Type_Declaration (Type_Entity_Node : Node_Id) return Boolean is Type_Decl_Node : constant Node_Id := Parent (Type_Entity_Node); Type_Decl_Nkind : Node_Kind; Is_Full_Type_Decl : Boolean := False; Is_Derived_Type_Decl : Boolean := False; Is_Formal_Type_Decl : Boolean := False; begin if not Is_Itype (Entity_Node) and then Present (Type_Decl_Node) then Is_Full_Type_Decl := Comes_From_Source (Type_Decl_Node) and then (not Is_Rewrite_Substitution (Type_Decl_Node)); if not Is_Full_Type_Decl and then Is_Rewrite_Substitution (Type_Decl_Node) then -- The second part of the condition is common for all the cases -- which require special analysis Type_Decl_Nkind := Nkind (Type_Decl_Node); Is_Derived_Type_Decl := (Type_Decl_Nkind = N_Subtype_Declaration or else Type_Decl_Nkind = N_Full_Type_Declaration or else Type_Decl_Nkind = N_Formal_Type_Declaration) and then (Nkind (Original_Node (Type_Decl_Node)) = N_Full_Type_Declaration and then Nkind (Sinfo.Type_Definition (Original_Node (Type_Decl_Node))) = N_Derived_Type_Definition); if not Is_Derived_Type_Decl then Is_Formal_Type_Decl := (Type_Decl_Nkind = N_Private_Extension_Declaration or else Type_Decl_Nkind = N_Full_Type_Declaration) and then Nkind (Original_Node (Type_Decl_Node)) = N_Formal_Type_Declaration; end if; end if; end if; return Is_Full_Type_Decl or else Is_Derived_Type_Decl or else Is_Formal_Type_Decl; end Is_Explicit_Type_Declaration; begin -- well, here we have a (sub)type entity node passed as an actual... -- the aim is to return the _explicit_ type declaration corresponding -- to this (sub)type entity. It should be such a declaration, if this -- function is called... -- -- We try to organize the processing in a recursive way - may be, -- not the most effective one, but easy-to maintain if Is_Explicit_Type_Declaration (Entity_Node) then -- the first part of the condition is the protection from -- non-accurate settings of Comes_From_Source flag :(( Result_Node := Parent (Entity_Node); elsif Sloc (Entity_Node) <= Standard_Location then -- here we have a predefined type declared in Standard. -- it may be the type entity or the entity for its 'Base -- type. In the latter case we have to go to the type -- entity if Present (Parent (Entity_Node)) then -- type entity, therefore simply Result_Node := Parent (Entity_Node); else -- 'Base type, so we have to compute the first named -- type. The code which does it looks tricky, but for now we -- do not know any better solution: Result_Node := Parent (Parent (Scalar_Range (Entity_Node))); end if; elsif Etype (Entity_Node) = Entity_Node and then Present (Associated_Node_For_Itype (Entity_Node)) and then Nkind (Associated_Node_For_Itype (Entity_Node)) = N_Object_Declaration then -- this corresponds to an anonymous array subtype created by an -- object declaration with array_type_definition Result_Node := Empty; else -- Entity_Node corresponds to some internal or implicit type created -- by the compiler. Here we have to traverse the tree till the -- explicit type declaration being the cause for generating this -- implicit type will be found Res_Ekind := Ekind (Entity_Node); if Res_Ekind = E_Anonymous_Access_Type then -- There is no type declaration node in this case at all, -- so we just return this N_Defining_Identifier node for -- further analysis in the calling context: return Entity_Node; -- ??? Why do not we return Empty in this case??? elsif Res_Ekind = E_Anonymous_Access_Subprogram_Type then -- No explicit type declaration, so return Empty; elsif Res_Ekind = E_String_Literal_Subtype or else (Res_Ekind = E_Array_Subtype and then Present (Parent (Entity_Node))) then -- The first part of the condition corresponds to a special case -- E_String_Literal_Subtype is created for, see Einfo (spec) for -- the details. The second part corresponds to the access to -- string type, see E626-002 Result_Node := Parent (Etype (Entity_Node)); if No (Result_Node) then Result_Node := Associated_Node_For_Itype (Etype (Entity_Node)); end if; elsif Ekind (Entity_Node) = E_Enumeration_Type then if Present (Associated_Node_For_Itype (Entity_Node)) then Result_Node := Associated_Node_For_Itype (Entity_Node); else -- Entity_Node represents an implicit type created for -- a derived enumeration type. we have to go down to this -- derived type Result_Node := Parent (Entity_Node); while Present (Result_Node) loop Result_Node := Next (Result_Node); exit when Nkind (Result_Node) = N_Subtype_Declaration and then Is_Rewrite_Substitution (Result_Node); end loop; end if; pragma Assert (Present (Result_Node)); elsif (No (Parent (Entity_Node)) or else not Comes_From_Source (Parent (Entity_Node))) and then Etype (Entity_Node) /= Entity_Node and then not (Ekind (Entity_Node) = E_Floating_Point_Type or else Ekind (Entity_Node) = E_Signed_Integer_Type or else Ekind (Entity_Node) = E_Array_Type or else Ekind (Entity_Node) = E_Private_Type or else Ekind (Entity_Node) = E_Limited_Private_Type) then if Is_Itype (Entity_Node) and then Nkind (Associated_Node_For_Itype (Entity_Node)) = N_Subtype_Declaration then Next_Node := Defining_Identifier (Associated_Node_For_Itype (Entity_Node)); if Next_Node = Entity_Node then Next_Node := Etype (Entity_Node); end if; else -- subtypes created for objects when an explicit constraint -- presents in the object declaration ??? Next_Node := Etype (Entity_Node); end if; Result_Node := Explicit_Type_Declaration (Next_Node); else Next_Node := Associated_Node_For_Itype (Entity_Node); pragma Assert (Present (Next_Node)); if Nkind (Original_Node (Next_Node)) = N_Full_Type_Declaration or else Nkind (Original_Node (Next_Node)) = N_Formal_Type_Declaration then Result_Node := Next_Node; elsif Nkind (Next_Node) = N_Loop_Parameter_Specification then -- here we have to traverse the loop parameter specification, -- because otherwise we may get the base type instead of -- the actually needed named subtype. Result_Node := Next_Node; Result_Node := Sinfo.Discrete_Subtype_Definition (Result_Node); case Nkind (Result_Node) is when N_Subtype_Indication => Result_Node := Sinfo.Subtype_Mark (Result_Node); Result_Node := Parent (Entity (Result_Node)); when N_Identifier | N_Expanded_Name => Result_Node := Parent (Entity (Result_Node)); when N_Range => -- and here we have to use the Etype field of -- the implicit type itself, because we do not have -- any type mark to start from in the loop parameter -- specification: Result_Node := Explicit_Type_Declaration (Etype (Entity_Node)); when others => null; pragma Assert (False); -- this is definitely wrong! Should be corrected -- during debugging!!! end case; else if Etype (Entity_Node) /= Entity_Node then -- otherwise we will be in dead circle Result_Node := Etype (Entity_Node); Result_Node := Explicit_Type_Declaration (Result_Node); else -- for now, the only guess is that we have an object -- defined by an object declaration with constrained -- array definition, or an initialization expression -- from such a declaration pragma Assert ( Nkind (Next_Node) = N_Object_Declaration and then Nkind (Object_Definition (Next_Node)) = N_Constrained_Array_Definition); return Empty; -- what else could we return here? end if; end if; end if; end if; return Result_Node; end Explicit_Type_Declaration; --------------------------------------- -- Explicit_Type_Declaration_Unwound -- --------------------------------------- function Explicit_Type_Declaration_Unwound (Entity_Node : Node_Id; Reference_Node : Node_Id := Empty) return Node_Id is Result_Node : Node_Id; Subtype_Mark_Node : Node_Id; begin Result_Node := Explicit_Type_Declaration (Entity_Node); while Nkind (Original_Node (Result_Node)) = N_Subtype_Declaration loop Subtype_Mark_Node := Sinfo.Subtype_Indication (Original_Node (Result_Node)); if Nkind (Subtype_Mark_Node) = N_Subtype_Indication then Subtype_Mark_Node := Sinfo.Subtype_Mark (Subtype_Mark_Node); end if; Result_Node := Explicit_Type_Declaration (Entity (Subtype_Mark_Node)); end loop; if Present (Reference_Node) and then (Nkind (Original_Node (Result_Node)) = N_Private_Type_Declaration or else Nkind (Original_Node (Result_Node)) = N_Private_Extension_Declaration) and then Full_View_Visible (Result_Node, Reference_Node) then Result_Node := Parent (Full_View (Defining_Identifier (Result_Node))); end if; return Result_Node; end Explicit_Type_Declaration_Unwound; ------------------------------------------------ -- Explicit_Type_Declaration_Unwound_Unaccess -- ------------------------------------------------ function Explicit_Type_Declaration_Unwound_Unaccess (Entity_Node : Node_Id; Reference_Node : Node_Id := Empty) return Node_Id is Result_Node : Node_Id; Subtype_Mark_Node : Node_Id; Tmp : Node_Id; begin Result_Node := Explicit_Type_Declaration_Unwound ( Entity_Node, Reference_Node); if Nkind (Result_Node) = N_Defining_Identifier and then Ekind (Result_Node) = E_Anonymous_Access_Type then Result_Node := Explicit_Type_Declaration_Unwound ( Directly_Designated_Type (Result_Node), Reference_Node); end if; -- This loop unwinds accessing^ while (Nkind (Original_Node (Result_Node)) = N_Full_Type_Declaration and then Nkind (Sinfo.Type_Definition (Original_Node (Result_Node))) = N_Access_To_Object_Definition) or else (Nkind (Original_Node (Result_Node)) = N_Formal_Type_Declaration and then Nkind (Sinfo.Formal_Type_Definition (Original_Node ( Result_Node))) = N_Access_To_Object_Definition) loop Subtype_Mark_Node := Original_Node (Result_Node); if Nkind (Subtype_Mark_Node) = N_Full_Type_Declaration then Subtype_Mark_Node := Sinfo.Subtype_Indication ( Sinfo.Type_Definition (Subtype_Mark_Node)); else Subtype_Mark_Node := Sinfo.Subtype_Indication ( Sinfo.Formal_Type_Definition (Subtype_Mark_Node)); end if; if Nkind (Subtype_Mark_Node) = N_Subtype_Indication then Subtype_Mark_Node := Sinfo.Subtype_Mark (Subtype_Mark_Node); end if; Result_Node := Explicit_Type_Declaration_Unwound ( Entity (Subtype_Mark_Node), Reference_Node); if Nkind (Result_Node) = N_Incomplete_Type_Declaration then -- To be 100% honest, we have to check that at place of -- Reference_Node the full view is visible. But we could hardly -- call this routine (for a legal code) if we do not see the full -- view from Reference_Node. Tmp := Full_View (Defining_Identifier (Result_Node)); if Present (Tmp) then Result_Node := Parent (Tmp); end if; end if; end loop; -- If we have a type derived from an access type, we have to go through -- this derivation and unwind accessing if Nkind (Result_Node) = N_Full_Type_Declaration and then Nkind (Sinfo.Type_Definition (Result_Node)) = N_Derived_Type_Definition then Tmp := Defining_Identifier (Result_Node); if Ekind (Tmp) in Access_Kind then Result_Node := Explicit_Type_Declaration_Unwound_Unaccess (Directly_Designated_Type (Tmp), Reference_Node); end if; end if; return Result_Node; end Explicit_Type_Declaration_Unwound_Unaccess; --------------- -- Expr_Type -- --------------- function Expr_Type (Expression : Asis.Expression) return Asis.Declaration is Arg_Node : Node_Id; Arg_Kind : constant Internal_Element_Kinds := Int_Kind (Expression); Result_Entity : Node_Id; Result_Node : Node_Id; Result_Unit : Compilation_Unit; Res_Spec_Case : Special_Cases := Not_A_Special_Case; Encl_Cont : constant Context_Id := Encl_Cont_Id (Expression); begin -- first, we should check whether Expression has a universal -- numeric type and return the corresponding ASIS universal type. -- For now, this check includes numeric literals and some of the -- attribute references is: if Arg_Kind = An_Integer_Literal or else Arg_Kind = An_Alignment_Attribute or else Arg_Kind = A_Component_Size_Attribute or else Arg_Kind = A_Digits_Attribute or else Arg_Kind = A_Count_Attribute or else Arg_Kind = An_Exponent_Attribute or else Arg_Kind = A_First_Bit_Attribute or else Arg_Kind = A_Fore_Attribute or else Arg_Kind = A_Last_Bit_Attribute or else Arg_Kind = A_Length_Attribute or else Arg_Kind = A_Machine_Emax_Attribute or else Arg_Kind = A_Machine_Emin_Attribute or else Arg_Kind = A_Machine_Mantissa_Attribute or else Arg_Kind = A_Machine_Radix_Attribute or else Arg_Kind = A_Max_Size_In_Storage_Elements_Attribute or else Arg_Kind = A_Model_Emin_Attribute or else Arg_Kind = A_Model_Mantissa_Attribute or else Arg_Kind = A_Modulus_Attribute or else Arg_Kind = A_Partition_ID_Attribute or else Arg_Kind = A_Pos_Attribute or else Arg_Kind = A_Position_Attribute or else Arg_Kind = A_Scale_Attribute or else Arg_Kind = A_Size_Attribute or else Arg_Kind = A_Storage_Size_Attribute or else Arg_Kind = A_Wide_Width_Attribute or else Arg_Kind = A_Width_Attribute or else (Special_Case (Expression) = Rewritten_Named_Number and then Nkind (R_Node (Expression)) = N_Integer_Literal) then return Set_Root_Type_Declaration (A_Universal_Integer_Definition, Encl_Cont); elsif Arg_Kind = A_Real_Literal or else Arg_Kind = A_Delta_Attribute or else Arg_Kind = A_Model_Epsilon_Attribute or else Arg_Kind = A_Model_Small_Attribute or else Arg_Kind = A_Safe_First_Attribute or else Arg_Kind = A_Safe_Last_Attribute or else Arg_Kind = A_Small_Attribute or else (Special_Case (Expression) = Rewritten_Named_Number and then Nkind (R_Node (Expression)) = N_Real_Literal) then return Set_Root_Type_Declaration (A_Universal_Real_Definition, Encl_Cont); end if; Arg_Node := Node (Expression); -- In some cases we have to use the rewritten node if Is_Rewrite_Substitution (R_Node (Expression)) and then (Nkind (Arg_Node) = N_Aggregate and then Nkind (R_Node (Expression)) = N_String_Literal) then Arg_Node := R_Node (Expression); end if; while Nkind (Arg_Node) = N_String_Literal and then Nkind (Parent (Arg_Node)) = N_String_Literal loop -- Trick for F109-A24: for string literals in a static expression, -- Etype points to some dummy subtype node (the tree structure is -- rewritten for the whole expression, and the original subtree is -- not fully decorated), so we take the type information from the -- rewritten result of the expression Arg_Node := Parent (Arg_Node); end loop; -- if the expression node is rewritten, all the semantic -- information can be found only through the rewritten node if Nkind (Parent (Arg_Node)) = N_Expanded_Name and then Arg_Node = Selector_Name (Parent (Arg_Node)) then -- selector in an expanded name - all the semantic fields -- are set for the whole name, but not for this selector. -- So: Arg_Node := Parent (Arg_Node); end if; -- ??? -- this fragment should be revised when the problem is fixed (as it should) if Nkind (Arg_Node) = N_Selected_Component then if Etype (Arg_Node) = Any_Type then -- for now (GNAT 3.05) this means, that Expression is an expanded -- name of the character literal of ether a predefined character -- type or of the type derived from a predefined character type Arg_Node := R_Node (Expression); -- resetting Arg_Node pointing to the rewritten node for the -- expanded name -- -- ??? -- This looks strange... Should be revised else Arg_Node := Selector_Name (Arg_Node); -- here the actual type is! end if; elsif Nkind (Arg_Node) = N_Character_Literal and then No (Etype (Arg_Node)) -- for now (GNAT 3.05) this means, that Expression is the -- selector in an expanded name of the character literal of -- ether a predefined character type or of the type derived -- from a predefined character type then Arg_Node := Parent (Arg_Node); -- resetting Arg_Node pointing to the rewritten node for the whole -- expanded name end if; -- ??? - end -- now the idea is to take the Etype attribute of the expression -- and to go to the corresponding type declaration. But -- special processing for computing the right Etype is -- required for some cases if Nkind (Parent (Arg_Node)) = N_Qualified_Expression and then Arg_Node = Sinfo.Expression (Parent (Arg_Node)) then Result_Entity := Etype (Sinfo.Subtype_Mark (Parent (Arg_Node))); -- we'll keep the commented code below for a while... -- elsif (Arg_Kind = A_First_Attribute or else -- Arg_Kind = A_Last_Attribute) -- and then not Comes_From_Source (Etype (Arg_Node)) -- and then Sloc (Etype (Arg_Node)) > Standard_Location -- and then Etype (Etype (Arg_Node)) = Etype (Arg_Node) -- then -- -- this tricky condition corresponds to the situation, when -- -- 'First or 'Last attribute is applied to a formal discrete -- -- type @:-( -- -- In this case we simply use the attribute prefix to define -- -- the result type -- Result_Entity := Etype (Prefix (Arg_Node)); else -- how nice it would be if *everything* would be so simple Result_Entity := Etype (Arg_Node); end if; if Result_Entity = Any_Composite then -- Here we have an aggregate in some original tree structure that has -- not been properly decorated. All the semantic decorations are in -- the corresponding rewritten structure, so we have to find the -- corresponding node there. declare Tmp : Node_Id; New_Arg_Node : Node_Id := Empty; Arg_Kind : constant Node_Kind := Nkind (Arg_Node); Arg_Sloc : constant Source_Ptr := Sloc (Arg_Node); function Find (Node : Node_Id) return Traverse_Result; -- Check if its argument represents the same construct as -- Arg_Node, and if it does, stores Node in New_Arg_Node and -- returns Abandon, otherwise returns OK. procedure Find_Rewr_Aggr is new Traverse_Proc (Find); function Find (Node : Node_Id) return Traverse_Result is begin if Nkind (Node) = Arg_Kind and then Sloc (Node) = Arg_Sloc then New_Arg_Node := Node; return Abandon; else return OK; end if; end Find; begin Tmp := Parent (Arg_Node); while not Is_Rewrite_Substitution (Tmp) loop Tmp := Parent (Tmp); end loop; Find_Rewr_Aggr (Tmp); pragma Assert (Present (New_Arg_Node)); Result_Entity := Etype (New_Arg_Node); end; end if; Result_Node := Explicit_Type_Declaration (Result_Entity); if No (Result_Node) then return Nil_Element; -- we cannot represent the type declaration in ASIS; -- for example, an object defined by an object declaration -- with constrained array definition end if; if Sloc (Result_Entity) <= Standard_Location then Result_Unit := Get_Comp_Unit (Standard_Id, Encl_Cont_Id (Expression)); Res_Spec_Case := Explicit_From_Standard; else Result_Unit := Enclosing_Unit (Encl_Cont_Id (Expression), Result_Node); end if; return Node_To_Element_New (Node => Result_Node, Spec_Case => Res_Spec_Case, In_Unit => Result_Unit); end Expr_Type; ----------------------- -- Full_View_Visible -- ----------------------- function Full_View_Visible (Priv_Type : Node_Id; Ref : Node_Id) return Boolean is Type_Scope : constant Node_Id := Scope (Defining_Identifier (Priv_Type)); Type_Scope_Body : Node_Id; Type_Full_View : Node_Id; Scope_Node : Node_Id := Empty; Next_Node : Node_Id := Parent (Ref); Next_Node_Inner : Node_Id := Ref; Result : Boolean := False; begin Type_Scope_Body := Parent (Type_Scope); if Nkind (Type_Scope_Body) = N_Defining_Program_Unit_Name then Type_Scope_Body := Parent (Type_Scope_Body); end if; Type_Scope_Body := Corresponding_Body (Parent (Type_Scope_Body)); if Nkind (Parent (Type_Scope_Body)) = N_Defining_Program_Unit_Name then Type_Scope_Body := Parent (Type_Scope_Body); end if; while Present (Next_Node) loop if (Nkind (Next_Node) = N_Package_Specification and then Defining_Unit_Name (Next_Node) = Type_Scope) or else (Nkind (Next_Node) = N_Package_Body and then Defining_Unit_Name (Next_Node) = Type_Scope_Body) then Scope_Node := Next_Node; exit; end if; Next_Node_Inner := Next_Node; Next_Node := Parent (Next_Node); end loop; if Present (Scope_Node) then if Nkind (Scope_Node) = N_Package_Body then Result := True; elsif List_Containing (Next_Node_Inner) = Private_Declarations (Scope_Node) then -- That is, Ref is in the private part of the package where -- Priv_Type is declared, and we have to check what goes first: -- Ref (or a construct it is enclosed into - it is pointed by -- Next_Node_Inner) or the full view of the private type: Type_Full_View := Parent (Full_View (Defining_Identifier (Priv_Type))); Next_Node := First_Non_Pragma (Private_Declarations (Scope_Node)); while Present (Next_Node) loop if Next_Node = Type_Full_View then Result := True; exit; elsif Next_Node = Next_Node_Inner then exit; else Next_Node := Next_Non_Pragma (Next_Node); end if; end loop; end if; end if; return Result; end Full_View_Visible; -------------------------------- -- Get_Discriminant_From_Type -- -------------------------------- function Get_Discriminant_From_Type (N : Node_Id) return Entity_Id is Type_Entity : Entity_Id := Parent (N); Res_Chars : constant Name_Id := Chars (N); Result : Entity_Id; begin while not (Nkind (Type_Entity) = N_Subtype_Declaration or else Nkind (Type_Entity) = N_Subtype_Indication) loop Type_Entity := Parent (Type_Entity); if Nkind (Type_Entity) = N_Allocator then Type_Entity := Etype (Type_Entity); while Ekind (Type_Entity) in Access_Kind loop Type_Entity := Directly_Designated_Type (Type_Entity); end loop; exit; end if; end loop; if Nkind (Type_Entity) = N_Subtype_Indication and then Nkind (Parent (Type_Entity)) = N_Subtype_Declaration then Type_Entity := Parent (Type_Entity); end if; if Nkind (Type_Entity) = N_Subtype_Declaration then Type_Entity := Defining_Identifier (Type_Entity); else Type_Entity := Entity (Sinfo.Subtype_Mark (Type_Entity)); end if; while Type_Entity /= Etype (Type_Entity) loop exit when Comes_From_Source (Type_Entity) and then Comes_From_Source (Original_Node (Parent (Type_Entity))) and then Nkind (Parent (Type_Entity)) /= N_Subtype_Declaration; Type_Entity := Etype (Type_Entity); if Ekind (Type_Entity) = E_Access_Type then Type_Entity := Directly_Designated_Type (Type_Entity); elsif (Ekind (Type_Entity) = E_Private_Type or else Ekind (Type_Entity) = E_Limited_Private_Type) and then Present (Full_View (Type_Entity)) then Type_Entity := Full_View (Type_Entity); end if; end loop; -- Take care of a private type with unknown discriminant part: if Nkind (Parent (Type_Entity)) in N_Private_Extension_Declaration .. N_Private_Type_Declaration and then Unknown_Discriminants_Present (Parent (Type_Entity)) then Type_Entity := Full_View (Type_Entity); end if; -- In case of a derived types, we may have discriminants declared for an -- ansector type and then redefined for some child type Search_Discriminant : loop Result := Original_Node (Parent (Type_Entity)); Result := First (Discriminant_Specifications (Result)); while Present (Result) loop if Chars (Defining_Identifier (Result)) = Res_Chars then Result := Defining_Identifier (Result); exit Search_Discriminant; else Result := Next (Result); end if; end loop; exit Search_Discriminant when Type_Entity = Etype (Type_Entity); Type_Entity := Etype (Type_Entity); end loop Search_Discriminant; pragma Assert (Present (Result)); return Result; end Get_Discriminant_From_Type; ------------------------------- -- Get_Entity_From_Long_Name -- ------------------------------- function Get_Entity_From_Long_Name (N : Node_Id) return Entity_Id is Result : Entity_Id := Empty; Arg_Chars : constant Name_Id := Chars (N); Res_Chars : Name_Id; P : Node_Id; Next_Entity : Entity_Id; begin P := Parent (N); while No (Entity (P)) loop P := Parent (P); end loop; Next_Entity := Entity (P); Res_Chars := Chars (Next_Entity); loop if Res_Chars = Arg_Chars then Result := Next_Entity; exit; end if; if Nkind (Parent (Next_Entity)) = N_Defining_Program_Unit_Name then P := Sinfo.Name (Parent (Next_Entity)); Next_Entity := Entity (P); Res_Chars := Chars (Next_Entity); else exit; end if; end loop; pragma Assert (Present (Result)); return Result; end Get_Entity_From_Long_Name; ----------------------------- -- Get_Rewritten_Discr_Ref -- ----------------------------- function Get_Rewritten_Discr_Ref (N : Node_Id) return Node_Id is Res_Chars : constant Name_Id := Chars (N); Result : Node_Id := Parent (N); begin while not (Nkind (Result) = N_Identifier and then Is_Rewrite_Substitution (Result) and then Nkind (Original_Node (Result)) = N_Subtype_Indication) loop Result := Parent (Result); end loop; -- Go to the declaration of this internal subtype Result := Parent (Entity (Result)); -- Now - no the constraint Result := Sinfo.Constraint (Sinfo.Subtype_Indication (Result)); -- And iterating through discriminant names Result := First (Constraints (Result)); Result := First (Selector_Names (Result)); while Present (Result) loop if Chars (Result) = Res_Chars then exit; end if; -- Get to the next discriminant if Present (Next (Result)) then Result := Next (Result); else Result := Next (Parent (Result)); if Present (Result) then Result := First (Selector_Names (Result)); end if; end if; end loop; pragma Assert (Present (Result)); return Result; end Get_Rewritten_Discr_Ref; ------------------------------ -- Get_Specificed_Component -- ------------------------------ function Get_Specificed_Component (Comp : Node_Id; Rec_Type : Entity_Id) return Entity_Id is Rec_Type_Entity : Entity_Id; Result : Entity_Id := Empty; Res_Chars : constant Name_Id := Chars (Comp); Next_Comp : Node_Id; begin if Ekind (Rec_Type) = E_Private_Type or else Ekind (Rec_Type) = E_Limited_Private_Type then Rec_Type_Entity := Full_View (Rec_Type); else Rec_Type_Entity := Rec_Type; end if; Next_Comp := First_Entity (Rec_Type_Entity); while Present (Next_Comp) loop if Chars (Next_Comp) = Res_Chars then Result := Next_Comp; exit; end if; Next_Comp := Next_Entity (Next_Comp); end loop; pragma Assert (Present (Result)); return Result; end Get_Specificed_Component; ------------------------------ -- Get_Statement_Identifier -- ------------------------------ function Get_Statement_Identifier (Def_Id : Node_Id) return Node_Id is Result_Node : Node_Id := Empty; -- List_Elem : Node_Id; begin Result_Node := Label_Construct (Parent (Def_Id)); if not (Nkind (Result_Node) = N_Label) then -- this means, that Result_Node is of N_Block_Statement or -- of N_Loop_Statement kind, therefore Result_Node := Sinfo.Identifier (Result_Node); end if; return Result_Node; end Get_Statement_Identifier; --------------------- -- GFP_Declaration -- --------------------- function GFP_Declaration (Par_Id : Node_Id) return Node_Id is Par_Chars : constant Name_Id := Chars (Par_Id); Result_Node : Node_Id; Gen_Par_Decl : Node_Id; begin -- First, going up to the generic instantiation itself: Result_Node := Parent (Parent (Par_Id)); -- then taking the name of the generic unit being instantiated -- and going to its definition - and declaration: Result_Node := Parent (Parent (Entity (Sinfo.Name (Result_Node)))); -- and now - searching the declaration of the corresponding -- generic parameter: Gen_Par_Decl := First_Non_Pragma (Generic_Formal_Declarations (Result_Node)); while Present (Gen_Par_Decl) loop if Nkind (Gen_Par_Decl) in N_Formal_Subprogram_Declaration then Result_Node := Defining_Unit_Name (Specification (Gen_Par_Decl)); else Result_Node := Defining_Identifier (Gen_Par_Decl); end if; if Chars (Result_Node) = Par_Chars then exit; else Gen_Par_Decl := Next_Non_Pragma (Gen_Par_Decl); end if; end loop; return Result_Node; end GFP_Declaration; -------------------------------- -- Identifier_Name_Definition -- -------------------------------- function Identifier_Name_Definition (Reference_I : Element) return Asis.Defining_Name is Arg_Node : Node_Id; Arg_Node_Kind : Node_Kind; Arg_Kind : constant Internal_Element_Kinds := Int_Kind (Reference_I); Result_Node : Node_Id := Empty; Result_Unit : Compilation_Unit; Spec_Case : Special_Cases := Not_A_Special_Case; Result_Kind : Internal_Element_Kinds := Not_An_Element; Is_Inherited : Boolean := False; Association_Type : Node_Id := Empty; -- ??? Is it a good name for a parameter? Componnet_Name : Node_Id := Empty; Tmp_Node : Node_Id; Result : Asis.Element; function Ekind (N : Node_Id) return Entity_Kind; -- This function differs from Atree.Ekind in that it can operate -- with N_Defining_Program_Unit_Name (in this case it returns -- Atree.Ekind for the corresponding Defining_Identifier node. function Ekind (N : Node_Id) return Entity_Kind is Arg_Node : Node_Id := N; begin if Nkind (Arg_Node) = N_Defining_Program_Unit_Name then Arg_Node := Defining_Identifier (Arg_Node); end if; return Atree.Ekind (Arg_Node); end Ekind; begin -- this function is currently integrated with -- Enumeration_Literal_Name_Definition and -- Operator_Symbol_Name_Definition -- The implementation approach is very similar to that one of -- A4G.A_Sem.Get_Corr_Called_Entity. Now the implicit *predefined* -- operations are turned off for a while ------------------------------------------------------------------ -- 1. Defining Result_Node (and adjusting Arg_Node, if needed) -- ------------------------------------------------------------------ if Arg_Kind = An_Identifier then Result_Kind := A_Defining_Identifier; -- may be changed to A_Defining_Expanded_Name later elsif Arg_Kind = An_Enumeration_Literal then Result_Kind := A_Defining_Enumeration_Literal; elsif Arg_Kind in Internal_Operator_Symbol_Kinds then Result_Kind := Def_Operator_Kind (Int_Kind (Reference_I)); end if; if Special_Case (Reference_I) = Rewritten_Named_Number then Arg_Node := R_Node (Reference_I); else -- Arg_Node := Get_Actual_Type_Name (Node (Reference_I)); Arg_Node := Node (Reference_I); end if; -- the code below is really awful! In some future we'll have -- to revise this "patch on patch" approach!!! if Is_Part_Of_Defining_Unit_Name (Arg_Node) and then Kind (Encl_Unit (Reference_I)) in A_Library_Unit_Body then -- this means, that we have a part of a prefix of a defining -- unit name which is a part of a body. These components do not -- have Entity field set, so we have to go to the spec: Arg_Node := Reset_To_Spec (Arg_Node); end if; if Nkind (Arg_Node) in N_Entity then -- This is the case of the reference to a formal type inside -- the expanded code when the actual type is a derived type -- In this case Get_Actual_Type_Name returns the entity node -- (see 8924-006) Result_Node := Arg_Node; Arg_Node := Node (Reference_I); -- For the rest of the processing we need Arg_Node properly set as -- the reference, but not as an entity node elsif Special_Case (Reference_I) = Rewritten_Named_Number then -- See BB10-002 Result_Node := Original_Entity (Arg_Node); elsif No (Entity (Arg_Node)) then Arg_Node_Kind := Nkind (Original_Node (Parent (Arg_Node))); -- in some cases we can try to "repair" the situation: if Arg_Node_Kind = N_Expanded_Name then -- the Entity field is set for the whole expanded name: if Entity_Present (Original_Node (Parent (Arg_Node))) or else Entity_Present (Parent (Arg_Node)) then Arg_Node := Parent (Arg_Node); -- In case of renamings, here we may have the expanded name -- rewritten, and the Entity field for the new name pointing -- to the renamed entity, but not to the entity defined by -- the renamed declaration, see B924-A13 if Is_Rewrite_Substitution (Arg_Node) and then Entity_Present (Original_Node (Arg_Node)) then Arg_Node := Original_Node (Arg_Node); end if; else -- Trying to "traverse a "long" defining program unit -- name (see 7917-005) Result_Node := Get_Entity_From_Long_Name (Arg_Node); end if; elsif Arg_Node_Kind = N_Component_Definition and then Sloc (Arg_Node) = Standard_Location then -- Special case of Subtype_Indication for predefined String -- and Wide_String types: Result_Node := Parent (Parent (Parent (Arg_Node))); -- Here we are in N_Full_Type_Declaration node Result_Node := Defining_Identifier (Result_Node); Result_Node := Component_Type (Result_Node); Spec_Case := Explicit_From_Standard; elsif Arg_Node_Kind = N_Function_Call then -- this is a special case of a parameterless function call -- of the form P.F Arg_Node := Sinfo.Name (Original_Node (Parent (Arg_Node))); elsif Arg_Node_Kind = N_Integer_Literal or else Arg_Node_Kind = N_Real_Literal or else Arg_Node_Kind = N_Character_Literal or else Arg_Node_Kind = N_String_Literal or else Arg_Node_Kind = N_Identifier then -- All but last conditions are a result of some compile-time -- optimization. The last one is a kind of -- semantically-transparent transformation which loses some -- semantic information for replaced structures (see the test -- for 9429-006). -- -- The last condition may need some more attention in case if new -- Corresponding_Name_Definition problems are detected Arg_Node := Original_Node (Parent (Arg_Node)); elsif Arg_Node_Kind = N_Component_Association and then Nkind (Parent (Parent (Arg_Node))) = N_Raise_Constraint_Error then -- A whole aggregate is rewritten into N_Raise_Constraint_Error -- node, see G628-026 Tmp_Node := Parent (Parent (Arg_Node)); Tmp_Node := Etype (Tmp_Node); Tmp_Node := First_Entity (Tmp_Node); while Present (Tmp_Node) loop if Chars (Tmp_Node) = Chars (Arg_Node) then Result_Node := Tmp_Node; exit; end if; Tmp_Node := Next_Entity (Tmp_Node); end loop; pragma Assert (Present (Result_Node)); if not (Comes_From_Source (Result_Node)) and then Comes_From_Source (Parent (Result_Node)) then Result_Node := Defining_Identifier (Parent (Result_Node)); end if; elsif Arg_Node_Kind = N_Component_Association and then Nkind (Sinfo.Expression (Parent (Arg_Node))) = N_Raise_Constraint_Error then -- here we are guessing for the situation when a compiler -- optimization take place. We can probably be non-accurate -- for inherited record components, but what can we do.... -- -- first, defining the corresponding Entity Node, we assume -- it to be a record component definition Result_Node := Parent (Parent (Arg_Node)); -- aggregate Association_Type := Etype (Result_Node); if Ekind (Association_Type) in Private_Kind then Association_Type := Full_View (Association_Type); end if; Result_Node := First_Entity (Association_Type); while Chars (Result_Node) /= Chars (Arg_Node) loop Result_Node := Next_Entity (Result_Node); end loop; elsif Arg_Node_Kind = N_Parameter_Association and then Arg_Node = Selector_Name (Parent (Arg_Node)) then -- Currently we assume, that this corresponds to the case of -- formal parameters of predefined operations return Nil_Element; elsif Arg_Node_Kind = N_Component_Clause then -- Component clause in record representation clause - Entity -- field is not set, we have to traverse the list of components -- of the record type Association_Type := Entity (Sinfo.Identifier (Parent (Parent (Arg_Node)))); if Ekind (Association_Type) = E_Record_Subtype then -- In case of a subtype it may be the case that some components -- depending on discriminant are skipped in case of a static -- discriminnat constraint, see also -- A4G.Mapping.Set_Inherited_Components Association_Type := Etype (Association_Type); end if; Result_Node := Get_Specificed_Component (Arg_Node, Association_Type); Association_Type := Empty; -- Association_Type is set back to Empty to make it possible -- to use the general approach for computing Association_Type -- later elsif Nkind (Arg_Node) = N_Identifier and then Sloc (Parent (Arg_Node)) = Standard_ASCII_Location then -- reference to Character in a constant definition in the -- ASCII package, see 8303-011 Result_Node := Standard_Character; elsif not (Arg_Node_Kind = N_Discriminant_Association or else Arg_Node_Kind = N_Generic_Association) and then not Is_From_Unknown_Pragma (R_Node (Reference_I)) then -- now we are considering all the other cases as component simple -- names in a (rewritten!) record aggregate, and we go from the -- original to the rewritten structure (because the original -- structure is not decorated). If this is not the case, we should -- get the Assert_Failure raised in Rewritten_Image -- Arg_Node := Rewritten_Image (Arg_Node); Result_Node := Search_Record_Comp (Arg_Node); end if; end if; if No (Result_Node) and then No (Entity (Arg_Node)) and then not (Nkind (Parent (Arg_Node)) = N_Discriminant_Association or else Nkind (Parent (Arg_Node)) = N_Generic_Association or else Is_From_Unknown_Pragma (R_Node (Reference_I))) then if Debug_Flag_S then Write_Str ("A4G.Expr_Sem.Identifier_Name_Definition:"); Write_Eol; Write_Str ("no Entity field is set for Node "); Write_Int (Int (Arg_Node)); Write_Eol; Write_Str (" the debug image of the query argument is:"); Write_Eol; Debug_String (Reference_I); Write_Str (Debug_Buffer (1 .. Debug_Buffer_Len)); Write_Eol; end if; raise Internal_Implementation_Error; end if; if Present (Result_Node) then null; elsif Is_From_Unknown_Pragma (R_Node (Reference_I)) then return Nil_Element; elsif Nkind (Parent (Arg_Node)) = N_Discriminant_Association and then Arg_Node /= Original_Node (Sinfo.Expression (Parent (Arg_Node))) then -- We use Original_Node (Sinfo.Expression (Parent (Arg_Node))) -- because of C730-016 (named numbers rewritten into their values) if No (Original_Discriminant (Arg_Node)) then Result_Node := Get_Discriminant_From_Type (Arg_Node); else Result_Node := Original_Discriminant (Arg_Node); if Present (Corresponding_Discriminant (Result_Node)) then Result_Node := Corresponding_Discriminant (Result_Node); end if; end if; elsif No (Entity (Arg_Node)) and then Nkind (Parent (Arg_Node)) = N_Generic_Association then -- this is the problem up to 3.10p. We have to compute -- N_Defining_Identifier_Node for this generic formal -- parameter "by hands" -- ??? should be rechecked for 3.11w!!! Result_Node := GFP_Declaration (Arg_Node); else Result_Node := Entity (Arg_Node); end if; -- Here we have Result_Node set. And now we have a whole bunch of -- situations when we have to correct Result_Node because of different -- reasons -- If Result_Node is the type reference, and the type has both private -- and full view, Result_Node will point to the private view. In some -- situations we have to replace it with the full view. if Ekind (Result_Node) in Einfo.Type_Kind and then Nkind (Original_Node (Parent (Result_Node))) in N_Private_Extension_Declaration .. N_Private_Type_Declaration and then Full_View_Visible (Priv_Type => Parent (Result_Node), Ref => Arg_Node) then Result_Node := Full_View (Result_Node); end if; -- FB02-015: Ada 2005 - reference to a record type with self-referencing -- components, The front-end creates an incomplete type -- declaration, and the Entity field may point to this -- incomplete type. if Ekind (Result_Node) = E_Incomplete_Type and then not Comes_From_Source (Result_Node) and then Nkind (Parent (Result_Node)) = N_Incomplete_Type_Declaration then Tmp_Node := Full_View (Result_Node); if Present (Tmp_Node) then Result_Node := Full_View (Result_Node); end if; end if; -- F818-A05: reference to a formal parameter of a child subprogram in -- case when the subprogram does not have a separate spec. -- The front-end creates some artificial data structures to -- represent this separate spec, so the entity field of a -- parameter reference points to some artificial node if Nkind (Parent (Result_Node)) = N_Parameter_Specification and then not (Comes_From_Source (Result_Node)) then -- Check if we are in the artificial spec created for child -- subprogram body: Tmp_Node := Scope (Result_Node); Tmp_Node := Parent (Parent (Parent (Tmp_Node))); if Nkind (Tmp_Node) = N_Subprogram_Declaration and then not Comes_From_Source (Tmp_Node) and then Present (Parent_Spec (Tmp_Node)) and then Present (Corresponding_Body (Tmp_Node)) then -- Go to the defining identifier of this parameter in subprogram -- body: Tmp_Node := Corresponding_Body (Tmp_Node); Tmp_Node := Parent (Parent (Tmp_Node)); Tmp_Node := First_Non_Pragma (Parameter_Specifications (Tmp_Node)); while Present (Tmp_Node) loop if Chars (Defining_Identifier (Tmp_Node)) = Chars (Result_Node) then Result_Node := Defining_Identifier (Tmp_Node); exit; end if; Tmp_Node := Next_Non_Pragma (Tmp_Node); end loop; pragma Assert (Present (Tmp_Node)); end if; end if; -- E802-015: for a protected operation items that do not have separate -- specs the front-end creates these specs and sets all the Entity -- fields pointing to the entities from these artificial specs. if Is_Artificial_Protected_Op_Item_Spec (Result_Node) then if Ekind (Result_Node) in Formal_Kind then Tmp_Node := Parent (Parent (Parent (Result_Node))); Tmp_Node := Parent (Corresponding_Body (Tmp_Node)); Tmp_Node := First_Non_Pragma (Parameter_Specifications (Tmp_Node)); while Present (Tmp_Node) loop if Chars (Defining_Identifier (Tmp_Node)) = Chars (Result_Node) then Result_Node := Defining_Identifier (Tmp_Node); exit; else Tmp_Node := Next_Non_Pragma (Tmp_Node); end if; end loop; else -- The only possibility - the protected operation entity Result_Node := Corresponding_Body (Parent (Parent (Result_Node))); end if; end if; -- See E421-006: problem with reference to a formal type in an expanded -- code. if Present (Result_Node) and then Is_Itype (Result_Node) -- and then Present (Cloned_Subtype (Result_Node)) then if Special_Case (Reference_I) = Dummy_Base_Attribute_Prefix then Result_Node := Associated_Node_For_Itype (Result_Node); else Result_Node := Etype (Result_Node); end if; -- This is for E912-013 if No (Parent (Result_Node)) and then Present (Associated_Node_For_Itype (Result_Node)) then Result_Node := Defining_Identifier (Associated_Node_For_Itype (Result_Node)); elsif Special_Case (Reference_I) = Dummy_Base_Attribute_Prefix then Result_Node := Defining_Identifier (Result_Node); end if; end if; -- Problem with System redefined with Extend_System pragma (E315-001) if Nkind (Arg_Node) in N_Has_Chars and then Chars (Arg_Node) = Name_System and then Chars (Result_Node) /= Name_System and then Nkind (Parent (Result_Node)) = N_Defining_Program_Unit_Name then Result_Node := Entity (Sinfo.Name (Parent (Result_Node))); pragma Assert (Chars (Result_Node) = Name_System); end if; -- Problem with tasks defined by a single task definition: for such a -- definition the front-end creates an artificial variable declaration -- node, and for the references to such task, the Entity field points to -- the entity node from this artificial variable declaration (E224-024). -- The same problem exists for a single protected declaration -- (E418-015) Tmp_Node := Parent (Result_Node); if Comes_From_Source (Result_Node) and then not Comes_From_Source (Tmp_Node) and then Nkind (Tmp_Node) = N_Object_Declaration and then not Constant_Present (Tmp_Node) and then No (Corresponding_Generic_Association (Tmp_Node)) then Tmp_Node := Etype (Result_Node); if Ekind (Tmp_Node) in Concurrent_Kind then Result_Node := Parent (Result_Node); while not (Nkind (Result_Node) = N_Task_Type_Declaration or else Nkind (Result_Node) = N_Protected_Type_Declaration) loop Result_Node := Prev (Result_Node); end loop; end if; Result_Node := Defining_Identifier (Original_Node (Result_Node)); end if; -- F703-020: see the comment marked by this TN in the body of -- A4G.A_Sem.Get_Corr_Called_Entity if not Comes_From_Source (Result_Node) and then Is_Overloadable (Result_Node) and then Present (Alias (Result_Node)) and then not (Is_Intrinsic_Subprogram (Result_Node)) and then Pass_Generic_Actual (Parent (Result_Node)) then -- ??? Result_Node := Alias (Result_Node); end if; -- and here we have to solve the problem with generic instances: -- for them Result_Node as it has been obtained above points not -- to the defining identifier from the corresponding instantiation, -- but to an entity defined in a "implicit" package created by the -- compiler if Is_Generic_Instance (Result_Node) then Result_Node := Get_Instance_Name (Result_Node); end if; -- If the argument is Is_Part_Of_Implicit reference to a type, we -- have to check if it is the reference to a type mark in parameter -- or parameter and result profile of inherited subprogram and if it -- should be substituted by the reference to the corresponding -- derived type Tmp_Node := Node_Field_1 (Reference_I); if Ekind (Result_Node) in Einfo.Type_Kind and then Is_From_Inherited (Reference_I) and then Nkind (Tmp_Node) in Sinfo.N_Entity and then (Ekind (Tmp_Node) = E_Procedure or else Ekind (Tmp_Node) = E_Function) then Result_Node := Get_Derived_Type (Type_Entity => Result_Node, Inherited_Subpr => Tmp_Node); end if; -- labels (and, probably, statement names!!) makes another problem: -- we have to return not the implicit label (statement identifier??) -- declaration, but the label (statement name) attached to the -- corresponding statement if Nkind (Parent (Result_Node)) = N_Implicit_Label_Declaration then Result_Node := Get_Statement_Identifier (Result_Node); end if; Tmp_Node := Original_Node (Parent (Parent (Result_Node))); while Nkind (Tmp_Node) = N_Subprogram_Renaming_Declaration and then not (Comes_From_Source (Tmp_Node)) and then not Pass_Generic_Actual (Tmp_Node) loop -- Result_Node is a defining name from the artificial renaming -- declarations created by the compiler in the for wrapper -- package for expanded subprogram instantiation. We -- have to go to expanded subprogram spec which is renamed. -- -- We have to do this in a loop in case of nested instantiations Result_Node := Sinfo.Name (Tmp_Node); if Nkind (Result_Node) = N_Selected_Component then Result_Node := Selector_Name (Result_Node); end if; Result_Node := Entity (Result_Node); Tmp_Node := Parent (Parent (Result_Node)); end loop; -- -- ??? -- if Ekind (Result_Node) = E_Operator then -- Result_Kind := N_Defining_Identifier_Mapping (Result_Node); -- end if; if Nkind (Parent (Result_Node)) = N_Defining_Program_Unit_Name or else Nkind (Result_Node) = N_Defining_Program_Unit_Name then -- if we are processing the reference to a child unit, we have to -- go from a defining identifier to the corresponding defining -- unit name (the first part of the condition). -- If this is a reference to a child subprogram, for which -- the separate subprogram specification does not exist, -- GNAT generates the tree structure corresponding to such a -- separate subprogram specification, and it set the Entity -- field for all references to this subprogram pointing -- to the defining identifier in this inserted subprogram -- specification. This case may be distinguished by the fact, -- that Comes_From_Source field for this defining identifier -- is set OFF. And in this case we have to go to the defining -- identifier in the subprogram body: if not Comes_From_Source (Result_Node) then -- we have to go to the defining identifier in the -- corresponding body: while not (Nkind (Result_Node) = N_Subprogram_Declaration) loop Result_Node := Parent (Result_Node); end loop; Result_Node := Corresponding_Body (Result_Node); end if; if Nkind (Result_Node) /= N_Defining_Program_Unit_Name then Result_Node := Parent (Result_Node); end if; Result_Kind := A_Defining_Expanded_Name; if not Comes_From_Source (Result_Node) then -- now it means that we have a library level instantiation -- of a generic child package Result_Node := Parent (Parent (Result_Node)); Result_Node := Original_Node (Result_Node); if Nkind (Result_Node) = N_Package_Declaration then Result_Node := Sinfo.Corresponding_Body (Result_Node); while Nkind (Result_Node) /= N_Package_Body loop Result_Node := Parent (Result_Node); end loop; Result_Node := Original_Node (Result_Node); end if; Result_Node := Defining_Unit_Name (Result_Node); end if; end if; if Nkind (Result_Node) = N_Defining_Identifier and then (Ekind (Result_Node) = E_In_Parameter or else Ekind (Result_Node) = E_Constant) and then Present (Discriminal_Link (Result_Node)) then -- here we have to go to an original discriminant Result_Node := Discriminal_Link (Result_Node); end if; -- FA13-008: subtype mark in parameter specification in implicit "/=" -- declaration in case if in the corresponding "=" the parameter is -- specified by 'Class attribute: if Nkind (Arg_Node) = N_Identifier and then not Comes_From_Source (Arg_Node) and then Ekind (Result_Node) = E_Class_Wide_Type and then Result_Node /= Defining_Identifier (Parent (Result_Node)) then Result_Node := Defining_Identifier (Parent (Result_Node)); end if; -- Now we have Result_Node pointing to some defining name. There are -- some kinds of entities which require special processing. For -- implicitly declared entities we have to set Association_Type -- pointing to a type which "generates" the corresponding implicit -- declaration (there is no harm to set Association_Type for explicitly -- declared entities, but for them it is of no use). For predefined -- entities the special case attribute should be set. ---------------------------------------- -- temporary solution for 5522-003 ???-- ---------------------------------------- -- The problem for record components: -- -- 1. The Entity field for references to record components and -- disciminants may point to field of some implicit types created -- by the compiler -- -- 2. The Entity field for the references to the (implicitly declared!) -- components of a derived record type point to the explicit -- declarations of the component of the ancestor record type -- -- 3. Probably, all this stuff should be incapsulated in a separate -- subprogram??? -- Here we already have Result_Node: if Nkind (Result_Node) = N_Defining_Identifier and then (Ekind (Result_Node) = E_Component or else Ekind (Result_Node) = E_Discriminant or else Ekind (Result_Node) = E_Entry or else Ekind (Result_Node) = E_Procedure or else Ekind (Result_Node) = E_Function) then -- first, we compute Association_Type as pointed to a type -- declaration for which Agr_Node is a component: if No (Association_Type) then Association_Type := Parent (Arg_Node); if Nkind (Association_Type) = N_Function_Call then Association_Type := Sinfo.Name (Association_Type); end if; case Nkind (Association_Type) is when N_Component_Clause => Association_Type := Sinfo.Identifier (Parent (Association_Type)); when N_Selected_Component => Association_Type := Prefix (Association_Type); if Nkind (Association_Type) = N_Attribute_Reference and then (Attribute_Name (Association_Type) = Name_Unrestricted_Access or else Attribute_Name (Association_Type) = Name_Access) then -- See G222-012 Association_Type := Prefix (Association_Type); end if; if Nkind (Association_Type) = N_Selected_Component then Association_Type := Selector_Name (Association_Type); end if; when N_Component_Association => Association_Type := Parent (Association_Type); when N_Discriminant_Association => if Arg_Node = Sinfo.Expression (Association_Type) then -- using a discriminant in initialization expression Association_Type := Empty; else Association_Type := Scope (Result_Node); end if; when others => -- We set Association_Type as Empty to indicate the case of -- a definitely explicit result Association_Type := Empty; end case; end if; if Present (Association_Type) then if not (Comes_From_Source (Association_Type) and then Nkind (Association_Type) in N_Entity and then Ekind (Association_Type) in Einfo.Type_Kind) then Association_Type := Etype (Association_Type); end if; if Nkind (Original_Node (Parent (Association_Type))) = N_Single_Task_Declaration or else Nkind (Original_Node (Parent (Association_Type))) = N_Single_Protected_Declaration then Association_Type := Empty; else if Ekind (Result_Node) = E_Component and then not Comes_From_Source (Parent (Result_Node)) and then Ekind (Association_Type) in Private_Kind then Association_Type := Full_View (Association_Type); end if; Association_Type := Explicit_Type_Declaration_Unwound_Unaccess (Association_Type, Arg_Node); if Nkind (Original_Node (Association_Type)) in N_Protected_Type_Declaration .. N_Private_Extension_Declaration then Association_Type := Parent (Full_View (Defining_Identifier (Original_Node (Association_Type)))); end if; end if; end if; -- then, we have to adjust result Node: if Ekind (Result_Node) = E_Discriminant and then Chars (Discriminal (Result_Node)) /= Chars (Original_Record_Component (Result_Node)) then -- This condition is the clue for discriminants explicitly -- declared in declarations of derived types. -- These assignments below resets Result_Node to -- N_Defining_Identifier node which denotes the same discriminant -- but has a properly set bottom-up chain of Parent nodes Result_Node := Discriminal (Result_Node); Result_Node := Discriminal_Link (Result_Node); else -- There we have to come from an implicit type to a explicitly -- declared type: Tmp_Node := Scope (Result_Node); if Ekind (Tmp_Node) = E_Record_Subtype then Tmp_Node := Etype (Tmp_Node); end if; if (Ekind (Result_Node) = E_Component or else Ekind (Result_Node) = E_Discriminant) and then not (Comes_From_Source (Result_Node) and then not Comes_From_Source (Parent (Result_Node))) then -- This condition leaves unchanged inherited discriminants -- of derived record types Tmp_Node := First_Entity (Tmp_Node); while Present (Tmp_Node) loop if Chars (Tmp_Node) = Chars (Result_Node) then Result_Node := Tmp_Node; exit; end if; Tmp_Node := Next_Entity (Tmp_Node); end loop; end if; end if; -- A private type may require some special adjustment in case if -- full view is visible: if Result_Node is a discriminant: -- it points to a discriminant in a private view, and we have -- to reset it to point to the discriminant in the full view if Present (Association_Type) and then Has_Private_Declaration (Defining_Identifier (Association_Type)) and then Ekind (Result_Node) = E_Discriminant and then Nkind (Association_Type) /= N_Private_Type_Declaration and then Nkind (Association_Type) /= N_Private_Extension_Declaration and then Is_Type_Discriminant (Result_Node, Original_Node (Association_Type)) then Result_Node := Reset_To_Full_View (Association_Type, Result_Node); end if; -- Now, we have to define if we have an implicit component here. -- Result_Context_Node is finally supposed to be set to the -- declaration of the type to which the argument component belongs if No (Association_Type) then -- definitely explicit result: Is_Inherited := False; elsif Is_Rewrite_Substitution (Association_Type) then -- here we have a derived type with no record extension part -- but it can have an explicitly declared discriminant if Ekind (Result_Node) = E_Discriminant then Is_Inherited := not (Is_Type_Discriminant ( Result_Node, Original_Node (Association_Type))); else Is_Inherited := True; end if; elsif Nkind (Association_Type) = N_Incomplete_Type_Declaration or else Nkind (Association_Type) = N_Private_Extension_Declaration or else Nkind (Association_Type) = N_Private_Type_Declaration or else Nkind (Association_Type) = N_Task_Type_Declaration or else Nkind (Association_Type) = N_Protected_Type_Declaration or else (Nkind (Association_Type) = N_Formal_Type_Declaration and then Nkind (Sinfo.Formal_Type_Definition (Association_Type)) = N_Formal_Private_Type_Definition) or else Nkind (Sinfo.Type_Definition (Association_Type)) = N_Record_Definition then -- should be an explicit component Is_Inherited := False; -- Patch for E407-A08 if Ekind (Result_Node) = E_Component then Result_Node := Original_Record_Component (Result_Node); end if; elsif Nkind (Sinfo.Type_Definition (Association_Type)) = N_Derived_Type_Definition then -- it may be an inherited component or an explicitly declared -- discriminant or a component from a record extension part if Is_Explicit_Type_Component (Result_Node, Association_Type) then Is_Inherited := False; else Is_Inherited := True; end if; else -- ??? this Assert pragma - only for development/debug period -- ??? what else except N_Selected_Component could be here null; pragma Assert (False); end if; end if; ------------------------------------------------- -- end for the temporary solution for 5522-003 -- ------------------------------------------------- -------------------------- -- Enumeration literals -- -------------------------- if not (Defined_In_Standard (Arg_Node)) and then Nkind (Result_Node) = N_Defining_Identifier -- or else -- Nkind (Result_Node) = N_Defining_Character_Literal) and then Ekind (Result_Node) = E_Enumeration_Literal and then (not Comes_From_Source (Result_Node)) then -- an enumeration literal inherited by a derived type definition -- (character literals are still processed by a separate function -- Character_Literal_Name_Definition, that's why the corresponding -- part of the condition is commented out) -- ???Needs revising for the new model of implicit Elements Is_Inherited := True; Association_Type := Etype (Arg_Node); Association_Type := Explicit_Type_Declaration_Unwound (Association_Type); end if; --------------------------------------- -- The rest of special processing: -- -- somewhat messy and needs revising -- --------------------------------------- -- We have to turn off for a while the full processing of the -- implicit elements (Hope to fix this soon). if Defined_In_Standard (Arg_Node) or else Sloc (Arg_Node) <= Standard_Location or else Sloc (Result_Node) <= Standard_Location then -- We need the second part of the condition for references to -- Standard.Characters which are parts of the definitions in -- the ASCII package if Ekind (Result_Node) = E_Operator then return Nil_Element; else -- I hope, that I'm right, that all the *identifiers* declared -- in standard are declared explicitly, and all the rest -- (which are defined in Standard) are implicit -- Root and universal types can make a problem, but let's -- see it before... Spec_Case := Explicit_From_Standard; end if; else if Result_Kind in Internal_Defining_Operator_Kinds then if Is_Predefined (Result_Node) then Spec_Case := Predefined_Operation; -- -- note, that Predefined_Operation corresponds to an -- -- implicitly declared operation of a type, which is defined -- -- not in the Standard package -- Association_Type := Enclosed_Type (Result_Node); -- -- we have to use namely Association_Type, but not Result_Node -- -- to define Result_Unit, because sometimes Result_Node -- -- does not have the Parent field set return Nil_Element; -- ???!!! this turns off all the predefined operations -- !!!??? defined not in Standard elsif Is_Impl_Neq (Result_Node) then Spec_Case := Is_From_Imp_Neq_Declaration; end if; end if; end if; ------------------- -- Limited views -- ------------------- if Spec_Case = Not_A_Special_Case then Tmp_Node := Result_Node; if Nkind (Tmp_Node) = N_Defining_Program_Unit_Name then Tmp_Node := Defining_Identifier (Tmp_Node); end if; if Nkind (Tmp_Node) in N_Entity then case Ekind (Tmp_Node) is when Einfo.Type_Kind => if not Comes_From_Source (Tmp_Node) and then Ekind (Tmp_Node) in Incomplete_Kind and then Present (Non_Limited_View (Tmp_Node)) then Spec_Case := From_Limited_View; Result_Node := Non_Limited_View (Result_Node); end if; when E_Package => if not Is_Generic_Instance (Tmp_Node) then if not Analyzed (Parent (Result_Node)) then Spec_Case := From_Limited_View; elsif Is_Limited_Withed (Result_Node, Reference_I) then Spec_Case := From_Limited_View; end if; end if; when others => null; end case; end if; end if; if Spec_Case not in Predefined and then Spec_Case /= Is_From_Imp_Neq_Declaration and then Spec_Case /= From_Limited_View and then not Comes_From_Source (Result_Node) and then No (Association_Type) and then not Part_Of_Pass_Generic_Actual (Result_Node) then -- Here we may have the following possibilities: -- - library-level subprogram instantiation; -- - artificial entity created for an inner package from a package -- "withed" by a limited with clause; -- - defining name from the artificial spec created for subprogram -- body which acts as a spec; -- - prefix of the artificial 'Class attribute reference (ASIS has -- to emulate such an attribute reference in case if a class-wide -- type is use as an actual type in the instantiation); -- - index (sub)type in case if the corresponding type is declared as -- private (F424-A01); -- - F619-024; -- - F627-001 -- - inherited subprogram; if Nkind (Parent (Result_Node)) in N_Subprogram_Specification then if Is_Generic_Instance (Result_Node) then -- Library-level subprogram instantiation -- Here we have to go from the rewritten to the original -- tree structure -- This code appeared at some point, but it seems that it is -- of no real need. Will be for a while - just in case. -- It does not allow to fix G312-006 -- ??? -- Result_Node := Parent (Parent (Parent (Parent (Result_Node)))); -- Result_Node := Original_Node (Result_Node); -- Result_Node := Sinfo.Defining_Unit_Name (Result_Node); null; else -- Artificial subprogram spec created for the body acting -- as spec Result_Node := Parent (Parent (Result_Node)); Result_Node := Corresponding_Body (Result_Node); end if; elsif Nkind (Parent (Result_Node)) = N_Package_Specification and then Comes_From_Source (Parent (Result_Node)) then -- An artificial internal entity created for a local package -- from a package that is "withed" by limited with clause -- We go to the entity node the package spec points to. -- See F310-025 and F311-003. Result_Node := Defining_Unit_Name (Parent (Result_Node)); elsif Special_Case (Reference_I) = Dummy_Class_Attribute_Prefix and then Ekind (Result_Node) = E_Class_Wide_Type then Result_Node := Defining_Identifier (Parent (Result_Node)); elsif Ekind (Result_Node) in Discrete_Kind and then Nkind (Parent (Result_Node)) = N_Subtype_Declaration then -- Go to the full view of the corresponding private type: Result_Node := Sinfo.Subtype_Indication (Parent (Result_Node)); Result_Node := Entity (Result_Node); pragma Assert (Ekind (Result_Node) in Private_Kind); Result_Node := Full_View (Result_Node); elsif Ekind (Result_Node) = E_Package and then Is_Hidden (Result_Node) and then Is_Rewrite_Substitution (R_Node (Reference_I)) then -- This is the case when we have a reference to the instantiation -- of generic parent in the instantiation of generic child, -- see F619-024 Result_Node := Entity (R_Node (Reference_I)); if Nkind (Parent (Result_Node)) = N_Defining_Program_Unit_Name then Result_Node := Parent (Result_Node); Result_Kind := A_Defining_Expanded_Name; end if; elsif Ekind (Result_Node) = E_Package and then Nkind (Parent (Result_Node)) = N_Package_Renaming_Declaration and then not Comes_From_Source (Parent (Result_Node)) then -- Reference_I is the reference to the name of the instantiation -- inside an expanded template, but the name of the template is -- the defining expanded name. In this case we have to use the -- entity of the rewritten node (F627-001) Result_Node := Entity (R_Node (Reference_I)); else -- It should be inherited! -- The last condition is needed to filter out already processed -- cases. This case corresponds to inherited user-defined -- subprograms Is_Inherited := True; if Ekind (Result_Node) = E_Function or else Ekind (Result_Node) = E_Procedure then Association_Type := Result_Node; -- Points to the defining identifier of implicit inherited -- subprogram Result_Node := Explicit_Parent_Subprogram (Result_Node); -- Now Result_Node points to the defining identifier of -- explicit subprogram which is inherited else -- ??? Probably will need revising when inherited record -- components and enumeration literals are fully -- implemented Association_Type := Defining_Identifier (Parent (Result_Node)); Association_Type := First_Subtype (Association_Type); end if; end if; end if; if Defined_In_Standard (Arg_Node) then -- Here we may need to adjust the result node in case if it is an -- entity representing an unconstrained base type for a signed -- integer type (see Cstand.Create_Unconstrained_Base_Type) if No (Parent (Result_Node)) and then Ekind (Result_Node) = E_Signed_Integer_Type then Result_Node := Parent (Scalar_Range (Result_Node)); end if; Result_Unit := Get_Comp_Unit (Standard_Id, Encl_Cont_Id (Reference_I)); else if Result_Kind in Internal_Defining_Operator_Kinds and then Is_Predefined (Result_Node) then null; -- -- note, that Predefined_Operation corresponds to an -- -- implicitly declared operation of a type, which is defined -- -- not in the Standard package -- Association_Type := Enclosed_Type (Result_Node); -- -- we have to use namely Association_Type, but not Result_Node -- -- to define Result_Unit, because sometimes Result_Node -- -- does not have the Parent field set -- Result_Unit := -- Enclosing_Unit (Encl_Cont_Id (Reference_I), Association_Type); return Nil_Element; -- ???!!! this turns off all the predefined operations -- !!!??? defined not in Standard elsif Is_Inherited then Result_Unit := Enclosing_Unit (Encl_Cont_Id (Reference_I), Association_Type); else Result_Unit := Enclosing_Unit (Encl_Cont_Id (Reference_I), Result_Node); end if; end if; if Is_Inherited and then (Ekind (Result_Node) = E_Component or else Ekind (Result_Node) = E_Discriminant) then Componnet_Name := Result_Node; end if; -- A special case of fake Numeric_Error renaming is handled -- separately (see B712-0050) if Result_Node = Standard_Constraint_Error and then Chars (Result_Node) /= Chars (Arg_Node) then Result := Get_Numeric_Error_Renaming; Set_Int_Kind (Result, A_Defining_Identifier); else Result := Node_To_Element_New (Node => Result_Node, Node_Field_1 => Association_Type, Node_Field_2 => Componnet_Name, Internal_Kind => Result_Kind, Spec_Case => Spec_Case, Inherited => Is_Inherited, In_Unit => Result_Unit); end if; -- See the comment in the body of A4G.A_Sem.Get_Corr_Called_Entity if Present (Association_Type) then if Is_From_Instance (Association_Type) then Set_From_Instance (Result, True); else Set_From_Instance (Result, False); end if; end if; if Spec_Case = From_Limited_View then Set_From_Implicit (Result, True); end if; return Result; end Identifier_Name_Definition; -------------------------------- -- Is_Explicit_Type_Component -- -------------------------------- function Is_Explicit_Type_Component (Comp_Def_Name : Node_Id; Type_Decl : Node_Id) return Boolean is Result : Boolean := False; Cont_Node : Node_Id; begin Cont_Node := Parent (Comp_Def_Name); while Present (Cont_Node) loop if Cont_Node = Type_Decl then Result := True; exit; end if; Cont_Node := Parent (Cont_Node); end loop; return Result; end Is_Explicit_Type_Component; ------------------------------ -- Is_From_Dispatching_Call -- ------------------------------ function Is_From_Dispatching_Call (Reference : Element) return Boolean is Can_Be_Dynamically_Identified : Boolean := False; Ref_Node : Node_Id; Parent_Ref_Node : Node_Id; Ref_Entity : Entity_Id; Parent_Call : Node_Id := Empty; Result : Boolean := False; begin Ref_Node := R_Node (Reference); if not (Nkind (Ref_Node) = N_Identifier or else Nkind (Ref_Node) = N_Operator_Symbol) then return False; end if; Parent_Ref_Node := Parent (Ref_Node); if Nkind (Parent_Ref_Node) = N_Expanded_Name and then Ref_Node = Selector_Name (Parent_Ref_Node) then Ref_Node := Parent (Ref_Node); Parent_Ref_Node := Parent (Ref_Node); end if; -- First, detect if Reference indeed can be dynamically identified, that -- is, it is either a subprogram name in a call or a formal parameter -- name in a parameter association. Because of the performance reasons, -- we do this on the tree structures, but not using ASIS queries case Nkind (Parent_Ref_Node) is when N_Parameter_Association => if Selector_Name (Parent_Ref_Node) = Ref_Node then Can_Be_Dynamically_Identified := True; end if; when N_Procedure_Call_Statement | N_Function_Call => if Sinfo.Name (Parent_Ref_Node) = Ref_Node then Can_Be_Dynamically_Identified := True; end if; when others => null; end case; if Can_Be_Dynamically_Identified then Ref_Entity := Entity (Ref_Node); if No (Ref_Entity) and then Nkind (Parent (Ref_Node)) = N_Expanded_Name and then Ref_Node = Selector_Name (Parent (Ref_Node)) then Ref_Node := Parent (Ref_Node); Ref_Entity := Entity (Ref_Node); end if; if Present (Ref_Entity) then case Ekind (Ref_Entity) is when Formal_Kind => Parent_Call := Parent (Parent (Ref_Node)); when Subprogram_Kind => Parent_Call := Parent (Ref_Node); when others => null; end case; end if; if Present (Parent_Call) and then (Nkind (Parent_Call) = N_Procedure_Call_Statement or else Nkind (Parent_Call) = N_Function_Call) and then Present (Controlling_Argument (Parent_Call)) then Result := True; end if; end if; return Result; end Is_From_Dispatching_Call; ---------------------------- -- Is_Implicit_Formal_Par -- ---------------------------- function Is_Implicit_Formal_Par (Result_El : Element) return Boolean is Result : Boolean := False; Res_Node : constant Node_Id := Node (Result_El); Parent_Node : Node_Id; begin if Nkind (Res_Node) in N_Entity and then Ekind (Res_Node) in Formal_Kind then Parent_Node := Parent (Res_Node); if Present (Parent_Node) and then Nkind (Parent_Node) = N_Parameter_Specification and then Res_Node /= Defining_Identifier (Parent_Node) then -- The condition is no more than just a clue... Result := True; end if; end if; return Result; end Is_Implicit_Formal_Par; ----------------------- -- Is_Limited_Withed -- ----------------------- function Is_Limited_Withed (E : Entity_Id; Reference : Asis.Element) return Boolean is Result : Boolean := False; CU_E : Asis.Compilation_Unit; CU_R : Asis.Compilation_Unit; begin CU_E := Enclosing_Unit (Encl_Cont_Id (Reference), E); if Unit_Kind (CU_E) = A_Package then CU_R := Enclosing_Compilation_Unit (Reference); if not Is_Equal (CU_R, CU_E) then declare CU_E_Name : constant Program_Text := To_Upper_Case (Unit_Full_Name (CU_E)); Comp_Clauses : constant Asis.Element_List := Context_Clause_Elements (CU_R); Name_List : Element_List_Access; begin for C in Comp_Clauses'Range loop if Trait_Kind (Comp_Clauses (C)) in A_Limited_Trait .. A_Limited_Private_Trait then Name_List := new Asis.Element_List'(Clause_Names (Comp_Clauses (C))); for N in Name_List'Range loop if To_Upper_Case (Full_Name_Image (Name_List (N))) = CU_E_Name then Free (Name_List); Result := True; exit; end if; end loop; Free (Name_List); end if; end loop; end; end if; end if; return Result; end Is_Limited_Withed; ----------------------------------- -- Is_Part_Of_Defining_Unit_Name -- ----------------------------------- function Is_Part_Of_Defining_Unit_Name (Name_Node : Node_Id) return Boolean is Result : Boolean := False; Next_Node : Node_Id := Parent (Name_Node); begin while Present (Next_Node) loop if Nkind (Next_Node) = N_Defining_Program_Unit_Name then Result := True; exit; elsif not (Nkind (Next_Node) = N_Expanded_Name or else Nkind (Next_Node) = N_Selected_Component) then -- theoretically, we need only the first part of the condition, -- but the unit name in the body is not fully decorated and, -- therefore, has the wrong syntax structure, so we need the -- second part. We are keeping both in order to have the correct -- code if it is changed in the tree. exit; else Next_Node := Parent (Next_Node); end if; end loop; return Result; end Is_Part_Of_Defining_Unit_Name; ------------------ -- Is_Reference -- ------------------ function Is_Reference (Name : Asis.Element; Ref : Asis.Element) return Boolean is Ref_Kind : constant Internal_Element_Kinds := Reference_Kind (Name); Result : Boolean := False; begin if Int_Kind (Ref) = Ref_Kind then begin if Is_Equal (Corresponding_Name_Definition (Ref), Name) then Result := True; end if; exception -- Corresponding_Name_Definition may raise Asis_Failed with -- Value_Error status when applied to identifiers which -- cannot have definitions (see section 17.6). Here we -- have to skip such Elements paying no attention to -- exception raising when others => null; end; end if; return Result; end Is_Reference; -------------------------- -- Is_Type_Discriminant -- -------------------------- function Is_Type_Discriminant (Discr_Node : Node_Id; Type_Node : Node_Id) return Boolean is Discr_Chars : constant Name_Id := Chars (Discr_Node); Discr_List : List_Id; Next_Discr_Spec : Node_Id; Result : Boolean := False; begin Discr_List := Discriminant_Specifications (Type_Node); if Present (Discr_List) then Next_Discr_Spec := First (Discr_List); while Present (Next_Discr_Spec) loop if Chars (Defining_Identifier (Next_Discr_Spec)) = Discr_Chars then Result := True; exit; end if; Next_Discr_Spec := Next (Next_Discr_Spec); end loop; end if; return Result; end Is_Type_Discriminant; ---------------- -- Needs_List -- ---------------- function Needs_List (Reference : Asis.Element) return Boolean is Result : Boolean := False; N : Node_Id := R_Node (Reference); Entity_N : Entity_Id; Pragma_Name_Id : Name_Id; begin if Nkind (Parent (N)) = N_Pragma_Argument_Association then Pragma_Name_Id := Pragma_Name (Parent (Parent (N))); if Pragma_Name_Id = Name_Asynchronous or else Pragma_Name_Id = Name_Convention or else Pragma_Name_Id = Name_Export or else Pragma_Name_Id = Name_Import or else Pragma_Name_Id = Name_Inline then Entity_N := Entity (N); if Present (Entity_N) and then Is_Overloadable (Entity_N) and then Has_Homonym (Entity_N) then -- ??? Is this the right condition??? -- ??? At the moment we do not consider any GNAT-specific -- pragma N := Homonym (Entity_N); if Present (N) and then (not (Sloc (N) <= Standard_Location -- !!! Note, that this check filters out the predefined -- implicitly declared operations!!! or else Part_Of_Pass_Generic_Actual (N) or else (Ekind (N) in Subprogram_Kind and then Is_Formal_Subprogram (N)))) then Result := True; end if; end if; end if; end if; return Result; end Needs_List; -------------------- -- Reference_Kind -- -------------------- function Reference_Kind (Name : Asis.Element) return Internal_Element_Kinds is Arg_Kind : Internal_Element_Kinds := Int_Kind (Name); Result : Internal_Element_Kinds := Not_An_Element; begin if Arg_Kind in Internal_Defining_Name_Kinds then if Arg_Kind = A_Defining_Expanded_Name then Arg_Kind := Int_Kind (Defining_Selector (Name)); end if; end if; case Arg_Kind is when A_Defining_Identifier => Result := An_Identifier; when A_Defining_Character_Literal => Result := A_Character_Literal; when A_Defining_Enumeration_Literal => Result := An_Enumeration_Literal; when A_Defining_And_Operator => Result := An_And_Operator; when A_Defining_Or_Operator => Result := An_Or_Operator; when A_Defining_Xor_Operator => Result := An_Xor_Operator; when A_Defining_Equal_Operator => Result := An_Equal_Operator; when A_Defining_Not_Equal_Operator => Result := A_Not_Equal_Operator; when A_Defining_Less_Than_Operator => Result := A_Less_Than_Operator; when A_Defining_Less_Than_Or_Equal_Operator => Result := A_Less_Than_Or_Equal_Operator; when A_Defining_Greater_Than_Operator => Result := A_Greater_Than_Operator; when A_Defining_Greater_Than_Or_Equal_Operator => Result := A_Greater_Than_Or_Equal_Operator; when A_Defining_Plus_Operator => Result := A_Plus_Operator; when A_Defining_Minus_Operator => Result := A_Minus_Operator; when A_Defining_Concatenate_Operator => Result := A_Concatenate_Operator; when A_Defining_Unary_Plus_Operator => Result := A_Unary_Plus_Operator; when A_Defining_Unary_Minus_Operator => Result := A_Unary_Minus_Operator; when A_Defining_Multiply_Operator => Result := A_Multiply_Operator; when A_Defining_Divide_Operator => Result := A_Divide_Operator; when A_Defining_Mod_Operator => Result := A_Mod_Operator; when A_Defining_Rem_Operator => Result := A_Rem_Operator; when A_Defining_Exponentiate_Operator => Result := An_Exponentiate_Operator; when A_Defining_Abs_Operator => Result := An_Abs_Operator; when A_Defining_Not_Operator => Result := A_Not_Operator; when others => null; end case; return Result; end Reference_Kind; ------------------------ -- Reset_To_Full_View -- ------------------------ function Reset_To_Full_View (Full_View : Node_Id; Discr : Node_Id) return Node_Id is Result : Node_Id; Discr_Chars : constant Name_Id := Chars (Discr); begin Result := First (Discriminant_Specifications (Full_View)); while Present (Result) loop exit when Chars (Defining_Identifier (Result)) = Discr_Chars; Result := Next (Result); end loop; pragma Assert (Present (Result)); Result := Defining_Identifier (Result); return Result; end Reset_To_Full_View; ------------------- -- Reset_To_Spec -- ------------------- function Reset_To_Spec (Name_Node : Node_Id) return Node_Id is Result : Node_Id := Empty; Next_Node : Node_Id := Parent (Name_Node); Name_Chars : constant Name_Id := Chars (Name_Node); begin while Nkind (Next_Node) /= N_Defining_Program_Unit_Name loop Next_Node := Parent (Next_Node); end loop; if Nkind (Parent (Next_Node)) in N_Subprogram_Specification then Next_Node := Parent (Next_Node); end if; Next_Node := Corresponding_Spec (Parent (Next_Node)); while Nkind (Next_Node) /= N_Defining_Program_Unit_Name loop Next_Node := Parent (Next_Node); end loop; Next_Node := Parent (Next_Node); Next_Node := Defining_Unit_Name (Next_Node); -- Now Next_Node should point to the defining program unit name in the -- spec: Next_Node := Sinfo.Name (Next_Node); while Present (Next_Node) loop if Nkind (Next_Node) = N_Expanded_Name then Next_Node := Selector_Name (Next_Node); end if; if Name_Chars = Chars (Next_Node) then Result := Next_Node; exit; end if; Next_Node := Parent (Next_Node); if Nkind (Next_Node) = N_Expanded_Name then Next_Node := Prefix (Next_Node); else exit; end if; end loop; pragma Assert (Present (Result)); return Result; end Reset_To_Spec; --------------------- -- Rewritten_Image -- --------------------- function Rewritten_Image (Selector_Name : Node_Id) return Node_Id is Name_Chars : constant Name_Id := Chars (Selector_Name); Aggr_Node : Node_Id; Result_Node : Node_Id := Empty; Association_Node : Node_Id; Choice_Node : Node_Id; begin -- may be, we have to be more smart for aggregates in aggregates... Aggr_Node := Parent (Selector_Name); -- we are in N_Component_Association node, and its Parent points not -- to the original, but to the rewritten structure for aggregate Aggr_Node := Parent (Aggr_Node); -- we are in the rewritten node for the aggregate pragma Assert ( (Nkind (Aggr_Node) = N_Aggregate or else Nkind (Aggr_Node) = N_Extension_Aggregate) and then Is_Rewrite_Substitution (Aggr_Node)); -- and now - traversing the rewritten structure Association_Node := First_Non_Pragma (Component_Associations (Aggr_Node)); Associations : while Present (Association_Node) loop Choice_Node := First_Non_Pragma (Choices (Association_Node)); -- in the rewritten aggregate it is exactly one choice in any -- component association if Chars (Choice_Node) = Name_Chars then Result_Node := Choice_Node; exit Associations; end if; Association_Node := Next_Non_Pragma (Association_Node); end loop Associations; pragma Assert (Present (Result_Node)); return Result_Node; end Rewritten_Image; ------------------------ -- Search_Record_Comp -- ------------------------ function Search_Record_Comp (Selector_Name : Node_Id) return Entity_Id is Result : Entity_Id := Empty; Res_Chars : constant Name_Id := Chars (Selector_Name); Aggr_Type : Entity_Id; begin Aggr_Type := Parent (Selector_Name); while not (Nkind (Aggr_Type) = N_Extension_Aggregate or else Nkind (Aggr_Type) = N_Aggregate or else No (Aggr_Type)) loop Aggr_Type := Parent (Aggr_Type); end loop; if No (Aggr_Type) then -- This definitely means that something went wrong... pragma Assert (False); return Empty; end if; Aggr_Type := Etype (Aggr_Type); while Ekind (Aggr_Type) /= E_Record_Type loop if Ekind (Aggr_Type) = E_Private_Type or else Ekind (Aggr_Type) = E_Limited_Private_Type or else Ekind (Aggr_Type) = E_Record_Type_With_Private then Aggr_Type := Full_View (Aggr_Type); else Aggr_Type := Etype (Aggr_Type); end if; end loop; Result := First_Entity (Aggr_Type); while Chars (Result) /= Res_Chars loop Result := Next_Entity (Result); end loop; pragma Assert (Present (Result)); return Result; end Search_Record_Comp; ------------------- -- To_Upper_Case -- ------------------- function To_Upper_Case (S : Wide_String) return Wide_String is Result : Wide_String (S'Range); begin for J in Result'Range loop Result (J) := Ada.Wide_Characters.Unicode.To_Upper_Case (S (J)); end loop; return Result; end To_Upper_Case; end A4G.Expr_Sem;