File : asis-extensions.adb
------------------------------------------------------------------------------
-- --
-- ASIS-for-GNAT IMPLEMENTATION COMPONENTS --
-- --
-- A S I S . E X T E N 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.Exceptions;
with Ada.Characters.Handling; use Ada.Characters.Handling;
with System.Assertions;
with Asis.Exceptions; use Asis.Exceptions;
with Asis.Elements; use Asis.Elements;
with Asis.Compilation_Units; use Asis.Compilation_Units;
with Asis.Declarations; use Asis.Declarations;
with Asis.Statements; use Asis.Statements;
with Asis.Iterator; use Asis.Iterator;
with A4G.Queries; use A4G.Queries;
with Asis.Set_Get; use Asis.Set_Get;
with A4G.A_Types; use A4G.A_Types;
with A4G.A_Sem; use A4G.A_Sem;
with A4G.Contt; use A4G.Contt;
with A4G.Contt.UT; use A4G.Contt.UT;
with A4G.A_Debug; use A4G.A_Debug;
with A4G.C_U_Info; use A4G.C_U_Info;
with A4G.Int_Knds; use A4G.Int_Knds;
with A4G.Mapping; use A4G.Mapping;
with A4G.Vcheck; use A4G.Vcheck;
with Types; use Types;
with Sinfo; use Sinfo;
with Einfo; use Einfo;
with Atree; use Atree;
with Nlists; use Nlists;
with Output; use Output;
with Stand; use Stand;
with Snames; use Snames;
package body Asis.Extensions is
LT : String renames ASIS_Line_Terminator;
Package_Name : String := "Asis.Extensions.";
-----------------------
-- Local subprograms --
-----------------------
function Is_Typeless_Subaggregate (Aggr : Node_Id) return Boolean;
-- Checks if Aggr represents an inner typeless subaggregate of
-- multi-dimensional array subaggregate
function Is_Expanded_Subprogram (N : Node_Id) return Boolean;
-- Checks if N corresponds to the spec of an expanded generic
-- subprogram. Is needed because Comes_From_Source in this case is
-- set OFF (opposite to expanded packages)
------------------
-- Acts_As_Spec --
------------------
function Acts_As_Spec (Declaration : Asis.Element) return Boolean is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
begin
Arg_Node := Node (Declaration);
if Arg_Kind = A_Procedure_Body_Declaration or else
Arg_Kind = A_Function_Body_Declaration
then
return Acts_As_Spec (Arg_Node);
elsif Arg_Kind = A_Procedure_Body_Stub or else
Arg_Kind = A_Function_Body_Stub
then
-- return No (Corr_Decl_For_Stub (Arg_Node));
return not (
Ekind (Defining_Unit_Name (Specification (Arg_Node))) =
E_Subprogram_Body);
else
return False;
end if;
end Acts_As_Spec;
------------------------------
-- Compilation_Dependencies --
------------------------------
function Compilation_Dependencies
(Main_Unit : Asis.Compilation_Unit)
return Asis.Compilation_Unit_List
is
Arg_Kind : Asis.Unit_Kinds := Kind (Main_Unit);
Arg_Unit_Id : Unit_Id;
Res_Cont_Id : Context_Id;
begin
Check_Validity (Main_Unit, Package_Name & "Compilation_Dependencies");
if Arg_Kind not in A_Procedure .. A_Protected_Body_Subunit then
Raise_ASIS_Inappropriate_Compilation_Unit
(Diagnosis => Package_Name & "Compilation_Dependencies");
end if;
Res_Cont_Id := Encl_Cont_Id (Main_Unit);
Reset_Context (Res_Cont_Id);
Arg_Unit_Id := Get_Unit_Id (Main_Unit);
declare
Result_Id_List : Unit_Id_List renames
GNAT_Compilation_Dependencies (Res_Cont_Id, Arg_Unit_Id);
Result_List : Compilation_Unit_List renames
Get_Comp_Unit_List (Result_Id_List, Res_Cont_Id);
begin
if Is_Nil (Result_List) then
Raise_ASIS_Inappropriate_Compilation_Unit
(Diagnosis => Package_Name & "Compilation_Dependencies");
else
return Result_List;
end if;
end;
exception
when ASIS_Inappropriate_Compilation_Unit =>
raise;
when ASIS_Failed =>
Add_Call_Information
(Outer_Call => Package_Name & "Compilation_Dependencies");
raise;
when others =>
Raise_ASIS_Failed
(Diagnosis => Package_Name & "Compilation_Dependencies");
end Compilation_Dependencies;
----------------
-- Components --
----------------
function Components (E : Asis.Element) return Asis.Element_List is
Child_Access : Query_Array := Appropriate_Queries (E);
Result_Length : Integer := 0;
begin
if Is_Nil (E) then
return Nil_Element_List;
end if;
-- first, we compute the result's lenght:
for Each_Query in Child_Access'Range loop
case Child_Access (Each_Query).Query_Kind is
when Bug =>
null;
when Single_Element_Query =>
if not Is_Nil (Child_Access (Each_Query).Func_Simple (E)) then
Result_Length := Result_Length + 1;
end if;
when Element_List_Query =>
declare
Child_List : Asis.Element_List :=
Child_Access (Each_Query).Func_List (E);
begin
Result_Length := Result_Length + Child_List'Length;
end;
when Element_List_Query_With_Boolean =>
declare
Child_List : Asis.Element_List :=
Child_Access (Each_Query).Func_List_Boolean
(E, Child_Access (Each_Query).Bool);
begin
Result_Length := Result_Length + Child_List'Length;
end;
end case;
end loop;
-- and now, we define the result element list of Result_Length
-- lemgth and fill it in by repeating the same loop. This is
-- not effective, and this will have to be revised.
if Result_Length = 0 then
return Nil_Element_List;
end if;
declare
Result_List : Asis.Element_List (1 .. Result_Length);
Next_Element : Integer := 1;
begin
for Each_Query in Child_Access'Range loop
case Child_Access (Each_Query).Query_Kind is
when Bug =>
null;
when Single_Element_Query =>
if not Is_Nil
(Child_Access (Each_Query).Func_Simple (E)) then
Result_List (Next_Element) :=
Child_Access (Each_Query).Func_Simple (E);
Next_Element := Next_Element + 1;
end if;
when Element_List_Query =>
declare
Child_List : Asis.Element_List :=
Child_Access (Each_Query).Func_List (E);
begin
for I in Child_List'First .. Child_List'Last loop
Result_List (Next_Element) := Child_List (I);
Next_Element := Next_Element + 1;
end loop;
end;
when Element_List_Query_With_Boolean =>
declare
Child_List : Asis.Element_List :=
Child_Access (Each_Query).Func_List_Boolean
(E, Child_Access (Each_Query).Bool);
begin
for I in Child_List'First .. Child_List'Last loop
Result_List (Next_Element) := Child_List (I);
Next_Element := Next_Element + 1;
end loop;
end;
end case;
end loop;
return Result_List;
end;
exception
when ASIS_Failed =>
Add_Call_Information (
Argument => E,
Outer_Call => Package_Name & "Components");
raise;
when others =>
Raise_ASIS_Failed (
Argument => E,
Diagnosis => Package_Name & "Components");
end Components;
-----------------------------------------------
-- Corresponding_Body_Parameter_Definition --
-----------------------------------------------
function Corresponding_Body_Parameter_Definition
(Defining_Name : in Asis.Defining_Name)
return Asis.Defining_Name
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Defining_Name);
Encl_Constr : Asis.Element;
Encl_Constr_Kind : Internal_Element_Kinds;
Result : Asis.Element := Nil_Element;
begin
if Arg_Kind /= A_Defining_Identifier then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
Package_Name & "Corresponding_Body_Parameter_Definition");
end if;
Encl_Constr := Enclosing_Element (Enclosing_Element (Defining_Name));
Encl_Constr_Kind := Int_Kind (Encl_Constr);
case Encl_Constr_Kind is
when A_Procedure_Body_Declaration |
A_Function_Body_Declaration =>
Result := Defining_Name;
when A_Procedure_Body_Stub |
A_Function_Body_Stub =>
Encl_Constr := Corresponding_Subunit (Encl_Constr);
when A_Procedure_Declaration |
A_Function_Declaration |
A_Generic_Function_Declaration |
A_Generic_Procedure_Declaration =>
Encl_Constr := Corresponding_Body (Encl_Constr);
Encl_Constr_Kind := Int_Kind (Encl_Constr);
if Encl_Constr_Kind = A_Procedure_Body_Stub or else
Encl_Constr_Kind = A_Function_Body_Stub
then
Encl_Constr := Corresponding_Subunit (Encl_Constr);
end if;
when others =>
-- For all the other situations we can not return a parameter
-- definition in the body
Encl_Constr := Nil_Element;
end case;
if not Is_Nil (Result) or else Is_Nil (Encl_Constr) then
return Result;
end if;
Process_Parameter_Specifications : declare
Def_Name_Image : String
:= To_Lower (To_String (Defining_Name_Image (Defining_Name)));
Param_Specs : Asis.Element_List
:= Parameter_Profile (Encl_Constr);
begin
Through_Parameter_Specs : for I in Param_Specs'Range loop
Process_Parameter_Names : declare
Par_Names : Asis.Element_List := Names (Param_Specs (I));
begin
Through_Parameter_Names : for J in Par_Names'Range loop
if Def_Name_Image =
To_Lower (To_String (Defining_Name_Image
(Par_Names (J))))
then
Result := Par_Names (J);
exit Through_Parameter_Specs;
end if;
end loop Through_Parameter_Names;
end Process_Parameter_Names;
end loop Through_Parameter_Specs;
end Process_Parameter_Specifications;
pragma Assert (not Is_Nil (Result));
return Result;
exception
when Assert_Error : System.Assertions.Assert_Failure =>
Raise_ASIS_Failed (
Argument => Defining_Name,
Diagnosis => LT & Package_Name
& "Corresponding_Body_Parameter_Definition - " & LT
& "Assert_Failure at "
& Ada.Exceptions.Exception_Message (Assert_Error));
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Defining_Name,
Outer_Call =>
Package_Name & "Corresponding_Body_Parameter_Definition");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Defining_Name,
Diagnosis =>
Package_Name & "Corresponding_Body_Parameter_Definition");
end Corresponding_Body_Parameter_Definition;
------------------------------------------
-- Corresponding_Called_Entity_Unwinded --
------------------------------------------
function Corresponding_Called_Entity_Unwinded
(Statement : in Asis.Statement)
return Asis.Declaration
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
Arg_Node_Kind : Node_Kind;
Result_Node : Node_Id;
Result_Unit : Compilation_Unit;
Res_Spec_Case : Special_Cases := Not_A_Special_Case;
begin
Check_Validity (Statement,
Package_Name & "Corresponding_Called_Entity_Unwinded");
if not (Arg_Kind = An_Entry_Call_Statement or else
Arg_Kind = A_Procedure_Call_Statement)
then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
Package_Name & "Corresponding_Called_Entity_Unwinded");
end if;
-- the implementation approach is similar to the approach taken for
-- Asis.Expressions.Corresponding_Called_Function
Arg_Node := R_Node (Statement);
-- To be on the safe side, we use R_Node instead of Node, but it looks
-- like in this case R_Node and Node should be the same
Arg_Node_Kind := Nkind (Arg_Node);
case Arg_Node_Kind is
when N_Attribute_Reference =>
return Nil_Element;
-- call to a procedure-attribute
when N_Entry_Call_Statement | N_Procedure_Call_Statement =>
-- here we have to filter out the case when Nil_Element
-- should be returned for a call through access-to-function:
if Nkind (Sinfo.Name (Arg_Node)) = N_Explicit_Dereference then
return Nil_Element;
end if;
-- ??? <tree problem 4>
-- this fragment should be revised when the problem is fixed (as it should)
if Arg_Node_Kind = N_Entry_Call_Statement then
Result_Node := Sinfo.Name (Arg_Node);
-- Result_Node points to the name of the called entry
if Nkind (Result_Node) = N_Indexed_Component then
-- this is the case for a call to an entry from an
-- entry family
Result_Node := Prefix (Result_Node);
end if;
Result_Node := Entity (Selector_Name (Result_Node));
else
Result_Node := Entity (Sinfo.Name (Arg_Node));
-- only this assignment is needed if tree problem 4 is
-- fixed
end if;
-- ??? <tree problem 4> - end
when others =>
pragma Assert (False);
null;
end case;
Result_Node := Unwind_Renaming (Result_Node);
if No (Result_Node) then
-- renaming of a procedure-attribute
return Nil_Element;
end if;
if not Comes_From_Source (Result_Node) then
return Nil_Element;
end if;
Result_Unit := Enclosing_Unit (Encl_Cont_Id (Statement), Result_Node);
-- if not Is_Consistent (Result_Unit, Encl_Unit (Statement)) then
-- return Nil_Element;
-- end if;
-- And now - fro m a defining name to a declaration itself
Result_Node := Parent (Result_Node);
if Arg_Node_Kind = N_Procedure_Call_Statement then
Result_Node := Parent (Result_Node);
end if;
if Is_Expanded_Subprogram (Result_Node) then
Res_Spec_Case := Expanded_Subprogram_Instantiation;
end if;
return Node_To_Element_New
(Node => Result_Node,
Spec_Case => Res_Spec_Case,
In_Unit => Result_Unit);
exception
when Assert_Error : System.Assertions.Assert_Failure =>
Raise_ASIS_Failed (
Argument => Statement,
Diagnosis => LT & Package_Name
& "Corresponding_Called_Entity_Unwinded - " & LT
& "Assert_Failure at "
& Ada.Exceptions.Exception_Message (Assert_Error));
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Outer_Call =>
Package_Name & "Corresponding_Called_Entity_Unwinded");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Diagnosis =>
Package_Name & "Corresponding_Called_Entity_Unwinded");
end Corresponding_Called_Entity_Unwinded;
--------------------------------------------
-- Corresponding_Called_Function_Unwinded --
--------------------------------------------
function Corresponding_Called_Function_Unwinded
(Expression : in Asis.Expression)
return Asis.Declaration
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Expression);
Arg_Node : Node_Id;
Arg_Node_Kind : Node_Kind;
Result_Node : Node_Id;
Result_Unit : Compilation_Unit;
Res_Spec_Case : Special_Cases := Not_A_Special_Case;
begin
Check_Validity (Expression,
Package_Name & "Corresponding_Called_Function_Unwinded");
if not (Arg_Kind = A_Function_Call) then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
Package_Name & "Corresponding_Called_Function_Unwinded");
end if;
-- first, we have to filter out the cases when a Nil_Element
-- should be returned. For now, these cases include:
--
-- - calls to functions-attributes;
-- - all forms of calls to predefined operators;
-- - all forms of calls to inherited functions
--
-- We hope to implement the last case in future...
-- First, we try the simplest approach, and then we will add patchs
-- if needed:
Arg_Node := R_Node (Expression);
Arg_Node_Kind := Nkind (Arg_Node);
-- Rewritten node should know everything. But if this node is the
-- result of compile-time optimisation, we have to work with
-- original node only:
if Arg_Node_Kind = N_String_Literal or else
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_Raise_Constraint_Error or else
Arg_Node_Kind = N_Identifier
then
Arg_Node := Node (Expression);
Arg_Node_Kind := Nkind (Arg_Node);
end if;
case Arg_Node_Kind is
when N_Attribute_Reference =>
return Nil_Element;
when N_Function_Call =>
-- here we have to filter out the case when Nil_Element
-- should be returned for a call through access-to-function:
if Nkind (Sinfo.Name (Arg_Node)) = N_Explicit_Dereference then
return Nil_Element;
else
Result_Node := Entity (Sinfo.Name (Arg_Node));
end if;
when N_Op =>
-- all the predefined operations (??)
Result_Node := Entity (Arg_Node);
when others =>
pragma Assert (False);
null;
end case;
-- here we have Result_Node pointed to the defininhg occurence of
-- the corresponding caled function. Three things should be done:
-- 1. If Result_Node is defined in a renaming definition, we have
-- to unwind all the renamings till the defining occurence of
-- the corresponding callable entity will be riched;
-- 2. If a given callable entity is implicitly defined, Nil_Element
-- should be returned;
-- 3. We have to come from a definng name to the correcponding
-- declaration and then we should return the Element
-- corresponding to this declaration
Result_Node := Unwind_Renaming (Result_Node);
if No (Result_Node) then
-- renaming of a function-attribute
return Nil_Element;
end if;
-- here we have Result_Node pointing to the defining occurence of the
-- name of the corresponding called function. First, we have to
-- filter out implicitly declared functions:
if not Comes_From_Source (Result_Node) then
return Nil_Element;
end if;
Result_Unit := Enclosing_Unit (Encl_Cont_Id (Expression), Result_Node);
-- if not Is_Consistent (Result_Unit, Encl_Unit (Expression)) then
-- return Nil_Element;
-- end if;
Result_Node := Parent (Parent (Result_Node));
-- to go from a defining name to a declaration itself
if Is_Expanded_Subprogram (Result_Node) then
Res_Spec_Case := Expanded_Subprogram_Instantiation;
end if;
return Node_To_Element_New
(Node => Result_Node,
Spec_Case => Res_Spec_Case,
In_Unit => Result_Unit);
exception
when Assert_Error : System.Assertions.Assert_Failure =>
Raise_ASIS_Failed (
Argument => Expression,
Diagnosis => LT & Package_Name
& "Corresponding_Called_Function_Unwinded - " & LT
& "Assert_Failure at "
& Ada.Exceptions.Exception_Message (Assert_Error));
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Expression,
Outer_Call =>
Package_Name & "Corresponding_Called_Function_Unwinded");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Expression,
Diagnosis =>
Package_Name & "Corresponding_Called_Function_Unwinded");
end Corresponding_Called_Function_Unwinded;
------------------------------------
-- Corresponding_First_Definition --
------------------------------------
function Corresponding_First_Definition
(Defining_Name : in Asis.Defining_Name)
return Asis.Defining_Name
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Defining_Name);
Is_Parameter : Boolean := False;
Encl_Constr : Asis.Element;
Encl_Constr_Kind : Internal_Element_Kinds;
First_Declaration : Asis.Element;
Result : Asis.Element := Nil_Element;
begin
if Arg_Kind not in Internal_Defining_Name_Kinds then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
Package_Name & "Corresponding_First_Definition");
end if;
Encl_Constr := Enclosing_Element (Defining_Name);
if Int_Kind (Encl_Constr) = A_Parameter_Specification then
Encl_Constr := Enclosing_Element (Encl_Constr);
Is_Parameter := True;
end if;
Encl_Constr_Kind := Int_Kind (Encl_Constr);
case Encl_Constr_Kind is
when A_Procedure_Body_Declaration |
A_Function_Body_Declaration |
A_Function_Renaming_Declaration |
A_Procedure_Renaming_Declaration |
A_Procedure_Body_Stub |
A_Function_Body_Stub =>
if ((Encl_Constr_Kind = A_Procedure_Body_Declaration or else
Encl_Constr_Kind = A_Function_Body_Declaration or else
Encl_Constr_Kind = A_Procedure_Body_Stub or else
Encl_Constr_Kind = A_Function_Body_Stub)
and then (not (Acts_As_Spec (Encl_Constr))))
or else
((Encl_Constr_Kind = A_Function_Renaming_Declaration or else
Encl_Constr_Kind = A_Procedure_Renaming_Declaration)
and then Is_Renaming_As_Body (Encl_Constr))
then
-- there should be a corresponding spec where the first
-- definition should be:
if Is_Subunit (Encl_Constr) then
Encl_Constr := Corresponding_Body_Stub (Encl_Constr);
end if;
First_Declaration := Corresponding_Declaration (Encl_Constr);
if not Is_Parameter then
-- just returning a defining name from a declaration,
-- otherwise Result will remain nil, and we will have
-- to process the case of a formal parameter after this
-- case statement
Result := Names (First_Declaration) (1);
end if;
else
Result := Defining_Name;
end if;
when A_Package_Body_Declaration |
A_Task_Body_Declaration |
A_Protected_Body_Declaration |
A_Package_Body_Stub |
A_Task_Body_Stub |
A_Protected_Body_Stub |
An_Entry_Body_Declaration =>
First_Declaration := Corresponding_Declaration (Encl_Constr);
if not Is_Parameter then
Result := Names (First_Declaration) (1);
end if;
when An_Accept_Statement =>
First_Declaration := Corresponding_Entry (Encl_Constr);
when An_Ordinary_Type_Declaration =>
Result := Corresponding_Type_Declaration (Encl_Constr);
if Is_Nil (Result) then
-- Encl_Constr is not a completion of an incomplete or
-- private type declaration
Result := Defining_Name;
else
Result := Names (Result) (1);
end if;
when others =>
Result := Defining_Name;
end case;
if Is_Nil (Result) then
-- here we have to compute the first definition of the formal
-- parameter in a subprogram spec/entry declaration
Process_Parameter_Specifications : declare
Def_Name_Image : String
:= To_Lower (To_String (Defining_Name_Image (Defining_Name)));
Param_Specs : Asis.Element_List
:= Parameter_Profile (First_Declaration);
begin
Through_Parameter_Specs : for I in Param_Specs'Range loop
Process_Parameter_Names : declare
Par_Names : Asis.Element_List := Names (Param_Specs (I));
begin
Through_Parameter_Names : for J in Par_Names'Range loop
if Def_Name_Image =
To_Lower (To_String (Defining_Name_Image
(Par_Names (J))))
then
Result := Par_Names (J);
exit Through_Parameter_Specs;
end if;
end loop Through_Parameter_Names;
end Process_Parameter_Names;
end loop Through_Parameter_Specs;
end Process_Parameter_Specifications;
end if;
pragma Assert (not Is_Nil (Result));
return Result;
exception
when Assert_Error : System.Assertions.Assert_Failure =>
Raise_ASIS_Failed (
Argument => Defining_Name,
Diagnosis => LT & Package_Name
& "Corresponding_First_Definition - " & LT
& "Assert_Failure at "
& Ada.Exceptions.Exception_Message (Assert_Error));
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Defining_Name,
Outer_Call => Package_Name & "Corresponding_First_Definition");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Defining_Name,
Diagnosis => Package_Name & "Corresponding_First_Definition");
end Corresponding_First_Definition;
-------------------------------
-- Element_Image_In_Template --
-------------------------------
function Element_Image_In_Template
(Element : in Asis.Element)
return Program_Text
is
Tmp_Element : Asis.Element := Element;
begin
if Is_Part_Of_Implicit (Element) or else
not Is_Part_Of_Instance (Element)
then
return "";
else
-- What we are doing is tricky, but it gives the fast and
-- easy-to-maintain solution: we consider the argument as if it is
-- NOT from the expanded template, and we use the normal ASIS
-- Element_Span function for it. The idea is to use Sloc fields
-- from the element node which point to the corresponding positions
-- in the template.
Set_From_Instance (Tmp_Element, False);
return Element_Image (Tmp_Element);
end if;
exception
when ASIS_Failed =>
Add_Call_Information (
Argument => Element,
Outer_Call => Package_Name & "Element_Image_In_Template");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Element,
Diagnosis => Package_Name & "Element_Image_In_Template");
end Element_Image_In_Template;
------------------------------
-- Element_Span_In_Template --
------------------------------
function Element_Span_In_Template
(Element : in Asis.Element)
return Asis.Text.Span
is
Tmp_Element : Asis.Element := Element;
begin
if Is_Part_Of_Implicit (Element) or else
not Is_Part_Of_Instance (Element)
then
return Nil_Span;
else
-- What we are doing is tricky, but it gives the fast and
-- easy-to-maintain solution: we consider the argument as if it is
-- NOT from the expanded template, and we use the normal ASIS
-- Element_Span function for it. The idea is to use Sloc fields
-- from the element node which point to the corresponding positions
-- in the template.
Set_From_Instance (Tmp_Element, False);
return Element_Span (Tmp_Element);
end if;
exception
when ASIS_Failed =>
Add_Call_Information (
Argument => Element,
Outer_Call => Package_Name & "Element_Span_In_Template");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Element,
Diagnosis => Package_Name & "Element_Span_In_Template");
end Element_Span_In_Template;
-------------------------------
-- Formal_Subprogram_Default --
-------------------------------
function Formal_Subprogram_Default
(Declaration : in Asis.Generic_Formal_Parameter)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
begin
Arg_Node := Node (Declaration);
Check_Validity (Declaration, Package_Name & "Formal_Subprogram_Default");
if not (Arg_Kind = A_Formal_Procedure_Declaration or else
Arg_Kind = A_Formal_Function_Declaration)
then
Raise_ASIS_Inappropriate_Element
(Package_Name & "Formal_Subprogram_Default");
end if;
if not Present (Default_Name (Arg_Node)) then
return Nil_Element;
end if;
return Node_To_Element (Node => Default_Name (Arg_Node),
In_Unit => Encl_Unit (Declaration));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => Package_Name & "Formal_Subprogram_Default");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => Package_Name & "Formal_Subprogram_Default");
end Formal_Subprogram_Default;
------------------------
-- Get_Last_Component --
------------------------
function Get_Last_Component (E : Asis.Element) return Asis.Element is
Child_Access : Query_Array := Appropriate_Queries (E);
Child : Asis.Element := Asis.Nil_Element;
begin
if Debug_Flag_X then
Write_Str (" Get_Last_Component - called for ");
Write_Str (Internal_Element_Kinds'Image (Int_Kind (E)));
Write_Eol;
end if;
for Each_Query in reverse Child_Access'Range loop
case Child_Access (Each_Query).Query_Kind is
when Bug =>
null;
when Single_Element_Query =>
Child := Child_Access (Each_Query).Func_Simple (E);
when Element_List_Query =>
declare
Child_List : Asis.Element_List :=
Child_Access (Each_Query).Func_List (E);
begin
if not Is_Nil (Child_List) then
Child := Child_List (Child_List'Last);
end if;
end;
when Element_List_Query_With_Boolean =>
declare
Child_List : Asis.Element_List :=
Child_Access (Each_Query).Func_List_Boolean
(E, Child_Access (Each_Query).Bool);
begin
if not Is_Nil (Child_List) then
Child := Child_List (Child_List'Last);
end if;
end;
end case;
exit when not Is_Nil (Child);
end loop;
if Debug_Flag_X then
Write_Str (" Get_Last_Component - returns ");
Write_Str (Internal_Element_Kinds'Image (Int_Kind (Child)));
Write_Eol;
end if;
return Child;
exception
when ASIS_Failed =>
Add_Call_Information (
Argument => E,
Outer_Call => Package_Name & "Get_Last_Component");
raise;
when others =>
Raise_ASIS_Failed (
Argument => E,
Diagnosis => Package_Name & "Get_Last_Component");
end Get_Last_Component;
------------------
-- Is_Completed --
------------------
function Is_Completed (Declaration : Asis.Element) return Boolean
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
Result : Boolean := False;
begin
-- JUNK IMPLEMENTATION!!!
if not (Arg_Kind = A_Procedure_Declaration or else
Arg_Kind = A_Function_Declaration)
or else
Is_Part_Of_Inherited (Declaration)
then
return False;
end if;
Arg_Node := Defining_Unit_Name (Specification (Node (Declaration)));
Result := Has_Completion (Arg_Node);
return Result;
end Is_Completed;
----------------------------
-- Is_Expanded_Subprogram --
----------------------------
function Is_Expanded_Subprogram (N : Node_Id) return Boolean is
Result : Boolean := False;
begin
if Nkind (N) = N_Subprogram_Declaration and then
Is_Generic_Instance (Defining_Unit_Name (Specification (N)))
then
Result := True;
end if;
return Result;
end Is_Expanded_Subprogram;
--------------------------
-- Is_Main_Unit_In_Tree --
--------------------------
function Is_Main_Unit_In_Tree
(Right : Asis.Compilation_Unit)
return Boolean
is
Arg_Kind : Unit_Kinds := Kind (Right);
Arg_Unit_Id : Unit_Id;
Arg_Cont_Id : Context_Id;
begin
Check_Validity (Right, Package_Name & "Is_Main_Unit_In_Tree");
Arg_Cont_Id := Encl_Cont_Id (Right);
Reset_Context (Arg_Cont_Id);
Arg_Unit_Id := Get_Unit_Id (Right);
if Arg_Kind in A_Procedure .. A_Protected_Body_Subunit then
return GNAT_Compilation_Dependencies (Arg_Cont_Id, Arg_Unit_Id) /=
Nil_Unit_Id_List;
else
return False;
end if;
end Is_Main_Unit_In_Tree;
-----------------
-- Is_Obsolete --
-----------------
function Is_Obsolete (Right : Asis.Compilation_Unit) return Boolean
is
Arg_Kind : Unit_Kinds := Kind (Right);
Arg_Id : Unit_Id;
Result : Boolean := True;
begin
case Arg_Kind is
when Not_A_Unit |
A_Nonexistent_Declaration |
A_Nonexistent_Body |
An_Unknown_Unit =>
Result := Result;
when others =>
Arg_Id := Get_Unit_Id (Right);
if Arg_Id = Standard_Id then
Result := False;
else
Result := not (Source_Status (Right) = Up_To_Date);
end if;
end case;
return Result;
end Is_Obsolete;
----------------------------
-- Is_Primitive_Operation --
----------------------------
function Is_Primitive_Operation
(Declaration : Asis.Element)
return Boolean
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
begin
-- ??? NOT IMPLEMENTED
if not (Arg_Kind = A_Procedure_Declaration or else
Arg_Kind = A_Function_Declaration or else
Arg_Kind = A_Procedure_Renaming_Declaration or else
Arg_Kind = A_Function_Renaming_Declaration)
then
return False;
end if;
Not_Implemented_Yet
(Diagnosis => Package_Name & "Is_Primitive_Operation");
end Is_Primitive_Operation;
-------------------------
-- Is_Renaming_As_Body --
-------------------------
function Is_Renaming_As_Body (Declaration : Asis.Element) return Boolean is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
begin
if not (Arg_Kind = A_Procedure_Renaming_Declaration or else
Arg_Kind = A_Function_Renaming_Declaration)
then
return False;
end if;
Arg_Node := Node (Declaration);
return Present (Corresponding_Spec (Arg_Node));
end Is_Renaming_As_Body;
---------------
-- Is_Static --
---------------
function Is_Static (Expression : Asis.Expression) return Boolean is
Result : Boolean := False;
begin
if Is_True_Expression (Expression) then
Result := Sinfo.Is_Static_Expression (R_Node (Expression));
end if;
return Result;
end Is_Static;
------------------------
-- Is_True_Expression --
------------------------
function Is_True_Expression
(Expression : Asis.Expression)
return Boolean
is
Arg_Node : Node_Id := Node (Expression);
Arg_Kind : Internal_Element_Kinds := Int_Kind (Expression);
Expr_Chars : Name_Id;
Entity_Node : Entity_Id;
Result : Boolean := True;
-- the idea of the implementation is to find out the cases when
-- Expression is NOT a true exception, so we initialize Result
-- as True
begin
if Arg_Kind not in Internal_Expression_Kinds then
return False;
end if;
if Nkind (Arg_Node) not in N_Has_Etype or else
No (Etype (Arg_Node)) or else
Ekind (Etype (Arg_Node)) = E_Anonymous_Access_Type or else
Ekind (Etype (Arg_Node)) = E_Subprogram_Type
then
-- Expression may be a true expression, but it may have a type which
-- cannot be represented in ASIS (such as an anonymous access type),
-- in such cases we also classify it as being not true expression
Result := False;
else
-- in some cases more detailed analysis is required.
-- ??? This part may require some more analysis - it may be
-- somewhat redundant
case Arg_Kind is
when An_Identifier | A_Selected_Component =>
-- and here we have to investigate whether or not this
-- Expression is a "naming expression"
if Nkind (Arg_Node) = N_Identifier and then
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;
-- ??? <tree problem 1>
-- this fragment should be revised when the problem is fixed (as it should)
if Nkind (Arg_Node) = N_Selected_Component and then
Etype (Arg_Node) = Any_Type
-- 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; the problem is that the
-- Entity field is not set for such a node
then
return True;
end if;
-- ??? <tree problem 1> - end
-- now taking the Entity field (if any) and looking,
-- what we have:
if Nkind (Arg_Node) = N_Selected_Component then
Entity_Node := Entity (Selector_Name (Arg_Node));
elsif Nkind (Arg_Node) = N_Attribute_Definition_Clause then
-- the attribute designator in an attribute definition
-- clause
Entity_Node := Empty;
else
Entity_Node := Entity (Arg_Node);
end if;
if No (Entity_Node) then
Result := False;
elsif Ekind (Entity_Node) = E_Enumeration_Literal then
null;
else
case Ekind (Entity_Node) is
-- the first choice in this case statement should
-- filter in entities which *ARE* expressions in Ada
-- sense
when E_Variable =>
-- tasks and protected objects declared by _single_
-- task/protected declarations do not have
-- corresponding type declarations which can be
-- represented in ASIS
Result := Comes_From_Source (Parent (Entity_Node));
when E_Component .. E_Named_Real |
-- variables and constants (including formal
-- parameters and generic formal parameters
E_Enumeration_Literal | -- ??? (see elsif path)
-- enumeration literals are not treated as functions
-- in ASIS
E_Entry_Index_Parameter |
E_Protected_Object =>
null;
-- simply keeping the initialization of Result
when others =>
Result := False;
end case;
end if;
when Internal_Operator_Symbol_Kinds =>
Result := False;
when Internal_Attribute_Reference_Kinds =>
case Internal_Attribute_Reference_Kinds (Arg_Kind) is
when An_Adjacent_Attribute |
A_Base_Attribute |
A_Ceiling_Attribute |
A_Class_Attribute |
A_Compose_Attribute |
A_Copy_Sign_Attribute |
An_Exponent_Attribute |
A_Floor_Attribute |
A_Fraction_Attribute |
An_Image_Attribute |
An_Input_Attribute |
A_Leading_Part_Attribute |
A_Machine_Attribute |
A_Max_Attribute |
A_Min_Attribute |
A_Model_Attribute |
An_Output_Attribute |
A_Pos_Attribute |
A_Pred_Attribute |
A_Range_Attribute |
A_Read_Attribute |
A_Remainder_Attribute |
A_Round_Attribute |
A_Rounding_Attribute |
A_Scaling_Attribute |
A_Succ_Attribute |
A_Truncation_Attribute |
An_Unbiased_Rounding_Attribute |
A_Val_Attribute |
A_Value_Attribute |
A_Wide_Image_Attribute |
A_Wide_Value_Attribute |
A_Write_Attribute =>
Result := False;
when An_Implementation_Defined_Attribute =>
Expr_Chars := Attribute_Name (Arg_Node);
if Expr_Chars = Name_Abort_Signal or else
Expr_Chars = Name_Elab_Body or else
Expr_Chars = Name_Elab_Spec
then
Result := False;
end if;
when others =>
null;
end case;
when A_Positional_Array_Aggregate | A_Named_Array_Aggregate =>
if Nkind (Parent (Arg_Node)) =
N_Enumeration_Representation_Clause
or else
Is_Typeless_Subaggregate (Arg_Node)
then
Result := False;
end if;
when others =>
null;
end case;
end if;
return Result;
exception
when others =>
Raise_ASIS_Failed (
Argument => Expression,
Diagnosis => "A4G.Expr_Sem.Is_True_Expression");
end Is_True_Expression;
------------------------------
-- Is_Typeless_Subaggregate --
------------------------------
function Is_Typeless_Subaggregate (Aggr : Node_Id) return Boolean is
Parent_Node : Node_Id := Parent (Aggr);
Result : Boolean := False;
begin
if Nkind (Parent_Node) = N_Component_Association then
Parent_Node := Parent (Parent_Node);
end if;
if Nkind (Parent_Node) = N_Aggregate then
if No (Etype (Parent_Node)) or else
Ekind (Etype (Parent_Node)) = E_Array_Subtype
then
Result := True;
end if;
end if;
return Result;
end Is_Typeless_Subaggregate;
-----------
-- No_Op --
-----------
procedure No_Op
(Element : in Asis.Element;
Control : in out Traverse_Control;
State : in out No_State)
is
begin
null;
end No_Op;
-------------------
-- Primary_Owner --
-------------------
function Primary_Owner
(Declaration : Asis.Declaration)
return Asis.Declaration
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
begin
if not (Arg_Kind = A_Procedure_Declaration or else
Arg_Kind = A_Function_Declaration or else
Arg_Kind = A_Procedure_Renaming_Declaration or else
Arg_Kind = A_Function_Renaming_Declaration)
then
Raise_ASIS_Inappropriate_Element
(Package_Name & "Primary_Owner");
end if;
return Nil_Element;
Not_Implemented_Yet
(Diagnosis => Package_Name & "Primary_Owner");
-- exception
-- when ASIS_Failed =>
-- Add_Call_Information (
-- Argument => E,
-- Outer_Call => Package_Name & "Primary_Owner");
-- raise;
-- when others =>
-- Raise_ASIS_Failed (
-- Argument => E,
-- Diagnosis => Package_Name & "Primary_Owner");
end Primary_Owner;
------------------------
-- Source_File_Status --
------------------------
function Source_File_Status
(Right : Asis.Compilation_Unit)
return Source_File_Statuses
is
Arg_Kind : Unit_Kinds := Kind (Right);
Result : Source_File_Statuses;
begin
case Arg_Kind is
when Not_A_Unit |
A_Nonexistent_Declaration |
A_Nonexistent_Body |
An_Unknown_Unit =>
Result := Absent;
when others =>
Result := Source_Status (Right);
end case;
return Result;
end Source_File_Status;
-------------------
-- Traverse_Unit --
-------------------
procedure Traverse_Unit
(Unit : in Asis.Compilation_Unit;
Control : in out Traverse_Control;
State : in out State_Information)
is
Arg_Kind : Unit_Kinds := Unit_Kind (Unit);
procedure Process_Element is new Asis.Iterator.Traverse_Element
(State_Information => State_Information,
Pre_Operation => Pre_Operation,
Post_Operation => Post_Operation);
begin
if not (Arg_Kind in A_Procedure .. A_Protected_Body_Subunit) then
Raise_ASIS_Inappropriate_Compilation_Unit (Diagnosis =>
Package_Name & "Traverse_Unit");
end if;
declare
Cont_Clause_Elements : Element_List :=
Asis.Elements.Context_Clause_Elements
(Compilation_Unit => Unit,
Include_Pragmas => True);
Unit_Element : Asis.Element := Asis.Elements.Unit_Declaration (Unit);
begin
for I in Cont_Clause_Elements'Range loop
Process_Element (Cont_Clause_Elements (I), Control, State);
end loop;
Process_Element (Unit_Element, Control, State);
end;
exception
when ASIS_Inappropriate_Compilation_Unit =>
raise;
when ASIS_Inappropriate_Context |
ASIS_Inappropriate_Container |
ASIS_Inappropriate_Element |
ASIS_Inappropriate_Line |
ASIS_Inappropriate_Line_Number |
ASIS_Failed
=>
Add_Call_Information (Outer_Call => Package_Name & "Traverse_Unit");
raise;
when Storage_Error =>
Raise_ASIS_Failed (Diagnosis => Package_Name & "Traverse_Unit");
when others =>
Raise_ASIS_Failed (Diagnosis => Package_Name & "Traverse_Unit");
end Traverse_Unit;
end Asis.Extensions