File : asis-elements.adb
------------------------------------------------------------------------------
-- --
-- ASIS-for-GNAT IMPLEMENTATION COMPONENTS --
-- --
-- A S I S . E L E M E N T 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 System.Assertions;
with Ada.Exceptions;
with Asis.Exceptions; use Asis.Exceptions;
with Asis.Declarations;
with Asis.Definitions;
with Asis.Statements;
with Asis.Clauses;
with Asis.Set_Get; use Asis.Set_Get;
with A4G.Knd_Conv; use A4G.Knd_Conv;
with A4G.Int_Knds; use A4G.Int_Knds;
with A4G.Mapping; use A4G.Mapping;
with A4G.Vcheck; use A4G.Vcheck;
with A4G.Encl_El; use A4G.Encl_El;
with A4G.A_Sinput; use A4G.A_Sinput;
with A4G.A_Output; use A4G.A_Output;
with A4G.Contt; use A4G.Contt;
with A4G.Contt.UT; use A4G.Contt.UT;
with Types; use Types;
with Sinfo; use Sinfo;
with Atree; use Atree;
with Stand; use Stand;
with Snames; use Snames;
with Nlists; use Nlists;
package body Asis.Elements is
-- !!!??? This file is '-gnatg-compilable', but both its content and its
-- !!!??? documentation need revising
function "=" (Left, Right : Element) return Boolean
renames Asis.Set_Get."=";
------------------------------------------------------------------------------
LT : String renames ASIS_Line_Terminator;
function Unit_Declaration
(Compilation_Unit : in Asis.Compilation_Unit)
return Asis.Declaration
is
Unit_Kind : Asis.Unit_Kinds;
Unit_Declaration_Node : Node_Id;
Special_Case : Special_Cases := Not_A_Special_Case;
begin
Check_Validity (Compilation_Unit,
"Asis.Elements.Unit_Declaration");
Reset_Context (Encl_Cont_Id (Compilation_Unit));
Unit_Kind := Kind (Compilation_Unit);
if Unit_Kind = Not_A_Unit then
Raise_ASIS_Inappropriate_Compilation_Unit
("Asis.Elements.Unit_Declaration");
end if;
if Unit_Kind = A_Nonexistent_Declaration or else
Unit_Kind = A_Nonexistent_Body or else
Unit_Kind = An_Unknown_Unit
then
return Nil_Element;
end if;
if Is_Standard (Compilation_Unit) then
Special_Case := Explicit_From_Standard;
Unit_Declaration_Node := Standard_Package_Node;
else
Unit_Declaration_Node := Unit (Top (Compilation_Unit));
end if;
if Unit_Kind = A_Procedure_Body_Subunit or else
Unit_Kind = A_Function_Body_Subunit or else
Unit_Kind = A_Package_Body_Subunit or else
Unit_Kind = A_Task_Body_Subunit or else
Unit_Kind = A_Protected_Body_Subunit
then
-- one step down the tree is required.
-- No Asis Element can correspond to
-- the N_Subunit Node
Unit_Declaration_Node := Proper_Body (Unit_Declaration_Node);
end if;
return Node_To_Element_New (Node => Unit_Declaration_Node,
Spec_Case => Special_Case,
In_Unit => Compilation_Unit);
exception
when ASIS_Inappropriate_Compilation_Unit =>
raise;
when ASIS_Failed =>
Add_Call_Information (Outer_Call =>
"Asis.Elements.Unit_Declaration");
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
"Asis.Elements.Unit_Declaration");
end Unit_Declaration;
-----------------------------------------------------------------------------
function Enclosing_Compilation_Unit (Element : in Asis.Element)
return Asis.Compilation_Unit
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Element);
begin
Check_Validity (Element,
"Asis.Elements.Enclosing_Compilation_Unit");
if Arg_Kind = Not_An_Element then
Raise_ASIS_Inappropriate_Element
("Asis.Elements.Enclosing_Compilation_Unit");
end if;
return Encl_Unit (Element);
end Enclosing_Compilation_Unit;
-----------------------------------------------------------------------------
function Context_Clause_Elements
(Compilation_Unit : in Asis.Compilation_Unit;
Include_Pragmas : in Boolean := False)
return Asis.Context_Clause_List
is
Unit_Kind : Asis.Unit_Kinds; -- Compilation_Unit kind
List_Before : List_Id;
begin
Check_Validity (Compilation_Unit,
"Asis.Elements.Context_Clause_Elements");
Unit_Kind := Kind (Compilation_Unit);
if Unit_Kind = Not_A_Unit then
Raise_ASIS_Inappropriate_Compilation_Unit
("Asis.Elements.Context_Clause_Elements");
end if;
if Is_Standard (Compilation_Unit) or else
Unit_Kind = A_Nonexistent_Declaration or else
Unit_Kind = A_Nonexistent_Body or else
Unit_Kind = An_Unknown_Unit
then
return Nil_Element_List;
end if;
List_Before := Context_Items (Top (Compilation_Unit));
-- if Include_Pragmas then
-- return Node_To_Element_List (List => List_Before,
-- In_Unit => Compilation_Unit);
-- else
-- return Node_To_Element_List (List => List_Before,
-- In_Unit => Compilation_Unit,
-- To_Be_Included => No_Pragma'Access);
-- end if;
return N_To_E_List_New
(List => List_Before,
Include_Pragmas => Include_Pragmas,
In_Unit => Compilation_Unit);
exception
when ASIS_Inappropriate_Compilation_Unit =>
raise;
when ASIS_Failed =>
Add_Call_Information (Outer_Call =>
"Asis.Elements.Context_Clause_Elements");
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
"Asis.Elements.Context_Clause_Elements");
end Context_Clause_Elements;
------------------------------------------------------------------------------
-- NOT IMPLEMENTED
function Configuration_Pragmas
(The_Context : in Asis.Context)
return Asis.Pragma_Element_List
is
begin
Check_Validity (The_Context,
"Asis.Elements.Configuration_Pragmas");
return Nil_Element_List;
exception
when ASIS_Inappropriate_Context =>
raise;
when ASIS_Failed =>
Add_Call_Information (Outer_Call =>
"Asis.Elements.Configuration_Pragmas");
raise;
when others =>
Raise_ASIS_Failed (
"Asis.Elements.Configuration_Pragmas");
end Configuration_Pragmas;
-----------------------------------------------------------------------------
function Compilation_Pragmas (Compilation_Unit : in Asis.Compilation_Unit)
return Asis.Pragma_Element_List
is
Unit_Kind : Asis.Unit_Kinds;
List_Before : List_Id;
List_After : List_Id;
begin
Check_Validity (Compilation_Unit,
"Asis.Elements.Compilation_Pragmas");
Unit_Kind := Kind (Compilation_Unit);
if Unit_Kind = Not_A_Unit then
Raise_ASIS_Inappropriate_Compilation_Unit
("Asis.Elements.Compilation_Pragmas");
end if;
if Is_Standard (Compilation_Unit) or else
Unit_Kind = A_Nonexistent_Declaration or else
Unit_Kind = A_Nonexistent_Body or else
Unit_Kind = An_Unknown_Unit
then
return Nil_Element_List;
end if;
List_Before := Context_Items (Top (Compilation_Unit));
List_After := Pragmas_After (Top (Compilation_Unit));
return Node_To_Element_List (
List => List_Before,
In_Unit => Compilation_Unit,
To_Be_Included => Only_Pragmas'Access)
&
Node_To_Element_List (
List => List_After,
In_Unit => Compilation_Unit);
exception
when ASIS_Inappropriate_Compilation_Unit =>
raise;
when ASIS_Failed =>
Add_Call_Information (Outer_Call =>
"Asis.Elements.Compilation_Pragmas");
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
"Asis.Elements.Compilation_Pragmas");
end Compilation_Pragmas;
------------------------------------------------------------------------------
function Element_Kind (Element : in Asis.Element)
return Asis.Element_Kinds is
begin
Check_Validity (Element, "Asis.Elements.Element_Kind");
return Kind (Element);
end Element_Kind;
-----------------------------------------------------------------------------
function Pragma_Kind (Pragma_Element : Asis.Pragma_Element)
return Asis.Pragma_Kinds is
begin
Check_Validity (Pragma_Element, "Asis.Elements.Pragma_Kind");
return Pragma_Kind_From_Internal (Int_Kind (Pragma_Element));
end Pragma_Kind;
-----------------------------------------------------------------------------
function Defining_Name_Kind (Defining_Name : in Asis.Defining_Name)
return Asis.Defining_Name_Kinds is
begin
Check_Validity (Defining_Name, "Asis.Elements.Defining_Name_Kind");
return Defining_Name_Kind_From_Internal (Int_Kind (Defining_Name));
end Defining_Name_Kind;
-----------------------------------------------------------------------------
function Declaration_Kind (Declaration : in Asis.Declaration)
return Asis.Declaration_Kinds is
begin
Check_Validity (Declaration, "Asis.Elements.Declaration_Kind");
return Declaration_Kind_From_Internal (Int_Kind (Declaration));
end Declaration_Kind;
-----------------------------------------------------------------------------
function Trait_Kind (Element : in Asis.Element)
return Asis.Trait_Kinds is
-- Trait-related flag values:
Is_Abstract : Boolean;
Is_Limited : Boolean;
Is_Aliased : Boolean;
Is_Private : Boolean;
Arg_Node : Node_Id;
Trait_Defining_Node : Node_Id;
-- if the Node (Elemen) is not enough for defining the result,
-- Trait_Defining_Node is used for the tree traversing
begin
Check_Validity (Element, "Asis.Elements.Trait_Kind");
-- ASIS_Element_Kinds.Trait_Kinds literals and GNAT tree flags mapping:
--
-- type Trait_Kinds is (
--
-- Not_A_Trait, --> Unexpected element, its node always has no
-- -- correcponding flags and its kind does not belong
-- -- to the Node Kinds for which A_Private_Trait could
-- -- be determined
--
-- An_Ordinary_Trait, --> all flags are set off, and the node kind
-- does not belong to the Node Kinds for which
-- A_Private_Trait could be determined
--
-- An_Aliased_Trait, --> Aliased_Present set ON
--
-- An_Access_Definition_Trait, --> no special flag, could be defined
-- -- on the base of the presence of
-- -- the N_Access_Definition node as the
-- -- child node of the argument node
--
-- A_Reverse_Trait, --> Reverse_Present set ON
--
-- A_Private_Trait, --> except the case of
-- A_Formal_Derived_Type_Definition,
-- -- no special flag is presented in the corresponding
-- -- node, the A_Private_Trait could be defined
-- -- on the base of Node Kinds and setting other
-- -- flags OFF;
-- -- for A_Formal_Derived_Type_Definition -
-- -- Private_Present set ON
--
-- A_Limited_Trait, --> Limited_Present set ON and corresponding node
-- -- does not belong to the Node Kinds for which
-- -- A_Private_Trait could be defined
--
-- A_Limited_Private_Trait, --> Limited_Present set ON and corresponding
-- -- node belongs to the Node Kinds for which
-- -- A_Private_Trait could be defined
--
-- An_Abstract_Trait, --> For types: Abstract_Present set ON and
-- -- corresponding node does not belong to the
-- -- Node Kinds for which A_Private_Trait could be
-- -- defined;
-- -- For subprograms: no special flag, could be
-- -- defined on the base of the Node Kind of the
-- -- argument node
--
-- An_Abstract_Private_Trait, --> except the case of
-- -- A_Formal_Derived_Type_Definition,
-- -- Abstract_Present set ON and corresponding
-- -- node belongs to the Node Kinds for which
-- -- A_Private_Trait could be defined;
-- -- for A_Formal_Derived_Type_Definition -
-- -- Abstract_Present set ON and
-- -- Private_Present set ON
--
-- An_Abstract_Limited_Trait, --> Abstract_Present set ON,
-- -- Limited_Present set ON
-- -- and corresponding node does not belong
-- -- to the Node Kinds for which
-- -- A_Private_Trait could be defined
--
-- An_Abstract_Limited_Private_Trait); --> Abstract_Present set ON,
-- -- Limited_Present set ON and
-- -- corresponding node belongs
-- -- to Node Kinds for which
-- -- A_Private_Trait could be defined
--
----------------------------------------------------------------------------
-- Expected Argument_Kinds: -> Corresponding tree Nodes:
-- Possible Trait values: --> Provided trait-related flags and
-- combination of their values
-- corresponding to the Trait value
----------------------------------------------------------------------------
--
-- Expected Declaration_Kinds:
-- ==========================
--
-- A_Private_Type_Declaration -> N_Private_Type_Declaration (*1*)
-- A_Private_Trait --> Abstract_Present = OFF
-- Limited_Present = OFF
--
-- A_Limited_Private_Trait --> Abstract_Present = OFF
-- Limited_Present = ON
--
-- An_Abstract_Private_Trait --> Abstract_Present = ON
-- Limited_Present = OFF
--
-- An_Abstract_Limited_Private_Trait --> Abstract_Present = ON
-- Limited_Present = ON
-----------------------------------------------
-- A_Private_Extension_Declaration -> N_Private_Extension_Declaration (*2*)
-- A_Private_Trait --> Abstract_Present = OFF
--
-- An_Abstract_Private_Trait --> Abstract_Present = ON
-----------------------------------------------
-- A_Variable_Declaration -> N_Object_Declaration (*3*)
-- An_Ordinary_Trait --> Aliased_Present = OFF
--
-- An_Aliased_Trait --> Aliased_Present = ON
-----------------------------------------------
-- A_Constant_Declaration -> N_Object_Declaration (*3*)
-- An_Ordinary_Trait --> Aliased_Present = OFF
--
-- An_Aliased_Trait --> Aliased_Present = ON
-----------------------------------------------
-- A_Deferred_Constant_Declaration -> N_Object_Declaration (*3*)
-- An_Ordinary_Trait --> Aliased_Present = OFF
--
-- An_Aliased_Trait --> Aliased_Present = ON
-----------------------------------------------
-- A_Discriminant_Specification -> N_Discriminant_Specification (*4*)
-- Has no trait-related flags
--
-- An_Ordinary_Trait --> Nkind(Discriminant_Type(Definition.Node))
-- /= N_Access_Definition
-- An_Access_Definition_Trait--> Nkind(Discriminant_Type(Definition.Node))
-- = N_Access_Definition
-----------------------------------------------
-- A_Loop_Parameter_Specification -> N_Loop_Parameter_Specification (*5*)
-- An_Ordinary_Trait --> Reverse_Present = OFF
--
-- A_Reverse_Trait --> Reverse_Present = ON
-----------------------------------------------
-- A_Procedure_Declaration -> N_Subprogram_Declaration (*6*)
-- An_Ordinary_Trait --> No flag needed to deternine the trait
-- -> N_Abstract_Subprogram_Declaration
-- An_Abstract_Trait --> No flag needed to deternine the trait
-----------------------------------------------
-- A_Function_Declaration -> N_Subprogram_Declaration (*6*)
-- An_Ordinary_Trait --> No flag needed to deternine the trait
-- -> N_Abstract_Subprogram_Declaration
-- An_Abstract_Trait --> No flag needed to deternine the trait
-----------------------------------------------
-- A_Parameter_Specification -> N_Parameter_Specification (*4*)
-- Has no trait-related flags
--
-- An_Ordinary_Trait --> Nkind(Parameter_Type(Definition.Node))
-- /= N_Access_Definition
-- An_Access_Definition_Trait --> Nkind(Parameter_Type(Definition.Node))
-- = N_Access_Definition
-----------------------------------------------
--
-- Expected Definition_Kinds:
-- =========================
--
-- A_Component_Definition -> N_Subtype_Indication (*10*)
-- N_Identifier
-- N_Expanded_Name
-- An_Ordinary_Trait --> Aliased_Present set OFF in the PARENT node
-- An_Aliased_Trait --> Aliased_Present set ON in the PARENT nod
--
-- A_Private_Type_Definition -> N_Private_Type_Declaration (*1*)
-- The situation is just the same as for A_Private_Type_Declaration
-----------------------------------------------
-- A_Tagged_Private_Type_Definition-> N_Private_Type_Declaration (*1*)
-- The situation is just the same as for A_Private_Type_Declaration
-----------------------------------------------
-- A_Private_Extension_Definition -> N_Private_Extension_Declaration (*2*)
-- The situation is just the same as for N_Private_Extension_Declaration
-----------------------------------------------
--
-- Expected Type_Kinds:
-- ===================
--
-----------------------------------------------
-- A_Derived_Type_Definition -> N_Derived_Type_Definition (*7*)
-- An_Ordinary_Trait --> Abstract_Present = OFF
--
-- An_Abstract_Trait --> Abstract_Present = ON
-----------------------------------------------
-- A_Derived_Record_Extension_Definition -> N_Derived_Type_Definition (*7*)
-- An_Ordinary_Trait --> Abstract_Present = OFF
--
-- An_Abstract_Trait --> Abstract_Present = ON
-----------------------------------------------
-- A_Record_Type_Definition -> N_Record_Definition (*8*)
-- An_Ordinary_Trait --> Abstract_Present = OFF
-- Limited_Present = OFF
--
-- An_Abstract_Trait --> Abstract_Present = ON
-- Limited_Present = OFF
--
-- A_Limited_Trait --> Abstract_Present = OFF
-- Limited_Present = ON
--
-- An_Abstract_Limited_Trait --> Abstract_Present = ON
-- Limited_Present = ON
-----------------------------------------------
-- A_Tagged_Record_Type_Definition -> N_Record_Definition (*8*)
-- An_Ordinary_Trait --> Abstract_Present = OFF
-- Limited_Present = OFF
--
-- An_Abstract_Trait --> Abstract_Present = ON
-- Limited_Present = OFF
--
-- A_Limited_Trait --> Abstract_Present = OFF
-- Limited_Present = ON
--
-- An_Abstract_Limited_Trait --> Abstract_Present = ON
-- Limited_Present = ON
-----------------------------------------------
--
-- Expected Formal_Type_Kinds:
-- ==========================
--
-- A_Formal_Private_Type_Definition -> N_Formal_Private_Type_Definition
-- (*1*)
-- The situation is just the same as for A_Private_Type_Declaration
-----------------------------------------------
-- A_Formal_Tagged_Private_Type_Definition ->
-- N_Formal_Private_Type_Definition (*1*)
--
-- The situation is just the same as for A_Private_Type_Declaration
-----------------------------------------------
-- A_Formal_Derived_Type_Definition -> N_Formal_Derived_Type_Definition(*9*)
-- An_Ordinary_Trait --> Abstract_Present = OFF
-- Private_Present = OFF
--
-- An_Abstract_Trait --> Abstract_Present = ON
-- Private_Present = OFF
--
-- A_Private_Trait --> Abstract_Present = OFF
-- Private_Present = ON
--
-- An_Abstract_Private_Trait --> Abstract_Present = ON
-- Private_Present = ON
------------------------------------------------------------------------------
Arg_Node := Node (Element);
case Int_Kind (Element) is
-- expected argument:
when -- (*1*)
A_Private_Type_Declaration
| A_Private_Type_Definition
| A_Tagged_Private_Type_Definition
| A_Formal_Private_Type_Definition
| A_Formal_Tagged_Private_Type_Definition =>
Is_Abstract := Abstract_Present (Arg_Node);
Is_Limited := Limited_Present (Arg_Node);
if Is_Abstract and Is_Limited then
return An_Abstract_Limited_Private_Trait;
elsif Is_Abstract then
return An_Abstract_Private_Trait;
elsif Is_Limited then
return A_Limited_Private_Trait;
else
return A_Private_Trait;
end if;
when -- (*2*)
A_Private_Extension_Declaration
| A_Private_Extension_Definition =>
Is_Abstract := Abstract_Present (Arg_Node);
if Is_Abstract then
return An_Abstract_Private_Trait;
else
return A_Private_Trait;
end if;
when -- (*3*)
A_Variable_Declaration
| A_Constant_Declaration
| A_Deferred_Constant_Declaration =>
Is_Aliased := Aliased_Present (Arg_Node);
if Is_Aliased then
return An_Aliased_Trait;
else
return An_Ordinary_Trait;
end if;
when -- (*4*)
A_Discriminant_Specification
| A_Parameter_Specification =>
if Int_Kind (Element) = A_Discriminant_Specification then
Trait_Defining_Node := Discriminant_Type (Arg_Node);
else
Trait_Defining_Node := Parameter_Type (Arg_Node);
end if;
if Nkind (Trait_Defining_Node) = N_Access_Definition then
return An_Access_Definition_Trait;
else
return An_Ordinary_Trait;
end if;
when -- (*5*)
A_Loop_Parameter_Specification =>
if Reverse_Present (Arg_Node) then
return A_Reverse_Trait;
else
return An_Ordinary_Trait;
end if;
when -- (*6*)
A_Procedure_Declaration
| A_Function_Declaration =>
if Nkind (Arg_Node) = N_Abstract_Subprogram_Declaration then
return An_Abstract_Trait;
else
return An_Ordinary_Trait;
end if;
when -- (*7*)
A_Derived_Type_Definition
| A_Derived_Record_Extension_Definition =>
if Abstract_Present (Arg_Node) then
return An_Abstract_Trait;
else
return An_Ordinary_Trait;
end if;
when -- (*8*)
A_Record_Type_Definition
| A_Tagged_Record_Type_Definition =>
Is_Abstract := Abstract_Present (Arg_Node);
Is_Limited := Limited_Present (Arg_Node);
if Is_Abstract and Is_Limited then
return An_Abstract_Limited_Trait;
elsif Is_Abstract then
return An_Abstract_Trait;
elsif Is_Limited then
return A_Limited_Trait;
else
return An_Ordinary_Trait;
end if;
when -- (*9*)
A_Formal_Derived_Type_Definition =>
Is_Abstract := Abstract_Present (Arg_Node);
Is_Private := Private_Present (Arg_Node);
if Is_Abstract and Is_Private then
return An_Abstract_Private_Trait;
elsif Is_Abstract then
return An_Abstract_Trait;
elsif Is_Private then
return A_Private_Trait;
else
return An_Ordinary_Trait;
end if;
when -- (*10*)
A_Component_Definition =>
if Aliased_Present (Parent (R_Node (Element))) then
return An_Aliased_Trait;
else
return An_Ordinary_Trait;
end if;
-- unexpected argument:
when others =>
return Not_A_Trait;
end case;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Element,
Outer_Call => "Asis.Elements.Trait_Kind");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Element,
Diagnosis => "Asis.Elements.Trait_Kind");
end Trait_Kind;
------------------------------------------------------------------------------
function Declaration_Origin (Declaration : in Asis.Declaration)
return Asis.Declaration_Origins is
begin
-- The implementation may require revising when the semantic queries
-- and implicit elements are implemented.
Check_Validity (Declaration, "Asis.Elements.Declaration_Origin");
if Int_Kind (Declaration) not in Internal_Declaration_Kinds then
return Not_A_Declaration_Origin;
elsif not Is_From_Implicit (Declaration) then
return An_Explicit_Declaration;
elsif Is_From_Inherited (Declaration) then
return An_Implicit_Inherited_Declaration;
else
return An_Implicit_Predefined_Declaration;
end if;
end Declaration_Origin;
-----------------------------------------------------------------------------
function Mode_Kind (Declaration : in Asis.Declaration)
return Asis.Mode_Kinds
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
begin
Check_Validity (Declaration, "Asis.Elements.Mode_Kind");
if not (Arg_Kind = A_Parameter_Specification or else
Arg_Kind = A_Formal_Object_Declaration)
then
return Not_A_Mode;
end if;
Arg_Node := Node (Declaration);
if In_Present (Arg_Node) and Out_Present (Arg_Node) then
return An_In_Out_Mode;
elsif In_Present (Arg_Node) then
return An_In_Mode;
elsif Out_Present (Arg_Node) then
return An_Out_Mode;
else
return A_Default_In_Mode;
end if;
end Mode_Kind;
-----------------------------------------------------------------------------
function Default_Kind
(Declaration : in Asis.Generic_Formal_Parameter)
return Asis.Subprogram_Default_Kinds
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
begin
Check_Validity (Declaration, "Asis.Elements.Default_Kind");
Arg_Node := Node (Declaration);
if not (Arg_Kind = A_Formal_Procedure_Declaration or else
Arg_Kind = A_Formal_Function_Declaration)
then
return Not_A_Default;
elsif Box_Present (Arg_Node) then
return A_Box_Default;
elsif Present (Default_Name (Arg_Node)) then
return A_Name_Default;
else
return A_Nil_Default;
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Elements.Default_Kind");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Elements.Default_Kind");
end Default_Kind;
-----------------------------------------------------------------------------
function Definition_Kind (Definition : in Asis.Definition)
return Asis.Definition_Kinds is
begin
Check_Validity (Definition, "Asis.Elements.Definition_Kind");
return Definition_Kind_From_Internal (Int_Kind (Definition));
end Definition_Kind;
-----------------------------------------------------------------------------
function Type_Kind (Definition : in Asis.Type_Definition)
return Asis.Type_Kinds is
begin
Check_Validity (Definition, "Asis.Elements.Type_Kind");
return Type_Kind_From_Internal (Int_Kind (Definition));
end Type_Kind;
-----------------------------------------------------------------------------
function Formal_Type_Kind (Definition : in Asis.Type_Definition)
return Asis.Formal_Type_Kinds is
begin
Check_Validity (Definition, "Asis.Elements.Formal_Type_Kind");
return Formal_Type_Kind_From_Internal (Int_Kind (Definition));
end Formal_Type_Kind;
-----------------------------------------------------------------------------
function Access_Type_Kind (Definition : in Asis.Type_Definition)
return Asis.Access_Type_Kinds is
begin
Check_Validity (Definition, "Asis.Elements.Access_Type_Kind");
return Access_Type_Kind_From_Internal (Int_Kind (Definition));
end Access_Type_Kind;
-----------------------------------------------------------------------------
function Root_Type_Kind (Definition : in Asis.Type_Definition)
return Asis.Root_Type_Kinds is
begin
Check_Validity (Definition, "Asis.Elements.Root_Type_Kind");
return Root_Type_Kind_From_Internal (Int_Kind (Definition));
end Root_Type_Kind;
-----------------------------------------------------------------------------
function Constraint_Kind (Definition : in Asis.Definition)
return Asis.Constraint_Kinds is
begin
Check_Validity (Definition, "Asis.Elements.Constraint_Kind");
return Constraint_Kind_From_Internal (Int_Kind (Definition));
end Constraint_Kind;
-----------------------------------------------------------------------------
function Discrete_Range_Kind
(Definition : in Asis.Definition)
return Asis.Discrete_Range_Kinds is
begin
Check_Validity (Definition, "Discrete_Range_Kind.Expression_Kind");
return Discrete_Range_Kind_From_Internal (Int_Kind (Definition));
end Discrete_Range_Kind;
-----------------------------------------------------------------------------
function Expression_Kind (Expression : in Asis.Expression)
return Asis.Expression_Kinds is
begin
Check_Validity (Expression, "Asis.Elements.Expression_Kind");
return Expression_Kind_From_Internal (Int_Kind (Expression));
end Expression_Kind;
-----------------------------------------------------------------------------
function Operator_Kind (Element : in Asis.Element)
return Asis.Operator_Kinds is
begin
Check_Validity (Element, "Asis.Elements.Operator_Kind");
return Operator_Kind_From_Internal (Int_Kind (Element));
end Operator_Kind;
-----------------------------------------------------------------------------
function Attribute_Kind (Expression : in Asis.Expression)
return Asis.Attribute_Kinds is
begin
Check_Validity (Expression, "Asis.Elements.Attribute_Kind");
return Attribute_Kind_From_Internal (Int_Kind (Expression));
end Attribute_Kind;
-----------------------------------------------------------------------------
function Association_Kind (Association : in Asis.Association)
return Asis.Association_Kinds is
begin
Check_Validity (Association, "Asis.Elements.Association_Kind");
return Association_Kind_From_Internal (Int_Kind (Association));
end Association_Kind;
-----------------------------------------------------------------------------
function Statement_Kind (Statement : in Asis.Statement)
return Asis.Statement_Kinds is
begin
Check_Validity (Statement, "Asis.Elements.Statement_Kind");
return Statement_Kind_From_Internal (Int_Kind (Statement));
end Statement_Kind;
-----------------------------------------------------------------------------
function Path_Kind (Path : in Asis.Path)
return Asis.Path_Kinds is
begin
Check_Validity (Path, "Asis.Elements.Clause_Kind");
return Path_Kind_From_Internal (Int_Kind (Path));
end Path_Kind;
-----------------------------------------------------------------------------
function Clause_Kind (Clause : in Asis.Clause)
return Asis.Clause_Kinds is
begin
Check_Validity (Clause, "Asis.Elements.Clause_Kind");
return Clause_Kind_From_Internal (Int_Kind (Clause));
end Clause_Kind;
-----------------------------------------------------------------------------
function Representation_Clause_Kind (Clause : in Asis.Clause)
return Asis.Representation_Clause_Kinds is
begin
Check_Validity (Clause, "Asis.Elements.Representation_Clause_Kind");
return Representation_Clause_Kind_From_Internal (Int_Kind (Clause));
end Representation_Clause_Kind;
-----------------------------------------------------------------------------
function Is_Nil (Right : in Asis.Element) return Boolean is
begin
return Right = Asis.Nil_Element;
end Is_Nil;
-----------------------------------------------------------------------------
function Is_Nil (Right : in Asis.Element_List) return Boolean is
begin
return Right'Length = 0;
end Is_Nil;
-----------------------------------------------------------------------------
function Is_Equal
(Left : in Asis.Element;
Right : in Asis.Element) return Boolean
is
C_Left : Context_Id;
C_Right : Context_Id;
U_Left : Unit_Id;
U_Right : Unit_Id;
begin
Check_Validity (Left, "Asis.Elements.Is_Equal");
Check_Validity (Right, "Asis.Elements.Is_Equal");
if Left = Nil_Element or else Right = Nil_Element then
return Left = Right;
elsif not (Rel_Sloc (Left) = Rel_Sloc (Right) and then
Special_Case (Left) = Special_Case (Right) and then
Int_Kind (Left) = Int_Kind (Right) and then
Character_Code (Left) = Character_Code (Right) and then
Is_From_Implicit (Left) = Is_From_Implicit (Right) and then
Is_From_Inherited (Left) = Is_From_Inherited (Right) and then
Is_From_Instance (Left) = Is_From_Instance (Right))
then
return False;
else
-- here we have to check if Left and Right are from
-- the same physical compilation unit. For now,
-- the same physical compilation unit means the same time stamp
-- of the source files.
C_Left := Encl_Cont_Id (Left);
U_Left := Encl_Unit_Id (Left);
C_Right := Encl_Cont_Id (Right);
U_Right := Encl_Unit_Id (Right);
if U_Left = Standard_Id and then U_Right = Standard_Id then
-- When we are in the predefined Standard package, Rel_Sloc
-- comparition does not work, and we have to compare nodes:
return Node_Value (Left) = Node_Value (Right);
elsif C_Left = C_Right then
return U_Left = U_Right;
else
-- This is the less reliable case: if we have two Elements
-- which came from _different_ Contexts, we have to check if
-- enlocing units are Is_Equal. Currently we use time stamps
-- comparing for this, but we akready have at least one
-- proof that it may be unreliable
return Time_Stamp (C_Left, U_Left) = Time_Stamp (C_Right, U_Right);
end if;
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Outer_Call => "Asis.Elements.Is_Equal");
raise;
when others =>
Raise_ASIS_Failed (
Diagnosis => "Asis.Elements.Is_Equal");
end Is_Equal;
-----------------------------------------------------------------------------
function Is_Identical (Left : in Asis.Element;
Right : in Asis.Element) return Boolean is
begin
Check_Validity (Left, "Asis.Elements.Is_Identical");
Check_Validity (Right, "Asis.Elements.Is_Identical");
return Rel_Sloc (Left) = Rel_Sloc (Right) and then
Int_Kind (Left) = Int_Kind (Right) and then
Special_Case (Left) = Special_Case (Right) and then
Is_From_Implicit (Left) = Is_From_Implicit (Right) and then
Is_From_Inherited (Left) = Is_From_Inherited (Right) and then
Is_From_Instance (Left) = Is_From_Instance (Right) and then
Encl_Unit_Id (Left) = Encl_Unit_Id (Right) and then
Encl_Cont_Id (Left) = Encl_Cont_Id (Right);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Outer_Call => "Asis.Elements.Is_Identical");
raise;
when others =>
Raise_ASIS_Failed (
Diagnosis => "Asis.Elements.Is_Identical");
end Is_Identical;
------------------------------------------------------------------------------
-- The general principle of the implementation
-- of the Is_Part_Of_... functions:
--
-- These functions simply returns the corresponding flag value from the
-- Element passed as their argument. All necessary work should be done
-- during the creation of the Element when these flags are set
--
-- All of them (as well as the function Declaration_Origin abowe) will
-- require revisiting during semantic queries implementation
------------------------------------------------------------------------------
function Is_Part_Of_Implicit (Element : in Asis.Element) return Boolean is
begin
Check_Validity (Element, "Asis.Elements.Is_Part_Of_Implicit");
return Is_From_Implicit (Element) or else
Special_Case (Element) = Is_Normalized;
-- for normalized associations Is_Part_Of_Implicit is not set ON ???
-- unless the association is from some enclosing implicit construct. ???
end Is_Part_Of_Implicit;
-----------------------------------------------------------------------------
function Is_Part_Of_Inherited (Element : in Asis.Element) return Boolean is
begin
Check_Validity (Element, "Asis.Elements.Is_Part_Of_Inherited");
return Is_From_Inherited (Element);
end Is_Part_Of_Inherited;
-----------------------------------------------------------------------------
function Is_Part_Of_Instance (Element : Asis.Element) return Boolean is
begin
Check_Validity (Element, "Asis.Elements.Is_Part_Of_Instance");
return Is_From_Instance (Element);
end Is_Part_Of_Instance;
-----------------------------------------------------------------------------
function Enclosing_Element
(Element : in Asis.Element)
return Asis.Element
is
Argument_Kind : Internal_Element_Kinds := Int_Kind (Element);
Arg_Spec_Case : Special_Cases := Special_Case (Element);
begin
Check_Validity (Element, "Asis.Elements.Enclosing_Element");
if Argument_Kind = Not_An_Element then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Elements.Enclosing_Element");
end if;
-- At last, we've started revising of the old implementation
-- of Enclosind_Element
-- if the argument is an expanded generic declaration we have
-- to return the corresponding instantiation:
if Arg_Spec_Case in Expanded_Spec then
return Corresponding_Instantiation (Element);
end if;
-- if the argument is from an expanded generic declaration,
-- we have to be careful when coming from some top-level component
-- of the expanded declaration to the declaration itself - we
-- need to set the Special_Case field properly
if Is_From_Instance (Element) and then
not Is_From_Implicit (Element)
then
return Enclosing_For_Explicit_Instance_Component (Element);
-- NEEDS ADDITIONAL REVISING!!!
end if;
if not (Is_From_Implicit (Element) or else
Is_From_Inherited (Element)) -- ???
then
return Enclosing_Element_For_Explicit (Element);
else
return Enclosing_Element_For_Implicit (Element);
end if;
exception
when Assert_Error : System.Assertions.Assert_Failure =>
Raise_ASIS_Failed (
Argument => Element,
Diagnosis =>
"Asis.Elements.Enclosing_Element - " & LT
& "Assert_Failure at "
& Ada.Exceptions.Exception_Message (Assert_Error));
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Element,
Outer_Call => "Asis.Elements.Enclosing_Element");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Element,
Diagnosis => "Asis.Elements.Enclosing_Element");
end Enclosing_Element;
-- OPEN PROBLEMS:
--
-- 1. If we are in an expanded generic template...
------------------------------------------------------------------------------
-- DEPENDS ON THE PARTIALLY IMPLEMENTED Enclosing_Element FUNCTION WITH
-- ONE PARAMETER
function Enclosing_Element
(Element : in Asis.Element;
Expected_Enclosing_Element : in Asis.Element)
return Asis.Element
is
begin
Check_Validity (Element, "Asis.Elements.Enclosing_Element "
& "(the Element parameter)");
Check_Validity (Expected_Enclosing_Element,
"Asis.Elements.Enclosing_Element "
& "(the Expected_Enclosing_Element parameter)");
return Enclosing_Element (Element);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Element,
Outer_Call => "Asis.Elements.Enclosing_Element");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Element,
Diagnosis => "Asis.Elements.Enclosing_Element");
end Enclosing_Element;
-----------------------------------------------------------------------------
function Pragmas
(The_Element : in Asis.Element)
return Asis.Pragma_Element_List
is
-- This implementation is based on the following statement in the function
-- documentation:
--
-- This interface returns exactly those pragmas that would be returned by the
-- various interfaces, that accept these same argument kinds, and that
-- return Declaration_Lists and Statement_Lists, where the inclusion of
-- Pragmas is controlled by an Include_Pragmas parameter.
--
-- The general idea of the implementation is straightforward - to get
-- the "full" Element_List by the call of the corresponding interface
-- with Include_Pragmas => True, and then select only A_Pragma elements
-- from this intermediate result.
--
-- Some loss of effectiveness could be considered as the disadvantage of
-- this approach, but its advantages are:
--
-- - it saves implementation efforts;
-- - it allows to check whether the documentation fragment cited above
-- is really correct;
-- - it saves the debugging efforts on the first prototyping stage
-- (there is no need for the special debugging of this function
-- if other ASIS interfaces used for its implementation work correctly);
-- - it is more convenient for for incremental development
-- - it yields the vendor-independent implementation of this function
Context_Internal_Kind : Internal_Element_Kinds;
function Extract_Pragmas
(List : Asis.Element_List)
return Asis.Pragma_Element_List;
-- function extracts Elements of A_Pragma kind from its
-- List parameter and returns the new List constructed from these
-- Pragma Elements (in their order of appearance) as its result
function Extract_Pragmas
(List : Asis.Element_List)
return Asis.Pragma_Element_List
is
Pragma_List : Asis.Pragma_Element_List (List'Range);
Pragma_List_Actual_Lenght : Asis.ASIS_Integer := 0;
begin
for I in List'Range loop
if Element_Kind (List (I)) = A_Pragma then
Pragma_List_Actual_Lenght := Pragma_List_Actual_Lenght + 1;
Pragma_List (Pragma_List_Actual_Lenght) := List (I);
end if;
end loop;
return Pragma_List (1 .. Pragma_List_Actual_Lenght);
end Extract_Pragmas;
begin -- Pragmas
Check_Validity (The_Element, "Asis.Elements.Pragmas");
Context_Internal_Kind := Int_Kind (The_Element);
if not -- Appropriate Element_Kinds:
(Context_Internal_Kind in Internal_Path_Kinds
or Context_Internal_Kind = An_Exception_Handler
-- Appropriate Declaration_Kinds:
or Context_Internal_Kind = A_Procedure_Body_Declaration
or Context_Internal_Kind = A_Function_Body_Declaration
or Context_Internal_Kind = A_Package_Declaration
or Context_Internal_Kind = A_Package_Body_Declaration
or Context_Internal_Kind = A_Task_Body_Declaration
or Context_Internal_Kind = A_Protected_Body_Declaration
or Context_Internal_Kind = An_Entry_Body_Declaration
or Context_Internal_Kind = A_Generic_Procedure_Declaration
or Context_Internal_Kind = A_Generic_Function_Declaration
or Context_Internal_Kind = A_Generic_Package_Declaration
-- Appropriate Definition_Kinds:
or Context_Internal_Kind = A_Record_Definition
or Context_Internal_Kind = A_Variant_Part
or Context_Internal_Kind = A_Variant
or Context_Internal_Kind = A_Task_Definition
or Context_Internal_Kind = A_Protected_Definition
-- Appropriate Statement_Kinds:
or Context_Internal_Kind = A_Loop_Statement
or Context_Internal_Kind = A_While_Loop_Statement
or Context_Internal_Kind = A_For_Loop_Statement
or Context_Internal_Kind = A_Block_Statement
or Context_Internal_Kind = An_Accept_Statement
-- Representation_Clause_Kinds:
or Context_Internal_Kind = A_Record_Representation_Clause)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Elements.Pragmas");
end if;
begin
-- ???
-- for the debugging period only!!!
-- to add the context information to diagnosis for
-- ASIS_Inappropriate_Element raised by other ASIS interfaces
--
-- should be better documented
case Context_Internal_Kind is
-- Appropriate Element_Kinds:
when Internal_Path_Kinds =>
-- A_Path: (pragmas from the statement list)
return Extract_Pragmas (
Asis.Statements.Sequence_Of_Statements (
Path => The_Element,
Include_Pragmas => True));
when An_Exception_Handler =>
-- (pragmas from the statement list)
return Extract_Pragmas (
Asis.Statements.Handler_Statements (
Handler => The_Element,
Include_Pragmas => True));
-- Appropriate Declaration_Kinds:
when A_Procedure_Body_Declaration -- (pragmas from decl region
| A_Function_Body_Declaration -- + statements)
| A_Package_Body_Declaration -- !! SEE OPEN_PROBLEMS.1 BELOW
| A_Task_Body_Declaration
| An_Entry_Body_Declaration =>
return (Extract_Pragmas (
Asis.Declarations.Body_Declarative_Items (
Declaration => The_Element,
Include_Pragmas => True))
&
Extract_Pragmas (
Asis.Declarations.Body_Statements (
Declaration => The_Element,
Include_Pragmas => True)));
when A_Package_Declaration =>
-- (pragmas from visible + private decl regions)
return (Extract_Pragmas (
Asis.Declarations.Visible_Part_Declarative_Items (
Declaration => The_Element,
Include_Pragmas => True))
&
Extract_Pragmas (
Asis.Declarations.Private_Part_Declarative_Items (
Declaration => The_Element,
Include_Pragmas => True)));
when A_Protected_Body_Declaration =>
-- (pragmas from decl region)
return Extract_Pragmas (
Asis.Declarations.Protected_Operation_Items (
Declaration => The_Element,
Include_Pragmas => True));
when A_Generic_Procedure_Declaration
| A_Generic_Function_Declaration =>
-- (pragmas from formal decl region
return Extract_Pragmas (
Asis.Declarations.Generic_Formal_Part (
Declaration => The_Element,
Include_Pragmas => True));
when A_Generic_Package_Declaration =>
-- (pragmas from formal + visible + private decl regions)
return (Extract_Pragmas (
Asis.Declarations.Generic_Formal_Part (
Declaration => The_Element,
Include_Pragmas => True))
&
Extract_Pragmas (
Asis.Declarations.Visible_Part_Declarative_Items (
Declaration => The_Element,
Include_Pragmas => True))
&
Extract_Pragmas (
Asis.Declarations.Private_Part_Declarative_Items (
Declaration => The_Element,
Include_Pragmas => True)));
-- Appropriate Definition_Kinds:
when A_Record_Definition
| A_Variant =>
-- (pragmas from the component list)
return Extract_Pragmas (
Asis.Definitions.Record_Components (
Definition => The_Element,
Include_Pragmas => True));
when A_Variant_Part =>
-- (pragmas from between variants)
return Extract_Pragmas (
Asis.Definitions.Variants (
Variant_Part => The_Element,
Include_Pragmas => True));
when A_Task_Definition
| A_Protected_Definition =>
-- (pragmas from visible + private decl regions)
return (Extract_Pragmas (
Asis.Definitions.Visible_Part_Items (
Definition => The_Element,
Include_Pragmas => True))
&
Extract_Pragmas (
Asis.Definitions.Private_Part_Items (
Definition => The_Element,
Include_Pragmas => True)));
-- Appropriate Statement_Kinds:
when A_Loop_Statement
| A_While_Loop_Statement
| A_For_Loop_Statement =>
-- (pragmas from statement list)
return Extract_Pragmas (
Asis.Statements.Loop_Statements (
Statement => The_Element,
Include_Pragmas => True));
when A_Block_Statement =>
-- (pragmas from decl region + statements)
return (Extract_Pragmas (
Asis.Statements.Block_Declarative_Items (
Statement => The_Element,
Include_Pragmas => True))
&
Extract_Pragmas (
Asis.Statements.Block_Statements (
Statement => The_Element,
Include_Pragmas => True)));
when An_Accept_Statement =>
-- (pragmas from statement list+ pragma immediately preceding
-- the first exception handler, if any)
-- !! SEE OPEN_PROBLEMS.2 BELOW
return (Extract_Pragmas (
Asis.Statements.Accept_Body_Statements (
Statement => The_Element,
Include_Pragmas => True))
&
Extract_Pragmas (
Asis.Statements.Accept_Body_Exception_Handlers (
Statement => The_Element,
Include_Pragmas => True)));
-- Appropriate Representation_Clause_Kinds:
when A_Record_Representation_Clause =>
-- (pragmas from component specifications)
return Extract_Pragmas (
Asis.Clauses.Component_Clauses (
Clause => The_Element,
Include_Pragmas => True));
when others => -- could never been reached !!!
Raise_ASIS_Failed (Diagnosis =>
"Internal Error in Asis_Elements.Pragmas");
return Nil_Element_List; -- to avoid GNAT warnings;
end case;
exception
-- ??? for the debugging period only!!!
when ASIS_Inappropriate_Element =>
Add_Call_Information (Outer_Call => "Asis.Elements.Pragmas");
raise;
end;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => The_Element,
Outer_Call => "Asis.Elements.Pragmas");
raise;
when others =>
Raise_ASIS_Failed (
Argument => The_Element,
Diagnosis => "Asis.Elements.Pragmas");
end Pragmas;
------------------------------------------------------------------------------
-- NOT IMPLEMENTED
function Corresponding_Pragmas (Element : in Asis.Element)
return Asis.Pragma_Element_List is
begin
Check_Validity (Element, "Asis.Elements.Corresponding_Pragmas");
Not_Implemented_Yet (Diagnosis => "Asis.Elements.Corresponding_Pragmas");
-- 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 => Element,
Outer_Call => "Asis.Elements.Corresponding_Pragmas");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Element,
Diagnosis => "Asis.Elements.Corresponding_Pragmas");
end Corresponding_Pragmas;
-----------------------------------------------------------------------------
function Pragma_Name_Image
(Pragma_Element : in Asis.Pragma_Element)
return Wide_String
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Pragma_Element);
Arg_Node : Node_Id;
Image_Start : Source_Ptr;
Image_End : Source_Ptr;
begin
Check_Validity (Pragma_Element, "Asis.Elements.Pragma_Name_Image");
if Arg_Kind not in Internal_Pragma_Kinds then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Elements.Pragma_Name_Image");
end if;
Arg_Node := Node (Pragma_Element);
Image_Start := Next_Identifier (Sloc (Arg_Node) + 6);
Image_End := Get_Word_End (P => Image_Start,
In_Word => In_Identifier'Access);
return To_Wide_String (Get_Word (Image_Start, Image_End));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Pragma_Element,
Outer_Call => "Asis.Elements.Pragma_Name_Image");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Pragma_Element,
Diagnosis => "Asis.Elements.Pragma_Name_Image");
end Pragma_Name_Image;
-----------------------------------------------------------------------------
function Pragma_Argument_Associations
(Pragma_Element : in Asis.Pragma_Element)
return Asis.Association_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Pragma_Element);
Arg_Node : Node_Id;
Pragma_Chars : Name_Id;
Res_Node : Node_Id;
begin
Check_Validity (Pragma_Element,
"Asis.Elements.Pragma_Argument_Associations");
if Arg_Kind not in Internal_Pragma_Kinds then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Elements.Pragma_Argument_Associations");
end if;
Arg_Node := Node (Pragma_Element);
Pragma_Chars := Chars (Arg_Node);
if Pragma_Chars = Name_Debug then
-- GNAT-specific debug pragma has a procedure call as its argument,
-- so it needs a special processing
Arg_Node := R_Node (Pragma_Element);
Res_Node := Nlists.First (Pragma_Argument_Associations (Arg_Node));
-- Here we have Res_Node set to N_Procedure_Call_Statement node
Res_Node := Sinfo.Name (Res_Node);
return (1 => Node_To_Element_New
(Node => Res_Node,
Starting_Element => Pragma_Element));
else
return Node_To_Element_List (
List => Pragma_Argument_Associations (Arg_Node),
In_Unit => Encl_Unit (Pragma_Element));
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Pragma_Element,
Outer_Call => "Asis.Elements.Pragma_Argument_Associations");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Pragma_Element,
Diagnosis => "Asis.Elements.Pragma_Argument_Associations");
end Pragma_Argument_Associations;
-----------------------------------------------------------------------------
function Debug_Image (Element : in Asis.Element) return Wide_String is
LT : String renames A4G.A_Types.ASIS_Line_Terminator;
begin
Debug_String (Element);
return To_Wide_String (
LT & "Element Debug_Image: " & LT &
Debug_Buffer (1 .. Debug_Buffer_Len));
end Debug_Image;
-----------------------------------------------------------------------------
function Hash (Element : in Asis.Element) return Asis.ASIS_Integer is
begin
Check_Validity (Element, "Asis.Elements.Hash");
if Encl_Unit_Id (Element) = Standard_Id then
if Special_Case (Element) = Stand_Char_Literal then
return Asis.ASIS_Integer (256 * Character_Code (Element));
else
return Asis.ASIS_Integer (Node_Value (Element));
end if;
else
return Asis.ASIS_Integer (Rel_Sloc (Element));
end if;
end Hash;
-----------------------------------------------------------------------------
end Asis.Elements