File : asis-expressions.adb
------------------------------------------------------------------------------
-- --
-- ASIS-for-GNAT IMPLEMENTATION COMPONENTS --
-- --
-- A S I S . E X P R E S S I O N S --
-- --
-- B o d y --
-- --
-- Copyright (c) 1995-1999, Free Software Foundation, Inc. --
-- --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
-- Software Foundation; either version 2, or (at your option) any later --
-- version. ASIS-for-GNAT is distributed in the hope that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General --
-- Public License for more details. You should have received a copy of the --
-- GNU General Public License distributed with ASIS-for-GNAT; see file --
-- COPYING. If not, write to the Free Software Foundation, 59 Temple Place --
-- - Suite 330, Boston, MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- 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 Ada Core Technologies Inc --
-- (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Asis.Exceptions; use Asis.Exceptions;
with Asis.Elements; use Asis.Elements;
with Asis.Extensions; use Asis.Extensions;
with Asis.Set_Get;
use Asis.Set_Get;
with A4G.Expr_Sem; use A4G.Expr_Sem;
with A4G.A_Output; use A4G.A_Output;
with A4G.A_Sem; use A4G.A_Sem;
with A4G.A_Debug; use A4G.A_Debug;
with A4G.Int_Knds; use A4G.Int_Knds;
with A4G.Mapping; use A4G.Mapping;
with A4G.Vcheck; use A4G.Vcheck;
with A4G.C_U_Info; use A4G.C_U_Info;
with A4G.Norm; use A4G.Norm;
with A4G.A_Sinput; use A4G.A_Sinput;
with Types; use Types;
with Sinfo; use Sinfo;
with Einfo; use Einfo;
with Nlists; use Nlists;
with Atree; use Atree;
with Snames; use Snames;
with Uintp; use Uintp;
with Output; use Output;
package body Asis.Expressions is
LT : String renames ASIS_Line_Terminator;
------------------------------------------------------------------------------
-- GENERAL DOCUMENTATION ITEMS --
------------------------------------------------------------------------------
-----------------------------
-- A_Function_Call Problem --
-----------------------------
-- As for now, the following consideration can be applied to explicit
-- elements only!!!
-- The following situations should be distinguished:
--
-- - the called function is a predefined operation (it can also be its
-- renaming);
-- - the called function is a user-defined function, but it has an operation
-- symbol as its designator;
-- - the called function is a "usial" user-defined function;
-- - the called function is an attribute;
--
-- - the call is prefix;
-- - the call is infix;
--
-- As a result, in an AST we can have the following situations;
--
-- - prefix call to a predefined operator:
--
-- Node is rewritten, the Original Node is of N_Function_Call kind
-- and its Name field points to the node of N_Operator_Symbol kind,
-- or of N_Expanded_Name kind, but anyway
-- the rewritten node is of N_Op_Xxxx kind and Original Node
-- contains the corresponding substructuers only for naming
-- associations (if any). The rewritten node contains both parameters,
-- but in the form of positional association.
--
-- Compiler-time optimization for static expresions: the rewritten
-- node may be of N_Identifier kind (when oprimizing calls to
-- boolean functions), N_Integer/Real_Literal king, when optimizing
-- function returning numeric results,
--
-- - infix call to a predefined operator:
--
-- Usially the node is unchanged, it is of N_Op_Xxx kind.
-- But the node may be rewritten into N_Integer_Literal or
-- N_Real_Literl, if the compiler optimizes an expression like
-- 1 + 2! It also may be rewritten into N_Identifier node,
-- if the compiler optimizes an expression like "not True"
-- or "False and True". Finaly, it may be rewritten into
-- N_String_Literal, if the compiler optimizes an expression like
-- "The " & "Beatles"
--
--
-- - prefix call to a user-defined operator:
--
-- node is unchanged, it is of N_Function_Call kind, but its Name
-- field points to the node of N_Operator_Symbol kind, if the prefix
-- consists on the operator symbol only, or to the node of N_Expanded_Name
-- kind.
--
-- - infix call to a user-defined operator:
--
-- node is unchanged, it is of N_Function_Call kind, but its Name
-- field points to the node of N_Identifier kind.
--
-- !! THIS MEANS THAT AN ELEMENT OF An_Operator_Symbol KIND MAY BE
-- BASED ON THE NODE OF N_Identifier kind!!!
--
-- - prefix call to a "usial" user-defined function:
--
-- node is unchanged, it is of N_Function_Call kind, its Name
-- field points to the node of N_Identifier or N_Expanded_Name kind
-- (as it should).
--
-- - call to an attribute-function (only the prefix form is possible)
--
-- node may or may nor be rewritten, but the Node field of the
-- corresponding element definitely is of N_Attribute_Reference
-- kind, and its Expressions field should be used for obtaining the
-- list of the function call parameters.
--
-- This is important for the functions:
--
-- Prefix
-- Is_Prefix_Call
-- Corresponding_Called_Function (?)
-- Function_Call_Parameters
--
-- having A_Function_Call as their appropriate kind, and also for
-- Name_Image (in the case of getting the image of an operator symbol)
--
-- THE MAPPING.2 DOCUMENT ALSO REQUIRES CORRECTIONS!!!
------------------------------------------------------------------------------
function Corresponding_Expression_Type (Expression : in Asis.Expression)
return Asis.Declaration
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Expression);
begin
-- this is the result of the first attempt to implement this function
-- the code is rather dirty, non-effective and not well-organized
Check_Validity (Expression,
"Asis.Expressions.Corresponding_Expression_Type");
if Arg_Kind not in Internal_Expression_Kinds then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.Corresponding_Expression_Type ");
end if;
-- first, we filter out cases for which Nil_Element should be
-- returned (may be, the check below is too trivial???)
if not Is_True_Expression (Expression) then
return Nil_Element;
end if;
-- we incapsulate the real processing in the function
-- A4G.Expr_Sem.Expr_Type:
return Expr_Type (Expression);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Expression,
Outer_Call => "Asis.Expressions.Corresponding_Expression_Type");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Expression,
Diagnosis => "Asis.Expressions.Corresponding_Expression_Type");
end Corresponding_Expression_Type;
-----------------------------------------------------------------------------
function Value_Image (Expression : in Asis.Expression) return Wide_String
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Expression);
Arg_Node : Node_Id;
Image_Start : Source_Ptr;
Image_End : Source_Ptr;
begin
Check_Validity (Expression, "Asis.Expressions.Value_Image");
if not (Arg_Kind = An_Integer_Literal or else
Arg_Kind = A_Real_Literal or else
Arg_Kind = A_String_Literal)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.Value_Image");
end if;
Arg_Node := Node (Expression);
if Is_Stat_Expr (Expression) then
-- when ASIS processes Expression representing the result of
-- compile-time computation of a static expression, we should not
-- get any information from the Source Buffer
--
-- probably, we'll have to get rid of working with the source
-- buffer at all!
case Arg_Kind is
when An_Integer_Literal =>
UI_Image (Intval (Arg_Node));
return To_Wide_String (UI_Image_Buffer (1 .. UI_Image_Length));
when A_Real_Literal =>
return To_Wide_String (Ureal_Image (Arg_Node));
when others =>
raise ASIS_Failed;
end case;
else
case Arg_Kind is
when An_Integer_Literal
| A_Real_Literal =>
Image_Start := Sloc (Arg_Node);
Image_End := Get_Num_Literal_End (P => Image_Start);
return To_Wide_String (Get_Word (Image_Start, Image_End));
when A_String_Literal =>
return To_Wide_String (String_Image (Arg_Node));
when others =>
raise ASIS_Failed;
-- this choice can never been reached,
-- see the condition for defining the appropriate argument
end case;
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Expression,
Outer_Call => "Asis.Expressions.Value_Image");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Expression,
Diagnosis => "Asis.Expressions.Value_Image");
end Value_Image;
-----------------------------------------------------------------------------
function Name_Image (Expression : in Asis.Expression) return Wide_String
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Expression);
Arg_Node : Node_Id;
Image_Start : Source_Ptr;
Image_End : Source_Ptr;
begin
Check_Validity (Expression, "Asis_Declarations.Name_Image");
if not (Arg_Kind = An_Identifier or else
Arg_Kind in Internal_Operator_Symbol_Kinds or else
Arg_Kind = A_Character_Literal or else
Arg_Kind = An_Enumeration_Literal)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.Name_Image");
end if;
Arg_Node := Get_Actual_Type_Name (Node (Expression));
case Arg_Kind is
when A_Character_Literal =>
return To_Wide_String (
''' & Get_Character (Sloc (Arg_Node) + 1) & ''');
--
-- Sloc (Defining_Arg_Node) points to the leading tick of
-- the literal
when Internal_Operator_Symbol_Kinds =>
-- three alternatives can be possible:
--
-- the Element is based on N_Op_Xxx node
-- -> an infix call of a predefined operator
--
-- the Element is based on N_Operator_Symbol node
-- -> definitely a prefix call
--
-- the Element is based on N_Identifier node
-- -> an infix call of a user-defined operator
--
-- But in any case the result should be enclosed in quoters
if Nkind (Arg_Node) = N_Operator_Symbol then
return To_Wide_String (String_Image (Arg_Node));
else
-- N_Identifier and N_Op_Xxx nodes are processed
-- in the same way
return To_Wide_String (Operator_Image (Arg_Node));
end if;
when others
-- really only An_Identifier | An_Enumeration_Literal
-- are possible,
-- see the condition for defining the appropriate
-- argument
=>
if Sloc (Arg_Node) <= Standard_Location then
return To_Wide_String (Normalized_Namet_String (Arg_Node));
else
Image_Start := Sloc (Arg_Node);
-- special processing is needed for some cases:
if Get_Character (Image_Start) = ''' then
-- special processing for an "ordinary" attribute
-- designator
Image_Start := Next_Identifier (Image_Start);
elsif Nkind (Arg_Node) = N_Attribute_Definition_Clause then
-- special processing for an attribute designator being
-- a child element of a pseudo attribute referense from
-- an attribute definition clause
Image_Start := Search_Rightmost_Symbol (Image_Start, ''');
Image_Start := Next_Identifier (Image_Start);
end if;
Image_End := Get_Word_End (P => Image_Start,
In_Word => In_Identifier'Access);
return To_Wide_String (Get_Word (Image_Start, Image_End));
end if;
end case;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Expression,
Outer_Call => "Asis.Expressions.Name_Image");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Expression,
Diagnosis => "Asis.Expressions.Name_Image");
end Name_Image;
------------------------------------------------------------------------------
-- OPEN PROBLEMS:
--
-- 1. A_Defining_Expanded_Name: is the recursive construction of the result
-- of the String type a really good thing here? The performance can be poor
-- but, from the other hand, this can happen not very often.
--
-- 2. The Asis_Declarations.Defining_Name_Image function contains the
-- (almost) exact
-- copy of the part of the code of this function (except the part for
-- processing A_Defining_Expanded_Name). May be, it should be better
-- to separate it on low-level function.
-------------------------------------------------------------------------------
-- NOT IMPLEMENTED
function References (Name : in Asis.Element;
Within_Element : in Asis.Element;
Implicitly : in Boolean := False)
return Asis.Name_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Name);
Arg_Node : Node_Id;
begin
Check_Validity (Name,
"Asis.Expressions.References");
if not (Arg_Kind in Internal_Defining_Name_Kinds) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.References");
end if;
Arg_Node := Node (Name);
Not_Implemented_Yet (Diagnosis =>
"Asis.Expressions.References");
-- ASIS_Failed is raised, Not_Implemented_Error status is setted
return Nil_Element_List; -- to make the code syntactically correct
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Name,
Bool_Par => Implicitly,
Outer_Call => "Asis.Expressions.References");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Name,
Bool_Par => Implicitly,
Diagnosis => "Asis.Expressions.References");
end References;
------------------------------------------------------------------------------
-- NOT IMPLEMENTED
function Is_Referenced (Name : in Asis.Element;
Within_Element : in Asis.Element;
Implicitly : in Boolean := False)
return Boolean
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Name);
Arg_Node : Node_Id;
begin
Check_Validity (Name, "Asis.Expressions.Is_Referenced");
if not (Arg_Kind in Internal_Defining_Name_Kinds) then
return False;
else
Arg_Node := Node (Name);
Not_Implemented_Yet (Diagnosis =>
"Asis.Expressions.Is_Referenced");
-- ASIS_Failed is raised, Not_Implemented_Error status is set
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Name,
Bool_Par => Implicitly,
Outer_Call => "Asis.Expressions.Is_Referenced");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Name,
Bool_Par => Implicitly,
Diagnosis => "Asis.Expressions.Is_Referenced");
end Is_Referenced;
-------------------------------------------------------------------------------
function Corresponding_Name_Definition (Reference : in Asis.Expression)
return Asis.Defining_Name
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Reference);
Arg_Node : Node_Id;
begin
-- This is the first attempt to implement this function:
-- we are analysing each argument kind separately and then we are
-- trying some solutions....
--
-- Aggregating these solutions will be the next step...
Check_Validity (Reference,
"Asis.Expressions.Corresponding_Name_Definition");
if not (Arg_Kind = An_Identifier or else
Arg_Kind in Internal_Operator_Symbol_Kinds or else
Arg_Kind = A_Character_Literal or else
Arg_Kind = An_Enumeration_Literal)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.Corresponding_Name_Definition");
end if;
-- argument checks specific to the given query:
Arg_Node := Node (Reference);
-- first, the situation when "passed a portion of a pragma that
-- was "ignored" by the compiler", it relates to pragma arguments
-- only, but not to pragma element identifiers:
-- GNAT rewrites the tree structure for non-recognized pargma as
-- if it is a null statement, so:
if Nkind (Parent (Parent (Arg_Node))) = N_Null_Statement then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.Corresponding_Name_Definition");
end if;
-- then check for the situation when if passed a portion of a
-- pragma that is an ambiguous reference to more than one entity.
if Nkind (Parent (Arg_Node)) = N_Pragma_Argument_Association and then
Is_Overloaded (Arg_Node)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.Corresponding_Name_Definition");
-- ??? is the use of Is_Overloaded field safe here? See the
-- ??? related pieces of the documentation in Sinfo (spec)
end if;
if Arg_Kind = An_Identifier then
-- There are three checks specific to arguments of An_Identifier
-- kind only: a pragma_argument_identifier, an identifier specific
-- to a pragma and a reference to an attribute_designator:
if Nkind (Arg_Node) = N_Pragma_Argument_Association
-- a reference to a pragma_argument_identifier
or else
(Nkind (Parent (Arg_Node)) = N_Pragma_Argument_Association
and then No (Entity (Arg_Node)))
-- an identifier specific to a pragma, we make a guess that
-- any identifier on the place of a pragma argument is
-- specific to the pragma, if the Entity field is not set
-- for this identifier. Is it really true???
or else
Nkind (Arg_Node) = N_Attribute_Reference
-- a reference to an attribute_designator
or else
Nkind (Arg_Node) = N_Attribute_Definition_Clause
-- attribute designator from an attribute definiton clause
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.Corresponding_Name_Definition");
end if;
end if;
if Arg_Kind = An_Identifier or else
Arg_Kind = An_Enumeration_Literal or else
Arg_Kind in Internal_Operator_Symbol_Kinds
then
return Identifier_Name_Definition (Reference);
-- elsif Arg_Kind in Internal_Operator_Symbol_Kinds then
-- return Operator_Symbol_Name_Definition (Reference);
else
-- Arg_Kind = A_Character_Literal here
return Character_Literal_Name_Definition (Reference);
-- else
-- -- Arg_Kind = An_Enumeration_Literal here
-- return Enumeration_Literal_Name_Definition (Reference);
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Reference,
Outer_Call => "Asis.Expressions.Corresponding_Name_Definition");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Reference,
Diagnosis => "Asis.Expressions.Corresponding_Name_Definition");
end Corresponding_Name_Definition;
------------------------------------------------------------------------------
-- NOT IMPLEMENTED
function Corresponding_Name_Definition_List (Reference : in Asis.Element)
return Asis.Defining_Name_List
is
-- Arg_Kind : Internal_Element_Kinds := Int_Kind (Reference);
Arg_Node : Node_Id;
begin
Check_Validity (Reference, "Asis.Expressions.Name_Definition_List");
Arg_Node := Node (Reference);
Not_Implemented_Yet (Diagnosis =>
"Asis.Expressions.Name_Definition_List");
-- ASIS_Failed is raised, Not_Implemented_Error status is setted
return Nil_Element_List; -- to make the code syntactically correct
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Reference,
Outer_Call => "Asis.Expressions.Name_Definition_List");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Reference,
Diagnosis => "Asis.Expressions.Name_Definition_List");
end Corresponding_Name_Definition_List;
------------------------------------------------------------------------------
function Corresponding_Name_Declaration (Reference : in Asis.Expression)
return Asis.Declaration
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Reference);
Result : Asis.Element;
begin
Check_Validity (Reference,
"Asis.Expressions.Corresponding_Name_Declaration");
if not (Arg_Kind = An_Identifier or else
Arg_Kind in Internal_Operator_Symbol_Kinds or else
Arg_Kind = A_Character_Literal or else
Arg_Kind = An_Enumeration_Literal)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis =>
"Asis.Expressions.Corresponding_Name_Declaration");
end if;
Result := Corresponding_Name_Definition (Reference);
if not Is_Nil (Result) then
Result := Enclosing_Element (Result);
end if;
return Result;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Reference,
Outer_Call => "Asis.Expressions.Corresponding_Name_Declaration");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Reference,
Diagnosis => "Asis.Expressions.Corresponding_Name_Declaration");
end Corresponding_Name_Declaration;
-----------------------------------------------------------------------------
function Prefix
(Expression : in Asis.Expression)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Expression);
Arg_Node : Node_Id;
Returned_Kind : Internal_Expression_Kinds;
Result_Node : Node_Id;
begin
-- ???
-- the code is really awful!!! too many return statements!!!
Check_Validity (Expression, "Asis.Expressions.Prefix");
if not (Arg_Kind = An_Explicit_Dereference or else
Arg_Kind in Internal_Attribute_Reference_Kinds or else
Arg_Kind = A_Function_Call or else
Arg_Kind = An_Indexed_Component or else
Arg_Kind = A_Selected_Component or else
Arg_Kind = A_Slice)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.Prefix");
end if;
-- tree traversing and forming the result:
Arg_Node := Node (Expression);
if Nkind (Arg_Node) = N_Identifier and then
-- Special case: F.A, where F is a function call
Nkind (R_Node (Expression)) = N_Function_Call
then
Arg_Node := R_Node (Expression);
end if;
-- We might implement this as shown below (the name following
-- the arrow (->) is the name of the Sinfo-defined tree access
-- function which should be used to obtain the result node,
-- the infix form of A_Function_Call should be treated as a special
-- case:
-- case Arg_Kind is
--
-- when An_Explicit_Dereference =>
-- -- N_Explicit_Dereference -> Prefix
--
-- when Internal_Attribute_Reference_Kinds =>
-- -- N_Attribute_Reference -> Prefix
--
-- when A_Function_Call =>
-- -- N_Function_Call -- prefix call -> Name
-- -- N_Op_* -- infix call -> the result should be based
-- -- on the same node
-- -- N_Attribute_Reference -> the result should be based
-- on the same node
--
-- when An_Indexed_Component =>
-- -- N_Indexed_Component -> Prefix
--
-- when A_Selected_Component =>
-- -- N_Selected_Component -> Prefix
-- -- N_Expanded_Name -> Prefix
--
-- when A_Slice =>
-- -- N_Slice -> Prefix
--
-- when others =>
--
-- return Nil_Element; -- to make the code formally correct,
-- -- see the condition for determining the
-- end case; -- appropriate element
-- but it is more convenient to use the Node_Kind-driven
-- case statement for implementing just the same processing:
Result_Node := Arg_Node;
-- for N_Op_* cases only; it may seem as being a bit tricky, but another
-- variants are too long ;-)
if Debug_Flag_1 then
Write_Node (Arg_Node, "Prefix: Arg_Node -> ");
Write_Eol;
end if;
case Nkind (Arg_Node) is
when N_Explicit_Dereference -- Prefix node access funtion
| N_Slice -- should be used for tree traversing
| N_Indexed_Component -- traversing
| N_Selected_Component
| N_Expanded_Name =>
-- !!The Node of N_Identifier kind cannot be processed by the
-- !!general Node_To_Element function (involving the auto
-- !!determination of the Element kind), because the subcomponents
-- !!of the prefix of a defining_unit_name do not have the Entity
-- !!attribute set.
Result_Node := Prefix (Arg_Node);
if Nkind (Result_Node) = N_Identifier and then
not Is_Rewrite_Substitution (Result_Node)
then
return Node_To_Element_New (
Node => Result_Node,
Starting_Element => Expression,
Internal_Kind => An_Identifier,
Considering_Parent_Count => False);
else
return Node_To_Element_New (
Node => Result_Node,
Starting_Element => Expression,
Considering_Parent_Count => False);
end if;
when N_Attribute_Definition_Clause =>
-- special processing for pseude-attribute being the child
-- element of An_Attribute_Definition_Clause Element
Result_Node := Sinfo.Name (Arg_Node);
return Node_To_Element_New
(Starting_Element => Expression,
Node => Result_Node);
when N_Attribute_Reference =>
-- two cases should be distinguished: when the function argument is
-- of A_Function_Call kind and when it is in
-- Internal_Attribute_Reference_Kinds
if Debug_Flag_1 then
Write_Str
("Asis.Expressions.Prefix: "
& "processing N_Attribute_Reference Node...");
Write_Eol;
Write_Node (Arg_Node, "Arg Node -> ");
Write_Eol;
end if;
if Arg_Kind = A_Function_Call then
-- the result should be based on the same node, so the
-- Result_Node setting should not be changed, but the kind
-- of the result should be deternined by hand
Returned_Kind := Subprogram_Attribute_Kind (Result_Node);
return Node_To_Element_New (
Node => R_Node (Expression),
Starting_Element => Expression,
Internal_Kind => Returned_Kind,
Considering_Parent_Count => False);
else
-- just the same processing as for the previous
-- case alternative:
Result_Node := Prefix (Arg_Node);
if Debug_Flag_1 then
Write_Str ("Asis.Expressions.Prefix: "
& "processing N_Attribute_Reference Prefix Node...");
Write_Eol;
Write_Node (Result_Node, "Result Node -> ");
Write_Eol;
end if;
if Nkind (Result_Node) = N_Identifier and then
not Is_Rewrite_Substitution (Result_Node)
then
return Node_To_Element_New (
Node => Result_Node,
Starting_Element => Expression,
Internal_Kind => An_Identifier,
Considering_Parent_Count => False);
else
return Node_To_Element_New (
Node => Result_Node,
Starting_Element => Expression,
Considering_Parent_Count => False);
end if;
end if;
when N_Function_Call =>
-- Name node access funtion should be used for tree traversing
if Debug_Flag_1 then
Write_Str ("Prefix: processing N_Function_Call Node:");
Write_Eol;
Write_Str ("Node is rewritten more then once - ");
Write_Eol;
Write_Str (Boolean'Image (Is_Rewrite_Substitution (Arg_Node)));
Write_Eol;
end if;
-- See comments under "A_Function_Call Problem" headline in the
-- beginning of the package body - we shall distinguish the case
-- of the infix call of the user - defined operator. The Name
-- function gives the result of N_Identifier kind, but really it
-- corresponds to the An_Operator_Symbol Element!
Result_Node := Sinfo.Name (Arg_Node);
if Debug_Flag_1 then
Write_Node (Result_Node, "Prefix: Result_Node -> ");
Write_Eol;
end if;
if Nkind (Result_Node) = N_Identifier and then
Chars (Result_Node) in Any_Operator_Name
then
-- really we have a infix call of a user-defined operator!
Returned_Kind :=
A4G.Mapping.N_Operator_Symbol_Mapping (Result_Node);
else
return Node_To_Element_New (
Node => Result_Node,
Starting_Element => Expression,
Considering_Parent_Count => False);
end if;
-- when N_Op_* => -- N_Op_* cases corresponding to the infix function
-- call, the result should be based on the same node;
-- only the internal kind of the returned element is
-- determined in the case statement; the return
-- statement for N_Op_* alternatives is located
-- outsite the case statement
when N_Op_And => -- "and"
Returned_Kind := An_And_Operator;
when N_Op_Or => -- "or"
Returned_Kind := An_Or_Operator;
when N_Op_Xor => -- "xor"
Returned_Kind := An_Xor_Operator;
when N_Op_Eq => -- "="
Returned_Kind := An_Equal_Operator;
when N_Op_Ne => -- "/="
Returned_Kind := A_Not_Equal_Operator;
when N_Op_Lt => -- "<"
Returned_Kind := A_Less_Than_Operator;
when N_Op_Le => -- "<="
Returned_Kind := A_Less_Than_Or_Equal_Operator;
when N_Op_Gt => -- ">"
Returned_Kind := A_Greater_Than_Operator;
when N_Op_Ge => -- ">="
Returned_Kind := A_Greater_Than_Or_Equal_Operator;
when N_Op_Add => -- "+" (binary)
Returned_Kind := A_Plus_Operator;
when N_Op_Subtract => -- "-" (binary)
Returned_Kind := A_Minus_Operator;
when N_Op_Concat => -- "&"
Returned_Kind := A_Concatenate_Operator;
when N_Op_Plus => -- "+" (unary)
Returned_Kind := A_Unary_Plus_Operator;
when N_Op_Minus => -- "-" (unary)
Returned_Kind := A_Unary_Minus_Operator;
when N_Op_Multiply => -- "*"
Returned_Kind := A_Multiply_Operator;
when N_Op_Divide => -- "/"
Returned_Kind := A_Divide_Operator;
when N_Op_Mod => -- "mod"
Returned_Kind := A_Mod_Operator;
when N_Op_Rem => -- "rem"
Returned_Kind := A_Rem_Operator;
when N_Op_Expon => -- "**"
Returned_Kind := An_Exponentiate_Operator;
when N_Op_Abs => -- "abs"
Returned_Kind := An_Abs_Operator;
when N_Op_Not => -- "not"
Returned_Kind := A_Not_Operator;
when others =>
-- to make the code formally correct, nothing else could be possible
return Nil_Element;
end case;
-- forming the result for N_Op_* cases and for the infix call of a
-- user-defined operator:
-- ??? !!! This is the ad hoc patch for Enclosing_Element needs:
-- we should keep rewritten node for function calls rewritten as
-- results of compiler-time optimisations
if Returned_Kind in Internal_Operator_Symbol_Kinds then
Result_Node := R_Node (Expression);
end if;
return Node_To_Element_New (
Node => Result_Node,
Starting_Element => Expression,
Internal_Kind => Returned_Kind,
Considering_Parent_Count => False);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Expression,
Outer_Call => "Asis.Expressions.Prefix");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Expression,
Diagnosis => "Asis.Expressions.Prefix");
end Prefix;
------------------------------------------------------------------------------
function Index_Expressions (Expression : in Asis.Expression)
return Asis.Expression_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Expression);
Arg_Node : Node_Id;
begin
Check_Validity (Expression, "Asis.Expressions.Index_Expressions");
if not (Arg_Kind = An_Indexed_Component) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.Index_Expressions");
end if;
Arg_Node := Node (Expression);
return Node_To_Element_List (
List => Sinfo.Expressions (Arg_Node),
In_Unit => Encl_Unit (Expression));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Expression,
Outer_Call => "Asis.Expressions.Index_Expressions");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Expression,
Diagnosis => "Asis.Expressions.Index_Expressions");
end Index_Expressions;
-----------------------------------------------------------------------------
function Slice_Range (Expression : in Asis.Expression)
return Asis.Discrete_Range
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Expression);
Arg_Node : Node_Id;
begin
Check_Validity (Expression, "Asis.Expressions.Slice_Range");
if not (Arg_Kind = A_Slice) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.Slice_Range");
end if;
Arg_Node := Node (Expression);
return Node_To_Element (Node => Sinfo.Discrete_Range (Arg_Node),
In_Unit => Encl_Unit (Expression));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Expression,
Outer_Call => "Asis.Expressions.Slice_Range");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Expression,
Diagnosis => "Asis.Expressions.Slice_Range");
end Slice_Range;
-----------------------------------------------------------------------------
-----------------------------------------------
-- local functions for the Selector function --
-----------------------------------------------
function Last_Selector (Node : Node_Id) return Boolean;
-- Node should be of N_Identifier kind, obtained as a Selector_Name
-- form N_Selected_Component or N_Expanded name node;
-- a caller is responsible for this. This function checks if
-- Node is the last selector in the corresponding selected component
-- or expanded name
function Is_Enumeration_Literal (Node : Node_Id) return Boolean;
-- Node should be of N_Identifier kind, obtained as a Selector_Name
-- form N_Selected_Component or N_Expanded name node;
-- moreover, this is the last selector in the enclosing construct
-- a caller is responsible for this. This function checks if
-- its argument should be classified as An_Enumeration_Literal
-- by checking the Entity fiels of the outermost "enclosing"
-- node of N_Expanded_Name kind
function Last_Selector (Node : Node_Id) return Boolean is
begin
return not ((Nkind (Parent (Node)) = N_Expanded_Name or else
Nkind (Parent (Node)) = N_Selected_Component)
and then
(Nkind (Parent (Parent (Node))) = N_Expanded_Name or else
Nkind (Parent (Parent (Node))) = N_Selected_Component));
end Last_Selector;
function Is_Enumeration_Literal (Node : Node_Id) return Boolean is
Entity_Node : Node_Id := Empty;
begin
Entity_Node := Entity (Node);
if No (Entity_Node) then
Entity_Node := Parent (Node);
if Nkind (Entity_Node) = N_Function_Call then
-- this may be the case for an expanded name which is a reference
-- to an overloaded enumeration literal
Entity_Node := Sinfo.Name (Entity_Node);
end if;
if Nkind (Entity_Node) in N_Has_Entity then
Entity_Node := Entity (Entity_Node);
end if;
end if;
if Nkind (Entity_Node) in N_Entity and then
Ekind (Entity_Node) = E_Enumeration_Literal
then
return True;
else
return False;
end if;
end Is_Enumeration_Literal;
function Selector (Expression : in Asis.Expression)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Expression);
Arg_Node : Node_Id;
Result_Node : Node_Id;
Result_Kind : Internal_Element_Kinds;
begin
Check_Validity (Expression, "Asis.Expressions.Selector");
if not (Arg_Kind = A_Selected_Component) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.Selector");
end if;
Arg_Node := Node (Expression);
Result_Node := Selector_Name (Arg_Node);
if not (Nkind (Result_Node) = N_Identifier) then
return Node_To_Element_New (Node => Result_Node,
Starting_Element => Expression);
end if;
if Last_Selector (Result_Node) and then
Is_Enumeration_Literal (Result_Node)
then
Result_Kind := An_Enumeration_Literal;
else
Result_Kind := An_Identifier;
end if;
return Node_To_Element_New (Node => Result_Node,
Internal_Kind => Result_Kind,
Starting_Element => Expression);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Expression,
Outer_Call => "Asis.Expressions.Selector");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Expression,
Diagnosis => "Asis.Expressions.Selector");
end Selector;
-----------------------------------------------------------------------------
function Attribute_Designator_Identifier
(Expression : in Asis.Expression)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Expression);
begin
Check_Validity (Expression,
"Asis.Expressions.Attribute_Designator_Identifier");
if not (Arg_Kind in Internal_Attribute_Reference_Kinds) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.Attribute_Designator_Identifier");
end if;
-- Attribute designator is based on the same node as the argument of
-- the function, this is a special case of identifier handling!!!
return Node_To_Element_New
(Starting_Element => Expression,
Node => R_Node (Expression),
Internal_Kind => An_Identifier);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Expression,
Outer_Call => "Asis.Expressions.Attribute_Designator_Identifier");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Expression,
Diagnosis => "Asis.Expressions.Attribute_Designator_Identifier");
end Attribute_Designator_Identifier;
-----------------------------------------------------------------------------
function Attribute_Designator_Expressions (Expression : in Asis.Expression)
return Asis.Expression_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Expression);
Arg_Node : Node_Id;
begin
Check_Validity (Expression,
"Asis.Expressions.Attribute_Designator_Expressions");
if not (Arg_Kind = A_First_Attribute or else
Arg_Kind = A_Last_Attribute or else
Arg_Kind = A_Length_Attribute or else
Arg_Kind = A_Range_Attribute or else
Arg_Kind = An_Implementation_Defined_Attribute or else
Arg_Kind = An_Unknown_Attribute)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis =>
"Asis.Expressions.Attribute_Designator_Expressions");
end if;
Arg_Node := Node (Expression);
if Nkind (Arg_Node) = N_Attribute_Definition_Clause then
return Nil_Element_List;
-- just in case - for an implmentation-defined attribute in an
-- attribute definition clause
end if;
if Debug_Flag_1 then
Write_Str ("Attribute_Designator_Expressions: Arg_Node:");
Write_Eol;
Write_Node (Arg_Node, "->");
Write_Eol;
end if;
return Node_To_Element_List (
List => Sinfo.Expressions (Arg_Node),
In_Unit => Encl_Unit (Expression));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Expression,
Outer_Call => "Asis.Expressions.Attribute_Designator_Expressions");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Expression,
Diagnosis => "Asis.Expressions.Attribute_Designator_Expressions");
end Attribute_Designator_Expressions;
------------------------------------------------------------------------------
function Record_Component_Associations
(Expression : in Asis.Expression;
Normalized : in Boolean := False)
return Asis.Association_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Expression);
Arg_Node : Node_Id;
Returned_List_Length : ASIS_Integer;
Positional_List_Length : Int;
Named_List_Length : Int;
begin
Check_Validity (Expression,
"Asis.Expressions.Record_Component_Associations");
if not (Arg_Kind = A_Record_Aggregate or else
Arg_Kind = An_Extension_Aggregate)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.Record_Component_Associations");
end if;
Arg_Node := Node (Expression);
if Null_Record_Present (Arg_Node) then
return Nil_Element_List;
end if;
if Normalized then
Arg_Node := R_Node (Expression);
-- any not-null record or extension arrgegate is rewritten in the
-- tree, but the subtree rooted by the rewritten node is just
-- what the doctor ordered for obtaining the normalized form
-- of the aggregate
--
-- And we are sure, that if we are here, then the aggregate is not
-- null
return N_To_E_List_Without_Pragmas
(List => Component_Associations (Arg_Node),
Node_Knd => N_Component_Association,
Internal_Kind => A_Record_Component_Association,
Special_Case => Is_Normalized,
In_Unit => Encl_Unit (Expression));
end if;
-- computing the returned list length:
if Present (Sinfo.Expressions (Arg_Node)) then
Positional_List_Length := List_Length (Sinfo.Expressions (Arg_Node));
else
Positional_List_Length := 0;
end if;
if Present (Component_Associations (Arg_Node)) then
Named_List_Length := List_Length (Component_Associations (Arg_Node));
else
Named_List_Length := 0;
end if;
Returned_List_Length :=
ASIS_Integer (Positional_List_Length + Named_List_Length);
-- Returned_List_Length cannot be equal to 0 here!
declare -- for proper exception handling
Returned_List : Asis.Association_List (1 .. Returned_List_Length);
begin
-- obtaining the association list:
if Debug_Flag_1 then
Write_Str ("obtaining the association list");
Write_Eol;
Write_Str ("List length is ");
Write_Int (Int (Returned_List_Length));
Write_Eol;
end if;
Returned_List :=
Node_To_Element_List (
List => Sinfo.Expressions (Arg_Node),
Internal_Kind => A_Record_Component_Association,
In_Unit => Encl_Unit (Expression))
&
Node_To_Element_List (
List => Component_Associations (Arg_Node),
Internal_Kind => A_Record_Component_Association,
In_Unit => Encl_Unit (Expression));
-- resetting the Normalized-status related fields of the
-- elements in the returned list before returning the list:
-- for I in 1 .. Returned_List_Length loop
--
-- Put_Debug_Str ("Resetting Element number ");
-- Put_Debug_Int (Int (I));
-- Debug_New_Line;
--
-- Put_Debug_Line (Debug_Image (Returned_List (I)));
-- Debug_New_Line;
-- Set_From_Implicit (Returned_List(I), True);
-- Set_Special_Case (Returned_List(I), Is_Normalized);
--
-- end loop;
return Returned_List;
end;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Expression,
Bool_Par => Normalized,
Outer_Call => "Asis.Expressions.Record_Component_Associations");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Expression,
Bool_Par => Normalized,
Diagnosis => "Asis.Expressions.Record_Component_Associations");
end Record_Component_Associations;
-----------------------------------------------------------------------------
function Extension_Aggregate_Expression
(Expression : in Asis.Expression)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Expression);
Arg_Node : Node_Id;
begin
Check_Validity (Expression,
"Asis.Expressions.Extension_Aggregate_Expression");
if not (Arg_Kind = An_Extension_Aggregate) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.Extension_Aggregate_Expression");
end if;
Arg_Node := Node (Expression);
return Node_To_Element (Node => Ancestor_Part (Arg_Node),
In_Unit => Encl_Unit (Expression));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Expression,
Outer_Call => "Asis.Expressions.Extension_Aggregate_Expression");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Expression,
Diagnosis => "Asis.Expressions.Extension_Aggregate_Expression");
end Extension_Aggregate_Expression;
-----------------------------------------------------------------------------
function Array_Component_Associations (Expression : in Asis.Expression)
return Asis.Association_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Expression);
Arg_Node : Node_Id;
Named_Ass : List_Id;
Pos_Ass : List_Id;
begin
Check_Validity (Expression,
"Asis.Expressions.Array_Component_Associations");
if not (Arg_Kind = A_Positional_Array_Aggregate or else
Arg_Kind = A_Named_Array_Aggregate)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.Array_Component_Associations");
end if;
Arg_Node := Node (Expression);
Named_Ass := Component_Associations (Arg_Node);
Pos_Ass := Sinfo.Expressions (Arg_Node);
if Arg_Kind = A_Named_Array_Aggregate then
return Node_To_Element_List (
List => Named_Ass,
Internal_Kind => An_Array_Component_Association,
In_Unit => Encl_Unit (Expression));
elsif No (Named_Ass) then
-- that is, no "others" choice in a positional array aggregate
return Node_To_Element_List (
List => Pos_Ass,
Internal_Kind => An_Array_Component_Association,
In_Unit => Encl_Unit (Expression));
else
-- a positional array aggregate with "others"
return (Node_To_Element_List (
List => Pos_Ass,
Internal_Kind => An_Array_Component_Association,
In_Unit => Encl_Unit (Expression))
&
Node_To_Element (
Node => First (
-- and the only " others"-containing association
Named_Ass),
Internal_Kind => An_Array_Component_Association,
In_Unit => Encl_Unit (Expression)));
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Expression,
Outer_Call => "Asis.Expressions.Array_Component_Associations");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Expression,
Diagnosis => "Asis.Expressions.Array_Component_Associations");
end Array_Component_Associations;
-----------------------------------------------------------------------------
function Array_Component_Choices (Association : in Asis.Association)
return Asis.Expression_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Association);
Arg_Node : Node_Id;
begin
Check_Validity (Association, "Asis.Expressions.Array_Component_Choices");
if not (Arg_Kind = An_Array_Component_Association) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.Array_Component_Choices");
end if;
Arg_Node := Node (Association);
if Nkind (Arg_Node) = N_Component_Association then
-- named association
return Discrete_Choice_Node_To_Element_List
(Choice_List => Choices (Arg_Node),
In_Unit => Encl_Unit (Association));
else
-- positional association
return Nil_Element_List;
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Association,
Outer_Call => "Asis.Expressions.Array_Component_Choices");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Association,
Diagnosis => "Asis.Expressions.Array_Component_Choices");
end Array_Component_Choices;
-----------------------------------------------------------------------------
function Record_Component_Choices (Association : in Asis.Association)
return Asis.Expression_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Association);
Arg_Node : Node_Id;
Result_Node : Node_Id;
Temp_Node : Node_Id;
Result_Unit : Asis.Compilation_Unit;
Result_Element : Asis.Element;
-- for handling the normalized A_Record_Component_Association only
begin
Check_Validity (Association,
"Asis.Expressions.Record_Component_Choices");
if not (Arg_Kind = A_Record_Component_Association) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.Record_Component_Choices");
end if;
Arg_Node := Node (Association);
if Special_Case (Association) = Is_Normalized then
-- it is definitely A_Record_Component_Association
-- based on the N_Component_Association Node
-- and the returned list should definitely contain exactly one
-- component of A_Defining_Name kind, which should not
-- test as Is_Normalized
--
-- Note, that if the argument Is_Normalized, its Node and R_Node
-- fields are the same
Result_Node := Entity (First (Choices (Arg_Node)));
Result_Unit := Enclosing_Unit
(Encl_Cont_Id (Association), Result_Node);
Result_Element := Node_To_Element_New
(Starting_Element => Association,
Node => Result_Node,
Internal_Kind => A_Defining_Identifier,
In_Unit => Result_Unit);
-- And now we have to correct some fields in Result_Element.
-- First, Association Is_Normalized, but its components are
-- not Is_Normalized. Therefore
Set_Special_Case (Result_Element, Not_A_Special_Case);
-- Then, we should check whether or not Result_Element represents
-- the implicit inherited component of some derived type
-- The idea (based on the tree structure of 3.05) is to go from
-- Result_Node up to the corresponding full type declaration,
-- then one step down to the type defining identifier and then
-- to check if it Is_Internal
Temp_Node := Parent (Parent (Result_Node));
-- this Parent (Parent) gives us either N_Component_List node
-- (if Result_Node corresponds to a record component) or
-- N_Full_Type_Declaration node (if Result_Node corresponds to a
-- discriminant). In the former case we have to apply Parent
-- twice more to go to a N_Full_Type_Declaration node
if Nkind (Temp_Node) = N_Component_List then
Temp_Node := Parent (Parent (Temp_Node));
end if;
-- and now - the test and the related corrections if the test
-- is successful:
if Nkind (Temp_Node) = N_Full_Type_Declaration then
-- if Result_Node corresponds to a record component from a record
-- expension part, we should be in N_Derived_Type_Definition
-- node here, and we have nothing to correct in Result_Element
-- in that case
Temp_Node := Defining_Identifier (Temp_Node);
if Is_Internal (Temp_Node) then
Set_From_Implicit (Result_Element);
Set_From_Inherited (Result_Element);
end if;
end if;
return (1 => Result_Element);
end if;
-- processing a non-normalized association:
if Nkind (Arg_Node) = N_Component_Association then
return Node_To_Element_List (List => Choices (Arg_Node),
In_Unit => Encl_Unit (Association));
else
return Nil_Element_List;
-- what else can we get from a positional association?
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Association,
Outer_Call => "Asis.Expressions.Record_Component_Choices");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Association,
Diagnosis => "Asis.Expressions.Record_Component_Choices");
end Record_Component_Choices;
-----------------------------------------------------------------------------
function Component_Expression (Association : in Asis.Association)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Association);
Arg_Node : Node_Id;
Returned_Element : Element;
Result_Node : Node_Id;
Temp_Node : Node_Id;
Norm_Expr_Sloc : Source_Ptr;
begin
Check_Validity (Association, "Asis.Expressions.Component_Expression");
if not (Arg_Kind = A_Record_Component_Association or else
Arg_Kind = An_Array_Component_Association)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.Component_Expression");
end if;
Arg_Node := Node (Association);
if Special_Case (Association) = Is_Normalized then
-- the idea of the implementation is: to go up to the
-- (rewritten!) N_Aggregate node, then to go to the corrsponding
-- expression in the corresponding non-normalized association
-- through the original aggregate node. The corresponding
-- expression is the expression having the same Sloc value
-- (we are traversing the same tree all the time, so we do not
-- need relative Slocs.
--
-- It may look a bit crazy - why do not we use the expression
-- subtree from the rewritten aggregate. At least one reason is
-- that some details of the original expression structure are
-- lost in the rewritten aggregate as a result of compile-time
-- optimizations of static expressions
Result_Node := Parent (Arg_Node);
-- here we are in the rewritten aggregate node. Now coming to its
-- original node:
Result_Node := Original_Node (Result_Node);
-- and now - trying to find the corresponding expression:
Norm_Expr_Sloc := Sloc (Sinfo.Expression (Arg_Node));
if Present (Sinfo.Expressions (Result_Node)) then
-- starting from positional associations, if any:
Temp_Node := First (Sinfo.Expressions (Result_Node));
while Present (Temp_Node) loop
if Sloc (Temp_Node) = Norm_Expr_Sloc then
Result_Node := Temp_Node;
goto Find;
end if;
Temp_Node := Next (Temp_Node);
end loop;
elsif Present (Component_Associations (Result_Node)) then
Temp_Node := First (Component_Associations (Result_Node));
while Present (Temp_Node) loop
if Sloc (Sinfo.Expression (Temp_Node)) = Norm_Expr_Sloc then
Result_Node := (Sinfo.Expression (Temp_Node));
goto Find;
end if;
Temp_Node := Next (Temp_Node);
end loop;
end if;
<<Find>>
if Nkind (Result_Node) = N_Aggregate then
-- This means, that there is some error in the implementation,
-- or the tree structure has been changed, and it does not
-- correspond to this implementation approach any more
Raise_ASIS_Failed (Diagnosis =>
"Cannot find the result node for a normalized association");
end if;
Returned_Element := Node_To_Element_New
(Starting_Element => Association,
Node => Result_Node);
-- And now we have to correct the Result_Element before returning
-- it. Association Is_Normalized, but its components are
-- not Is_Normalized. Therefore
Set_Special_Case (Returned_Element, Not_A_Special_Case);
return Returned_Element;
else
-- processing non-normalized A_Record_Component_Association or
-- An_Array_Component_Association
-- tree traversing:
if Nkind (Arg_Node) = N_Component_Association then
-- named array association
Result_Node := Sinfo.Expression (Arg_Node);
else
-- positional array association
Result_Node := Arg_Node;
end if;
-- return Node_To_Element (Node => Result_Node,
-- In_Unit => Encl_Unit (Association));
return Node_To_Element_New (Node => Result_Node,
Starting_Element => Association);
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Association,
Outer_Call => "Asis.Expressions.Component_Expression");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Association,
Diagnosis => "Asis.Expressions.Component_Expression");
end Component_Expression;
------------------------------------------------------------------------------
-- PARTIALLY IMPLEMENTED, CANNOT HANDLE THE NORMALIZED ARGUMENT
-- ??? NEEDS REVISING BADLY!!!
function Formal_Parameter (Association : in Asis.Association)
return Asis.Element
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Association);
Arg_Node : Node_Id;
Result_Node : Node_Id;
Result_Unit : Compilation_Unit;
Result_Kind : Internal_Element_Kinds := Not_An_Element;
Auto_Detect : Boolean := False;
-- set True for A_Generic_Association if the auto determination
-- of the result kind is required (this is the case if the resukt
-- is of An_Operator_Symbol kind), otherwise we are sure that the
-- result should be of An_Identifier kind
Nil_To_Be_Returned : Boolean := False;
begin
Check_Validity (Association, "Asis.Expressions.Formal_Parameter");
if not (Arg_Kind = A_Parameter_Association or else
Arg_Kind = A_Generic_Association or else
Arg_Kind = A_Pragma_Argument_Association)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.Formal_Parameter");
end if;
Arg_Node := Node (Association);
if Special_Case (Association) in Normalized_Association then
if Arg_Kind = A_Generic_Association then
-- see the documentation for the body of
-- Norm.Normalized_Generic_Associations:
Result_Node := Arg_Node;
Result_Unit :=
Enclosing_Unit (Encl_Cont_Id (Association), Result_Node);
-- if not Is_Consistent (Result_Unit, Encl_Unit (Association)) then
-- return Nil_Element;
-- end if;
return Node_To_Element_New (Node => Result_Node,
Internal_Kind => Result_Kind,
In_Unit => Result_Unit);
else
Not_Implemented_Yet (Diagnosis =>
"Asis.Expressions.Formal_Parameter: "
& ASIS_Line_Terminator
& " Cannot handle the NORMALIZED parameter association");
end if;
else
if Arg_Kind = A_Parameter_Association then
if not (Nkind (Arg_Node) = N_Parameter_Association) then
-- positional (non-normalized) associaton
Nil_To_Be_Returned := True;
else
Result_Node := Selector_Name (Arg_Node);
end if;
elsif Arg_Kind = A_Generic_Association then
-- Arg_Node_Kind = N_Generic_Association
-- is always True
if No (Selector_Name (Arg_Node)) then
-- positional (non-normalized) associaton
Nil_To_Be_Returned := True;
else
Result_Node := Selector_Name (Arg_Node);
if Nkind (Result_Node) = N_Operator_Symbol then
Auto_Detect := True;
end if;
end if;
else -- Arg_Kind = A_Pragma_Argument_Association
-- special treatment by an identifier in the tree
if Chars (Arg_Node) = No_Name then
-- no pragma argument identifier
Nil_To_Be_Returned := True;
else
Result_Node := Arg_Node;
end if;
end if;
if Nil_To_Be_Returned then
return Nil_Element;
elsif Auto_Detect then
return Node_To_Element (
Node => Result_Node,
In_Unit => Encl_Unit (Association));
else
return Node_To_Element (
Node => Result_Node,
Internal_Kind => An_Identifier,
In_Unit => Encl_Unit (Association));
end if;
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Association,
Outer_Call => "Asis.Expressions.Formal_Parameter");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Association,
Diagnosis => "Asis.Expressions.Formal_Parameter");
end Formal_Parameter;
------------------------------------------------------------------------------
-- PARTIALLY IMPLEMENTED, CANNOT HANDLE THE NORMALIZED ARGUMENT
function Actual_Parameter (Association : in Asis.Association)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Association);
Arg_Node : Node_Id;
Result_Node : Node_Id;
Result_Kind : Internal_Element_Kinds := Not_An_Element;
Result_Spec_Case : Special_Cases := Not_A_Special_Case;
Result_Unit : Compilation_Unit;
Use_Or_Node : Boolean := True;
Pragma_Node : Node_Id;
Pragma_Chars : Name_Id;
begin
Check_Validity (Association, "Asis.Expressions.Actual_Parameter");
if not (Arg_Kind = A_Parameter_Association or else
Arg_Kind = A_Generic_Association or else
Arg_Kind = A_Pragma_Argument_Association)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.Actual_Parameter");
end if;
Arg_Node := Node (Association);
if Special_Case (Association) in Normalized_Association then
if Arg_Kind = A_Generic_Association then
-- see the documentation for the body of
-- Norm.Normalized_Generic_Associations:
Result_Node := Node_Field_1 (Association);
if Special_Case (Association) = Is_Normalized_Defaulted then
-- the actual parameter is taken by default from the
-- declaration of the corresponding formal, it may be
-- in another Compilation Unit
Result_Unit :=
Enclosing_Unit (Encl_Cont_Id (Association), Result_Node);
else
Result_Unit := Encl_Unit (Association);
end if;
-- in case of the default defined at the place of
-- an instantiation for A_Box_Default; we will keep
-- Special_Case equial to Is_Normalized_Defaulted_For_Box
-- (just in case).
if Special_Case (Association) =
Is_Normalized_Defaulted_For_Box
then
Result_Spec_Case := Is_Normalized_Defaulted_For_Box;
end if;
return Node_To_Element_New (Node => Result_Node,
Spec_Case => Result_Spec_Case,
In_Unit => Result_Unit);
else
Not_Implemented_Yet (Diagnosis =>
"Asis.Expressions.Actual_Parameter: "
& ASIS_Line_Terminator
& " Cannot handle the NORMALIZED parameter association");
end if;
else
if Arg_Kind = A_Parameter_Association then
if not (Nkind (Arg_Node) = N_Parameter_Association) then
-- positional (non-normalized) associaton
Result_Node := R_Node (Association);
else
Result_Node := Explicit_Actual_Parameter (Arg_Node);
end if;
elsif Arg_Kind = A_Generic_Association then
-- NKind (Arg_Node) = N_Generic_Association is always True
Result_Node := Explicit_Generic_Actual_Parameter (Arg_Node);
else
-- Arg_Kind = A_Pragma_Argument_Association
-- Special processing is needed for a Debug pragma:
Pragma_Node := Original_Node (Parent (Arg_Node));
Pragma_Chars := Chars (Pragma_Node);
if Pragma_Chars = Name_Debug then
Result_Node := Parent (Arg_Node);
Result_Kind := A_Procedure_Call_Statement;
Use_Or_Node := False;
else
Result_Node := Sinfo.Expression (Arg_Node);
end if;
end if;
end if;
return Node_To_Element_New
(Node => Result_Node,
Starting_Element => Association,
Internal_Kind => Result_Kind,
Using_Original_Node => Use_Or_Node);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Association,
Outer_Call => "Asis.Expressions.Actual_Parameter");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Association,
Diagnosis => "Asis.Expressions.Actual_Parameter");
end Actual_Parameter;
------------------------------------------------------------------------------
-- PARTIALLY IMPLEMENTED, CANNOT HANDLE THE NORMALIZED ARGUMENT
function Discriminant_Selector_Names
(Association : in Asis.Discriminant_Association)
return Asis.Expression_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Association);
Arg_Node : Node_Id;
begin
Check_Validity (Association,
"Asis.Expressions.Discriminant_Selector_Names");
if not (Arg_Kind = A_Discriminant_Association) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.Discriminant_Selector_Names");
end if;
Arg_Node := Node (Association);
if Special_Case (Association) = Is_Normalized then
return (1 => Discr_Def_Name (Association));
else
if not (Nkind (Arg_Node) = N_Discriminant_Association) then
-- positional association
return Nil_Element_List;
else
return Node_To_Element_List (
List => Selector_Names (Arg_Node),
Internal_Kind => An_Identifier,
In_Unit => Encl_Unit (Association));
end if;
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Association,
Outer_Call => "Asis.Expressions.Discriminant_Selector_Names");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Association,
Diagnosis => "Asis.Expressions.Discriminant_Selector_Names");
end Discriminant_Selector_Names;
------------------------------------------------------------------------------
-- PARTIALLY IMPLEMENTED, CANNOT HANDLE THE NORMALIZED ARGUMENT
function Discriminant_Expression
(Association : in Asis.Discriminant_Association)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Association);
Arg_Node : Node_Id;
begin
Check_Validity (Association, "Asis.Expressions.Discriminant_Expression");
if not (Arg_Kind = A_Discriminant_Association) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.Discriminant_Expression");
end if;
Arg_Node := Node (Association);
if Special_Case (Association) = Is_Normalized then
Not_Implemented_Yet (Diagnosis =>
"Asis.Expressions.Discriminant_Expression: "
& ASIS_Line_Terminator
& " Processing of the NORMALIZED "
& "Asis.Discriminant_Association");
return Nil_Element; -- to avoid GNAT warning
else
if Nkind (Arg_Node) = N_Discriminant_Association then
-- named association ?
return Node_To_Element (
Node => Sinfo.Expression (Arg_Node),
In_Unit => Encl_Unit (Association));
else
-- positional association?
return Node_To_Element (
Node => Arg_Node,
In_Unit => Encl_Unit (Association));
end if;
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Association,
Outer_Call => "Asis.Expressions.Discriminant_Expression");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Association,
Diagnosis => "Asis.Expressions.Discriminant_Expression");
end Discriminant_Expression;
-----------------------------------------------------------------------------
function Is_Normalized (Association : in Asis.Association) return Boolean
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Association);
Spec_Case : Special_Cases;
begin
Check_Validity (Association, "Asis.Expressions.Is_Normalized");
if not (Arg_Kind = A_Discriminant_Association or else
Arg_Kind = A_Record_Component_Association or else
Arg_Kind = A_Parameter_Association or else
Arg_Kind = A_Generic_Association)
then
return False;
else
Spec_Case := Special_Case (Association);
return Spec_Case in Normalized_Association;
end if;
end Is_Normalized;
-----------------------------------------------------------------------------
function Is_Defaulted_Association
(Association : in Asis.Element)
return Boolean
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Association);
Spec_Case : Special_Cases;
begin
Check_Validity (Association,
"Asis.Expressions.Is_Defaulted_Association");
if not (Arg_Kind = A_Parameter_Association or else
Arg_Kind = A_Generic_Association)
then
return False;
else
Spec_Case := Special_Case (Association);
return Spec_Case in Defaulted_Association;
end if;
end Is_Defaulted_Association;
------------------------------------------------------------------------------
function Expression_Parenthesized (Expression : in Asis.Expression)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Expression);
Arg_Node : Node_Id;
Initial_Parentheses_Level : Paren_Count_Type;
Parentheses_Away : Special_Cases;
Returned_Element : Asis.Expression;
-- used when the result is also of A_Parenthesized_Expression
-- with one level of parentheses less, differs with the actual
-- parameter passed for Expression only in the values of the
-- Special_Case field
Unparenthesized_Expression_To_Return : Boolean;
begin
Check_Validity (Expression,
"Asis.Expressions.Expression_Parenthesized");
if not (Arg_Kind = A_Parenthesized_Expression) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.Expression_Parenthesized");
end if;
Arg_Node := Node (Expression);
Initial_Parentheses_Level := Paren_Count (Arg_Node);
-- should be in 1 .. 3
Returned_Element := Expression;
Parentheses_Away := Special_Case (Expression);
Unparenthesized_Expression_To_Return := False;
case Initial_Parentheses_Level is
when 1 => -- (Exp) -> Exp
Unparenthesized_Expression_To_Return := True;
when 2 =>
if Parentheses_Away = Not_A_Special_Case then
-- [((Exp)) ->] ((Exp)) -> (Exp)
Set_Special_Case
(Returned_Element, One_Pair_Of_Parentheses_Away);
else
-- means Parentheses_Away = One_Pair_Of_Parentheses_Away,
-- nothing else could be possible:
-- [((Exp)) ->] (Exp) -> Exp
Unparenthesized_Expression_To_Return := True;
end if;
when 3 =>
if Parentheses_Away = Not_A_Special_Case then
-- [(((Exp))) ->] (((Exp))) -> ((Exp))
Set_Special_Case
(Returned_Element, One_Pair_Of_Parentheses_Away);
elsif Parentheses_Away = One_Pair_Of_Parentheses_Away then
-- [(((Exp))) ->] ((Exp)) -> (Exp)
Set_Special_Case
(Returned_Element, Two_Pairs_Of_Parentheses_Away);
else
-- means Parentheses_Away = Two_Pairs_Of_Parentheses_Away,
-- nothing else could be possible:
-- [(((Exp))) ->]1 (Exp) -> Exp
Unparenthesized_Expression_To_Return := True;
end if;
when others =>
-- it could mean only some error in the implementation
Raise_ASIS_Failed (
Diagnosis => "The argument is of A_Parenthesized_Expression "
& "kind, but its Paren_Count = 0 !");
end case;
if Unparenthesized_Expression_To_Return then
-- the returned element should be based on the same node as the
-- argument, but it should not be classified as
-- A_Parenthesized_Expression, so Taking_Account_Of_Parent_Count
-- flag should be set OFF
return Node_To_Element (
Node => R_Node (Expression),
Taking_Account_Of_Parent_Count => False,
In_Unit => Encl_Unit (Expression));
else
return Returned_Element;
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Expression,
Outer_Call => "Asis.Expressions.Expression_Parenthesized");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Expression,
Diagnosis => "Asis.Expressions.Expression_Parenthesized");
end Expression_Parenthesized;
-----------------------------------------------------------------------------
function Is_Prefix_Call (Expression : in Asis.Expression)
return Boolean
is
Arg_Node : Node_Id;
begin
Check_Validity (Expression, "Asis.Expressions.Is_Prefix_Call");
Arg_Node := Node (Expression);
if Nkind (Arg_Node) = N_Attribute_Reference then
return True;
elsif Nkind (Arg_Node) = N_Identifier then
-- Special case: F.A , where F - parameterless function returning
-- arecord type
return True;
elsif not (Nkind (Arg_Node) = N_Function_Call) then
return False;
else
return Nkind (Sinfo.Name (Arg_Node)) /= N_Identifier
or else
Chars (Sinfo.Name (Arg_Node)) not in Any_Operator_Name;
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Expression,
Outer_Call => "Asis.Expressions.Is_Prefix_Call");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Expression,
Diagnosis => "Asis.Expressions.Is_Prefix_Call");
end Is_Prefix_Call;
-----------------------------------------------------------------------------
function Corresponding_Called_Function
(Expression : in Asis.Expression)
return Asis.Declaration
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Expression);
begin
Check_Validity (Expression,
"Asis.Expressions.Corresponding_Called_Function");
if not (Arg_Kind = A_Function_Call) then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
"Asis.Expressions.Corresponding_Called_Function");
end if;
return Get_Corr_Called_Entity (Expression);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Expression,
Outer_Call => "Asis.Expressions.Corresponding_Called_Function");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Expression,
Diagnosis => "Asis.Expressions.Corresponding_Called_Function");
end Corresponding_Called_Function;
------------------------------------------------------------------------------
function Function_Call_Parameters
(Expression : in Asis.Expression;
Normalized : in Boolean := False)
return Asis.Association_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Expression);
Arg_Node : Node_Id;
Function_Call_Node : Node_Id;
Func_Call_Or_Node : Node_Id;
Function_Call_Node_Kind : Node_Kind;
Ass_Node_List : List_Id;
Infix_Operands : Asis.Association_List (1 .. 2);
begin
Check_Validity (Expression,
"Asis.Expressions.Function_Call_Parameters");
Arg_Node := Node (Expression);
if not (Arg_Kind = A_Function_Call) or else
(Normalized and then Nkind (Arg_Node) = N_Attribute_Reference)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.Function_Call_Parameters");
end if;
-- There is a number of different situations when the frontend
-- rewrites or changes in some other way the node heading
-- the subtree representing a function call. So we have to start
-- from computing the node to represent a functon call.
if Nkind (R_Node (Expression)) = N_Raise_Constraint_Error or else
Nkind (R_Node (Expression)) = N_Raise_Program_Error or else
Nkind (R_Node (Expression)) = N_Conditional_Expression
then
Function_Call_Node := Node (Expression);
elsif Nkind (Arg_Node) = N_Attribute_Reference then
Function_Call_Node := Arg_Node;
elsif Nkind (Arg_Node) = N_Op_Ne and then
Nkind (R_Node (Expression)) = N_Op_Not
then
Function_Call_Node := Arg_Node; -- change for 3.09
else
Function_Call_Node := R_Node (Expression);
if Nkind (Function_Call_Node) = N_Integer_Literal or else
Nkind (Function_Call_Node) = N_Real_Literal or else
Nkind (Function_Call_Node) = N_Identifier or else
Nkind (Function_Call_Node) = N_String_Literal or else
-- this means, that the compiler has optimized a call like
-- 1 + 2, and we have to go back to the original node!
Nkind (Function_Call_Node) = N_Explicit_Dereference
-- this happens, but I do not know why...
then
Function_Call_Node := Arg_Node;
end if;
if Nkind (Function_Call_Node) = N_Type_Conversion and then
Is_Rewrite_Substitution (Function_Call_Node) and then
Nkind (Original_Node (Function_Call_Node)) =
Nkind (Sinfo.Expression (Function_Call_Node))
then
-- this is for fixed-fixed multiplying operations
Function_Call_Node := Sinfo.Expression (Function_Call_Node);
end if;
end if;
-- See the general comment under the "A_Function_Call Problem"
-- headline in the begginning of the package body!! The prefix call
-- of the predefined operations should be processed on the base of
-- the rewritten node, in all the other cases, except
-- N_Attribute_Reference (which corresponds to the call to an
-- attribute-function and is handled separately: the node for such
-- a call may or may not be rewritten, but the processing is based on
-- the original node) the node is not rewritten.
-- -- temporary fix for "+"(1, 2) problem ??? 3.11w
--
-- if Nkind (Node (Expression)) = N_Function_Call and then
-- (Nkind (R_Node (Expression)) in N_Op_Add .. N_Op_Xor or else
-- Nkind (R_Node (Expression)) in N_Op_Abs .. N_Op_Plus)
-- then
-- Function_Call_Node := R_Node (Expression);
-- end if;
--
-- to activate this fix, one should decomment this if statement
-- and to comment out the fragment between
-- -- temporary fix for "+"(1, 2) problem - start
-- and
-- -- temporary fix for "+"(1, 2) problem - end
-- sentinels
Function_Call_Node_Kind := Nkind (Function_Call_Node);
-- if Normalized
-- then
-- Not_Implemented_Yet (Diagnosis =>
-- "Asis.Expressions.Function_Call_Parameters: "
-- & ASIS_Line_Terminator
-- & " Construction of the NORMALISED "
-- & "Asis.Association_List");
--
-- return Nil_Element_List; -- to avoid GNAT warning
--
-- else
if Function_Call_Node_Kind = N_Attribute_Reference then
-- the (prefix) call of the attribute function
if Normalized then
-- the current solution is to return the list of Is_Normalized
-- associations which will return Nil_Element when asked
-- about the formal parameter. Another possible solution
-- is to raise Asis_Inappropriate element (the corresponding
-- code is commented out below)
return N_To_E_List_New
(List => Sinfo.Expressions (Function_Call_Node),
Include_Pragmas => False, -- ???
Starting_Element => Expression,
Internal_Kind => A_Parameter_Association,
Special_Case => Is_Normalized);
-- Raise_ASIS_Inappropriate_Element (Diagnosis =>
-- "Asis.Expressions.Corresponding_Name_Definition: "
-- & "Normalized is set for the call to function-attribute");
else
return N_To_E_List_New
(List => Sinfo.Expressions (Function_Call_Node),
Starting_Element => Expression,
Internal_Kind => A_Parameter_Association);
end if;
elsif Function_Call_Node_Kind = N_Function_Call then
if No (Parameter_Associations (Function_Call_Node)) then
return Nil_Element_List;
elsif Normalized then
return Normalized_Param_Associations
(Call_Elem => Expression,
Call_Node => Function_Call_Node);
else
return N_To_E_List_New
(List => Parameter_Associations (Function_Call_Node),
Starting_Element => Expression,
Internal_Kind => A_Parameter_Association);
end if;
elsif Function_Call_Node_Kind in N_Op_Add .. N_Op_Xor then
-- here we have infix or prefix call of a binary predefined
-- operation
-- first, we construct the non-normalized association list
Infix_Operands (1) := Node_To_Element_New
(Node => Left_Opnd (Function_Call_Node),
Internal_Kind => A_Parameter_Association,
Starting_Element => Expression);
Infix_Operands (2) := Node_To_Element_New
(Node => Right_Opnd (Function_Call_Node),
Internal_Kind => A_Parameter_Association,
Starting_Element => Expression);
if Normalized then
-- we simply correct the Special_Case field of the result
-- and return it, and the rest will be the business of the
-- functions making up the further decomposition...
Set_Special_Case (Infix_Operands (1), Is_Normalized);
Set_Special_Case (Infix_Operands (2), Is_Normalized);
-- temporary fix for "+"(1, 2) problem - start
elsif Is_Prefix_Call (Expression) then
-- Is is a real pity, but we have to worry about the crazy
-- situation like "+" (Right => X, Left => Y). For a prefix
-- call to a predefined operation an argument node is
-- rewritten to N_Op_Xxx node, and the original node of
-- N_Function_Call kind contains references to named
-- parameter associations, if any
-- So, we have to check if this situation takes place
-- If not Is_Prefix_Call (Expression), we have nothing to do!
Func_Call_Or_Node := Node (Expression);
if Func_Call_Or_Node /= Function_Call_Node and then
-- Func_Call_Or_Node can be of N_Function_Call kind only!
-- and we have the prefix call here!
--
-- Present (Parameter_Associations (Func_Call_Or_Node))
--
-- cannot be used to complete the check, because we have
-- empty list, but not No_List if there is positional
-- associations. Therefore -
List_Length (Parameter_Associations (Func_Call_Or_Node)) > 0
then
-- we have named associations, and we have to correct the
-- result
Ass_Node_List := Parameter_Associations (Func_Call_Or_Node);
if List_Length (Ass_Node_List) = 2 then
-- we have two named associations, so we cannot return
-- Infix_Operands. We will not correct it, we will
-- recreate the returned list:
return N_To_E_List_New
(List => Ass_Node_List,
Include_Pragmas => False, -- ???
Starting_Element => Expression,
Internal_Kind => A_Parameter_Association);
else
-- if we are here, the only possibility is that
-- List_Length (Ass_Node_List) = 1 and we are processing
-- the call like "+"(13, Right => Y).
-- So the first component of Infix_Operands is OK,
-- but the second should be re-created from the
-- positional association pointed by the original node:
Infix_Operands (2) := Node_To_Element_New (
Node => First (Ass_Node_List),
Internal_Kind => A_Parameter_Association,
Starting_Element => Expression);
end if;
end if;
end if;
-- temporary fix for "+"(1, 2) problem - end
return Infix_Operands;
elsif Function_Call_Node_Kind in N_Op_Abs .. N_Op_Plus then
-- unary operation, Sinfo.ads rev. 1.251
-- infix_call, here we have infix or prefix call of an unary
-- predefined operation
-- the situation is more simple, then for binary predefined
-- operation - we have only one component in the returned list
-- we start from checking if we have the crazy case with
-- named association (something like "+"(Right => X)
Func_Call_Or_Node := Node (Expression);
if Func_Call_Or_Node /= Function_Call_Node and then
List_Length (Parameter_Associations (Func_Call_Or_Node)) > 0
then
-- we have named association
Ass_Node_List := Parameter_Associations (Func_Call_Or_Node);
Infix_Operands (1) := Node_To_Element_New (
Node => First (Ass_Node_List),
Internal_Kind => A_Parameter_Association,
Starting_Element => Expression);
else
Infix_Operands (1) := Node_To_Element_New (
Node => Right_Opnd (Function_Call_Node),
Internal_Kind => A_Parameter_Association,
Starting_Element => Expression);
end if;
if Normalized then
-- we simply correct the Special_Case field of the result...
-- and the rest will be the business of the functions making
-- up the further decomposition...
Set_Special_Case (Infix_Operands (1), Is_Normalized);
end if;
return Infix_Operands (1 .. 1);
else
-- really nothing else could be possible, this alternative
-- could be chosen only as the result of some bug in the
-- implementation
Raise_ASIS_Failed (
Diagnosis => "The argument ("
& Node_Id'Image (Arg_Node)
& ") is of "
& "A_Function_Call kind,"
& ASIS_Line_Terminator
& "but it is based on the Node of the "
& Node_Kind'Image (Function_Call_Node_Kind)
& " Node Kind");
return Nil_Element_List; -- to avoid GNAT warning
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Expression,
Bool_Par => Normalized,
Outer_Call => "Asis.Expressions.Function_Call_Parameters");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Expression,
Bool_Par => Normalized,
Diagnosis => "Asis.Expressions.Function_Call_Parameters");
end Function_Call_Parameters;
-----------------------------------------------------------------------------
function Short_Circuit_Operation_Left_Expression
(Expression : in Asis.Expression)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Expression);
Arg_Node : Node_Id;
begin
Check_Validity (Expression,
"Asis.Expressions.Short_Circuit_Operation_Left_Expression");
if not (Arg_Kind = An_And_Then_Short_Circuit or else
Arg_Kind = An_Or_Else_Short_Circuit)
then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
"Asis.Expressions.Short_Circuit_Operation_Left_Expression");
end if;
Arg_Node := Node (Expression);
return Node_To_Element_New (Node => Left_Opnd (Arg_Node),
Starting_Element => Expression);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Expression,
Outer_Call =>
"Asis.Expressions.Short_Circuit_Operation_Left_Expression");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Expression,
Diagnosis =>
"Asis.Expressions.Short_Circuit_Operation_Left_Expression");
end Short_Circuit_Operation_Left_Expression;
-----------------------------------------------------------------------------
function Short_Circuit_Operation_Right_Expression
(Expression : in Asis.Expression)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Expression);
Arg_Node : Node_Id;
begin
Check_Validity (Expression,
"Asis.Expressions.Short_Circuit_Operation_Right_Expression");
if not (Arg_Kind = An_And_Then_Short_Circuit or else
Arg_Kind = An_Or_Else_Short_Circuit)
then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
"Asis.Expressions.Short_Circuit_Operation_Right_Expression");
end if;
Arg_Node := Node (Expression);
return Node_To_Element (Node => Right_Opnd (Arg_Node),
In_Unit => Encl_Unit (Expression));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Expression,
Outer_Call =>
"Asis.Expressions.Short_Circuit_Operation_Right_Expression");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Expression,
Diagnosis =>
"Asis.Expressions.Short_Circuit_Operation_Right_Expression");
end Short_Circuit_Operation_Right_Expression;
-----------------------------------------------------------------------------
function Membership_Test_Expression (Expression : in Asis.Expression)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Expression);
Arg_Node : Node_Id;
begin
Check_Validity (Expression,
"Asis.Expressions.Membership_Test_Expression");
if not (Arg_Kind = An_In_Range_Membership_Test or else
Arg_Kind = A_Not_In_Range_Membership_Test or else
Arg_Kind = An_In_Type_Membership_Test or else
Arg_Kind = A_Not_In_Type_Membership_Test)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.Membership_Test_Expression");
end if;
Arg_Node := Node (Expression);
return Node_To_Element (Node => Left_Opnd (Arg_Node),
In_Unit => Encl_Unit (Expression));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Expression,
Outer_Call => "Asis.Expressions.Membership_Test_Expression");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Expression,
Diagnosis => "Asis.Expressions.Membership_Test_Expression");
end Membership_Test_Expression;
-----------------------------------------------------------------------------
function Membership_Test_Range (Expression : in Asis.Expression)
return Asis.Range_Constraint
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Expression);
Arg_Node : Node_Id;
Result_Node : Node_Id;
Result_Or_Node : Node_Id;
Result_Kind : Internal_Element_Kinds;
begin
Check_Validity (Expression, "Asis.Expressions.Membership_Test_Range");
if not (Arg_Kind = An_In_Range_Membership_Test or else
Arg_Kind = A_Not_In_Range_Membership_Test)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.Membership_Test_Range");
end if;
Arg_Node := Node (Expression);
-- we cannot use the auto determination of the result kind
-- because of the possible rewritting of A'Range as
-- A'First .. A'Last.
Result_Node := Right_Opnd (Arg_Node);
Result_Or_Node := Original_Node (Result_Node);
if Nkind (Result_Or_Node) = N_Attribute_Reference then
Result_Kind := A_Range_Attribute_Reference;
else
Result_Kind := A_Simple_Expression_Range;
end if;
return Node_To_Element (Node => Result_Node,
Internal_Kind => Result_Kind,
In_Unit => Encl_Unit (Expression));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Expression,
Outer_Call => "Asis.Expressions.Membership_Test_Range");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Expression,
Diagnosis => "Asis.Expressions.Membership_Test_Range");
end Membership_Test_Range;
-----------------------------------------------------------------------------
function Membership_Test_Subtype_Mark (Expression : in Asis.Expression)
return Asis.Expression is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Expression);
Arg_Node : Node_Id;
begin
Check_Validity (Expression,
"Asis.Expressions.Membership_Test_Subtype_Mark");
if not (Arg_Kind = An_In_Type_Membership_Test or else
Arg_Kind = A_Not_In_Type_Membership_Test)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.Membership_Test_Expression");
end if;
Arg_Node := Node (Expression);
return Node_To_Element (Node => Right_Opnd (Arg_Node),
In_Unit => Encl_Unit (Expression));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Expression,
Outer_Call => "Asis.Expressions.Membership_Test_Subtype_Mark");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Expression,
Diagnosis => "Asis.Expressions.Membership_Test_Subtype_Mark");
end Membership_Test_Subtype_Mark;
------------------------------------------------------------------------------
function Converted_Or_Qualified_Subtype_Mark
(Expression : in Asis.Expression)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Expression);
Arg_Node : Node_Id;
begin
Check_Validity (Expression,
"Asis.Expressions.Converted_Or_Qualified_Subtype_Mark");
if not (Arg_Kind = A_Type_Conversion or else
Arg_Kind = A_Qualified_Expression)
then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
"Asis.Expressions.Converted_Or_Qualified_Subtype_Mark");
end if;
Arg_Node := Node (Expression);
if Special_Case (Expression) = Type_Conversion_With_Attribute then
return Node_To_Element (
Node => Arg_Node,
-- that is, the node of N_Attribute_Reference kind!
Check_If_Type_Conversion => False,
-- and it is treated as the base for An_Attribute_Reference
-- Element
In_Unit => Encl_Unit (Expression));
else
return Node_To_Element (
Node => Sinfo.Subtype_Mark (Arg_Node),
In_Unit => Encl_Unit (Expression));
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Expression,
Outer_Call =>
"Asis.Expressions.Converted_Or_Qualified_Subtype_Mark");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Expression,
Diagnosis =>
"Asis.Expressions.Converted_Or_Qualified_Subtype_Mark");
end Converted_Or_Qualified_Subtype_Mark;
------------------------------------------------------------------------------
function Converted_Or_Qualified_Expression
(Expression : in Asis.Expression)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Expression);
Arg_Node : Node_Id;
begin
Check_Validity (Expression,
"Asis.Expressions.Converted_Or_Qualified_Expression");
if not (Arg_Kind = A_Type_Conversion or else
Arg_Kind = A_Qualified_Expression)
then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
"Asis.Expressions.Converted_Or_Qualified_Expression");
end if;
if Special_Case (Expression) = Type_Conversion_With_Attribute then
Arg_Node := R_Node (Expression);
-- that is, the (converted) expression will be obtained from the
-- rewritten node of N_Type_Conversion kind!
else
Arg_Node := Node (Expression);
end if;
return Node_To_Element (Node => Sinfo.Expression (Arg_Node),
In_Unit => Encl_Unit (Expression));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Expression,
Outer_Call =>
"Asis.Expressions.Converted_Or_Qualified_Expression");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Expression,
Diagnosis => "Asis.Expressions.Converted_Or_Qualified_Expression");
end Converted_Or_Qualified_Expression;
-----------------------------------------------------------------------------
function Allocator_Subtype_Indication (Expression : in Asis.Expression)
return Asis.Subtype_Indication
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Expression);
Arg_Node : Node_Id;
begin
Check_Validity (Expression,
"Asis.Expressions.Allocator_Subtype_Indication");
if not (Arg_Kind = An_Allocation_From_Subtype) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.Allocator_Subtype_Indication");
end if;
Arg_Node := Node (Expression);
return Node_To_Element (Node => Sinfo.Expression (Arg_Node),
Internal_Kind => A_Subtype_Indication,
In_Unit => Encl_Unit (Expression));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Expression,
Outer_Call => "Asis.Expressions.Allocator_Subtype_Indication");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Expression,
Diagnosis => "Asis.Expressions.Allocator_Subtype_Indication");
end Allocator_Subtype_Indication;
------------------------------------------------------------------------------
function Allocator_Qualified_Expression (Expression : in Asis.Expression)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Expression);
Arg_Node : Node_Id;
begin
Check_Validity (Expression,
"Asis.Expressions.Allocator_Qualified_Expression");
if not (Arg_Kind = An_Allocation_From_Qualified_Expression) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Expressions.Allocator_Qualified_Expression");
end if;
Arg_Node := Node (Expression);
return Node_To_Element (Node => Sinfo.Expression (Arg_Node),
In_Unit => Encl_Unit (Expression));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Expression,
Outer_Call => "Asis.Expressions.Allocator_Qualified_Expression");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Expression,
Diagnosis => "Asis.Expressions.Allocator_Qualified_Expression");
end Allocator_Qualified_Expression;
-----------------------------------------------------------------------------
end Asis.Expressions