------------------------------------------------------------------------------
-- --
-- ASIS-for-GNAT IMPLEMENTATION COMPONENTS --
-- --
-- A 4 G . E X P R _ S E M --
-- --
-- B o d y --
-- --
-- Copyright (C) 1995-2017, 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 3, or (at your option) any later --
-- version. ASIS-for-GNAT is distributed in the hope that it will be --
-- useful, but WITHOUT ANY WARRANTY; without even the implied warranty of --
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- --
-- --
-- --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception distributed with GNAT; see --
-- the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- . --
-- --
-- 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). --
-- --
------------------------------------------------------------------------------
pragma Ada_2012;
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.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 A4G.Vcheck;
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;
loop
pragma Assert (Present (Association_Type));
exit when Nkind (Association_Type) = N_String_Literal;
-- Some character literals are rewritten into an unchecked
-- conversion of a string constant
if Nkind (Association_Type) = N_Unchecked_Type_Conversion then
Association_Type := Etype (Association_Type);
pragma Assert (Ekind (Association_Type) = E_Array_Subtype);
exit;
end if;
Association_Type := Parent (Association_Type);
end loop;
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_Needs_Charcode (Arg_Node) then
Special_Case := Stand_Char_Literal;
end if;
if not Char_Defined_In_Standard (Arg_Node) then
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_Impl_Neq : Boolean;
Is_Program_Unit_Pragma : Boolean := False;
Enclosing_Scope_Entity : Entity_Id;
Enclosing_List : List_Id;
Next_El : Asis.Element;
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
Is_Impl_Neq := False;
if Comes_From_Source (Next_Entity) then
Res_Node := Next_Entity;
Res_NF_1 := Empty;
Res_Inherited := False;
else
if Nkind (Next_Entity) = N_Defining_Operator_Symbol
and then
Chars (Next_Entity) = Name_Op_Ne
and then
Present (Corresponding_Equality (Next_Entity))
then
Res_Node := Next_Entity;
Res_NF_1 := Empty;
Res_Inherited := False;
Is_Impl_Neq := True;
else
Res_Node := 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;
end if;
Next_El := Node_To_Element_New (Node => Res_Node,
Node_Field_1 => Res_NF_1,
Inherited => Res_Inherited,
In_Unit => Result_Unit);
if Is_Impl_Neq then
Set_From_Implicit (Next_El, True);
Set_Special_Case (Next_El, Is_From_Imp_Neq_Declaration);
end if;
Asis_Element_Table.Append (Next_El);
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
Subprogram_Node := Scope (Res_Node);
-- This is a temporary solution for O219-033. The commented code below
-- should be removed when the solution is completed.
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;
-- Start of processing for 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.
-- Or it could be an Itype.
pragma Assert
(Is_Itype (Entity_Node) or else
(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);
if Arg_Kind = A_Selected_Component
and then
Nkind (Arg_Node) = N_Function_Call
and then
Nkind (R_Node (Expression)) = N_Expanded_Name
then
-- In some cases (in particular when this expanded name is a
-- parameter of an infix call to predefined "=") a reference to an
-- overloaded enumeration literal in the form of an expanded name is
-- transformed into a function call, and the right structure can be
-- found in the rewritten node only.
Arg_Node := R_Node (Expression);
end if;
-- 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
Arg_Node := R_Node (Expression);
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 : 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
if Nkind (Parent (Type_Scope)) = N_Defining_Program_Unit_Name then
Type_Scope := Parent (Type_Scope);
end if;
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
or else
(Nkind (Type_Entity) = N_Identifier
and then
Is_Rewrite_Substitution (Type_Entity)
and then
Nkind (Original_Node (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);
elsif Nkind (Type_Entity) /= N_Identifier then
Type_Entity := Entity (Sinfo.Subtype_Mark (Type_Entity));
end if;
-- We may have a discriminant reference in a discriminant constraint
-- applied to an access type:
if Nkind (Type_Entity) in N_Entity
and then
Ekind (Type_Entity) in
E_Access_Type | E_Access_Subtype | E_General_Access_Type
then
Type_Entity := Directly_Designated_Type (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 an incomplete/private type with unknown discriminant
-- part:
if Nkind (Parent (Type_Entity)) in
N_Private_Extension_Declaration |
N_Private_Type_Declaration |
N_Incomplete_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 := Label_Construct (Parent (Def_Id));
begin
if Nkind (Result_Node) /= N_Label then
pragma Assert
(Nkind (Result_Node) in N_Block_Statement | N_Loop_Statement);
-- Get the identifier of the block or loop. Original_Node is needed
-- in case this is a "for ... of" loop rewritten as a block.
Result_Node := Sinfo.Identifier (Original_Node (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 Comes_From_Source (N : Node_Id) return Boolean renames
Patched_Comes_From_Source;
-- Temporary solution for NA29-045. Differs from Atree.Comes_From_Source
-- in that it returns True for defining names of formal subprograms from
-- expanded instantiations that correspond to formal packages
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);
-- A call to a predefined operator with named notation gets turned into
-- an N_Op node, so we have to undo that here.
elsif No (Entity (Arg_Node)) and then
Nkind (Parent (Arg_Node)) = N_Expanded_Name and then
Arg_Node = Selector_Name (Parent (Arg_Node)) and then
Nkind (Original_Node (Parent (Arg_Node))) = N_Parameter_Association
then
Arg_Node := Parent (Arg_Node);
pragma Assert (Entity_Present (Arg_Node));
pragma Assert (Nkind (Parent (Arg_Node)) in N_Op);
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 Is_From_Universal_Expression (Arg_Node) then
return Nil_Element;
elsif Arg_Node_Kind = N_Parameter_Association and then
Arg_Node = Selector_Name (Original_Node (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 No (Result_Node) then
if No (Entity (Arg_Node)) then
if 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);
end if;
else
Result_Node := Entity (Arg_Node);
end if;
end if;
if Nkind (Result_Node) = N_Defining_Identifier
and then
Ekind (Result_Node) = E_Abstract_State
and then
Nkind (Parent (Result_Node)) = N_Identifier
then
A4G.Vcheck.Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.Corresponding_Name_Definition",
Wrong_Kind => An_Identifier);
-- This corresponds to the reference to abstract state in a
-- SPARK-2014-specific attribute. Consider:
--
-- package Refined_Depends_Legal
-- with Abstract_State => S_Null --(1)
-- is
-- procedure P1 (Par : in out Integer)
-- with Global => (Input => S_Null), -- (2)
-- Depends => (Par => + S_Null);
-- end Refined_Depends_Legal;
--
-- The aspect specification (1) actually works as the definition of
-- S_Null, so the entity field in the reference to S_Null in (2)
-- points to the N_Defining_Identifier created for (1). But this is
-- not a legal Ada, so we have to consider S_Null as a name that is
-- specific to SPARK 2014 and that does not have any definition as
-- an *Ada* name in an *Ada* program
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
-- ??? Needs more attention! Should we skip the artificial
-- declaration created in the expanded code as the means to pass the
-- actual parameter and jump to the declaration of the actual
-- parameter or should we return the defining name from this
-- artificial declaration???
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 statement names have another problem: we have to return
-- not the implicit label declaration, but the label or 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 Ekind (Result_Node) in Overloadable_Kind
and then
Present (Alias (Result_Node))
and then
Nkind (Original_Node (Parent (Result_Node))) in
N_Formal_Type_Declaration |
N_Full_Type_Declaration |
N_Incomplete_Type_Declaration |
N_Protected_Type_Declaration |
N_Private_Extension_Declaration
then
-- ???Is this the right test for implicit inherited user-defined
-- subprogram???
Is_Inherited := True;
Association_Type := Result_Node;
while Present (Alias (Result_Node))
and then
not Comes_From_Source (Result_Node)
loop
Result_Node := Alias (Result_Node);
end loop;
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
-- Predefined type operations are not supported...
return Nil_Element;
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;
elsif Is_Implicit_Null_Procedure
(Parent (Parent (Result_Node)))
then
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;
if Nkind (Result_Node) = N_Defining_Operator_Symbol
and then
Chars (Result_Node) = Name_Op_Eq
and then
Int_Kind (Result) = A_Defining_Not_Equal_Operator
then
Set_From_Implicit (Result, True);
Set_Special_Case (Result, Is_From_Imp_Neq_Declaration);
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;