File : asis-declarations.adb
------------------------------------------------------------------------------
-- --
-- ASIS-for-GNAT IMPLEMENTATION COMPONENTS --
-- --
-- --
-- A S I S . D E C L A R A T 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 System.Assertions;
with Ada.Exceptions;
with Asis.Exceptions; use Asis.Exceptions;
with Asis.Elements; use Asis.Elements;
with Asis.Expressions;
with Asis.Compilation_Units; use Asis.Compilation_Units;
with Asis.Extensions; use Asis.Extensions;
with Asis.Set_Get;
use Asis.Set_Get;
with A4G.Int_Knds; use A4G.Int_Knds;
with A4G.Mapping; use A4G.Mapping;
with A4G.Vcheck; use A4G.Vcheck;
with A4G.Norm; use A4G.Norm;
with A4G.Decl_Sem; use A4G.Decl_Sem;
with A4G.C_U_Info; use A4G.C_U_Info;
with A4G.A_Sinput; use A4G.A_Sinput;
with A4G.A_Sem; use A4G.A_Sem;
with A4G.Contt.UT; use A4G.Contt.UT; use A4G.Contt;
with A4G.Contt.TT; use A4G.Contt.TT;
with A4G.Span_End; use A4G.Span_End;
with Types; use Types;
with Sinfo; use Sinfo;
with Einfo; use Einfo;
with Nlists; use Nlists;
with Atree; use Atree;
with Uintp; use Uintp;
package body Asis.Declarations is
-- !!!??? This file is '-gnatg-compilable', but both its content and its
-- !!!??? documentation need revising
LT : String renames ASIS_Line_Terminator;
function Names
(Declaration : in Asis.Declaration)
return Asis.Defining_Name_List
is
Arg_Node : Node_Id;
Decl_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Result_Node : Node_Id;
Result_Kind : Internal_Element_Kinds := Not_An_Element;
begin
Check_Validity (Declaration, "Asis.Declarations.Names");
if not (Decl_Kind in Internal_Declaration_Kinds) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Declarations.Names");
end if;
Arg_Node := Node (Declaration);
case Internal_Declaration_Kinds (Decl_Kind) is
when An_Ordinary_Type_Declaration =>
Result_Node := Defining_Identifier (R_Node (Declaration));
Result_Kind := A_Defining_Identifier;
when A_Variable_Declaration |
A_Constant_Declaration |
A_Deferred_Constant_Declaration |
An_Integer_Number_Declaration |
A_Real_Number_Declaration |
A_Discriminant_Specification |
A_Component_Declaration |
A_Parameter_Specification |
An_Exception_Declaration |
A_Formal_Object_Declaration =>
return Defining_Id_List_From_Normalized
(N => Arg_Node,
From_Declaration => Declaration);
when A_Task_Type_Declaration |
A_Protected_Type_Declaration |
An_Incomplete_Type_Declaration |
A_Private_Type_Declaration |
A_Private_Extension_Declaration |
A_Subtype_Declaration |
A_Single_Task_Declaration |
A_Single_Protected_Declaration |
A_Loop_Parameter_Specification |
An_Object_Renaming_Declaration |
An_Exception_Renaming_Declaration |
A_Task_Body_Declaration |
A_Protected_Body_Declaration |
An_Entry_Declaration |
An_Entry_Body_Declaration |
An_Entry_Index_Specification |
A_Package_Body_Stub |
A_Task_Body_Stub |
A_Protected_Body_Stub |
A_Formal_Type_Declaration |
A_Formal_Package_Declaration |
A_Formal_Package_Declaration_With_Box =>
Result_Node := Defining_Identifier (Arg_Node);
Result_Kind := A_Defining_Identifier;
-- See "Open problems" below
when An_Enumeration_Literal_Specification =>
Result_Node := Arg_Node;
if Nkind (Result_Node) = N_Defining_Character_Literal then
Result_Kind := A_Defining_Character_Literal;
else
Result_Kind := A_Defining_Enumeration_Literal;
end if;
when A_Procedure_Body_Declaration
| A_Function_Body_Declaration
| A_Package_Declaration
| A_Procedure_Renaming_Declaration
| A_Function_Renaming_Declaration
| A_Procedure_Body_Stub
| A_Function_Body_Stub
| A_Generic_Procedure_Declaration
| A_Generic_Function_Declaration
| A_Generic_Package_Declaration
| A_Formal_Procedure_Declaration
| A_Formal_Function_Declaration =>
Result_Node := Defining_Unit_Name (Specification (Arg_Node));
if Nkind (Result_Node) = N_Defining_Program_Unit_Name then
Result_Kind := A_Defining_Expanded_Name;
elsif Nkind (Result_Node) = N_Defining_Operator_Symbol then
Result_Kind := Not_An_Element;
-- Not_An_Element is used as a dummy value to initiate auto
-- determination of the result Internal kind to determine
-- the particular operator symbol
else
Result_Kind := A_Defining_Identifier;
end if;
when A_Package_Body_Declaration =>
Result_Node := Defining_Unit_Name (Arg_Node);
if Nkind (Result_Node) = N_Defining_Program_Unit_Name then
Result_Kind := A_Defining_Expanded_Name;
else
Result_Kind := A_Defining_Identifier;
end if;
when A_Procedure_Declaration
| A_Function_Declaration
| A_Package_Renaming_Declaration
| A_Generic_Package_Renaming_Declaration
| A_Generic_Procedure_Renaming_Declaration
| A_Generic_Function_Renaming_Declaration
| A_Package_Instantiation
| A_Procedure_Instantiation
| A_Function_Instantiation =>
if Decl_Kind = A_Procedure_Declaration or else
Decl_Kind = A_Function_Declaration
then
Result_Node := Defining_Unit_Name (Specification (Arg_Node));
else
Result_Node := Defining_Unit_Name (Arg_Node);
end if;
if Nkind (Result_Node) = N_Defining_Program_Unit_Name then
Result_Kind := A_Defining_Expanded_Name;
elsif Nkind (Result_Node) = N_Defining_Operator_Symbol then
Result_Kind := Not_An_Element;
-- Not_An_Element is used as a dummy value to initiate auto
-- determination of the result Internal kind to determine
-- the particular operator symbol
else
Result_Kind := A_Defining_Identifier;
end if;
when A_Choice_Parameter_Specification =>
Result_Node := Arg_Node;
Result_Kind := A_Defining_Identifier;
end case;
return (1 => Node_To_Element_New (Starting_Element => Declaration,
Node => Result_Node,
Internal_Kind => Result_Kind));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Names");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Names");
end Names;
-- OPEN PROBLEMS: 1. May be, we should use R_Node (Declaration) instead
-- of Node for all possible argument kinds, not only for
-- An_Ordinary_Type_Declaration to handle properly all the rewritings
function Defining_Name_Image
(Defining_Name : in Asis.Defining_Name)
return Wide_String
is
Arg_Node : Node_Id;
Def_N_Kind : Internal_Element_Kinds;
Image_Start : Source_Ptr;
Image_End : Source_Ptr;
Name_Prefix : Asis.Expression;
-- for recursive construction of
-- A_Defining_Expanded_Name image
function Prefix_Image (Name_Prefix : Asis.Name) return Program_Text;
-- Returns the string image for the prefix A_Defining_Expanded_Name.
function Prefix_Image (Name_Prefix : Asis.Name) return Program_Text is
begin
if Int_Kind (Name_Prefix) = An_Identifier then
return Asis.Expressions.Name_Image (Name_Prefix);
else
return
Prefix_Image (Asis.Expressions.Prefix (Name_Prefix))
& "."
& Asis.Expressions.Name_Image
(Asis.Expressions.Selector (Name_Prefix));
end if;
end Prefix_Image;
begin
Check_Validity (Defining_Name, "Asis.Declarations.Defining_Name_Image");
Def_N_Kind := Int_Kind (Defining_Name);
if Def_N_Kind not in Internal_Defining_Name_Kinds then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Declarations.Defining_Name_Image");
end if;
-- we should make the difference between entities defined in the
-- package Standard and all the other entities. Entities from the
-- package Standard are processed on the basis of Name Table, all the
-- other ones - on the basis of the Source Buffer.
Arg_Node := Node (Defining_Name);
case Def_N_Kind is
when A_Defining_Character_Literal =>
if Sloc (Arg_Node) <= Standard_Location then
return '''
& Wide_Character'Val (Character_Code (Defining_Name))
& ''';
else
if Nkind (Arg_Node) /= N_Defining_Character_Literal then
return To_Wide_String (
'''
& Get_Character (Character_Code (Defining_Name))
& ''');
else
return To_Wide_String (
''' & Get_Character (Sloc (Arg_Node) + 1) & ''');
-- Sloc (Arg_Node) points to the leading tick of
-- the literal
end if;
end if;
when A_Defining_Identifier
| A_Defining_Enumeration_Literal =>
-- the situation is the same for them
if Sloc (Arg_Node) <= Standard_Location then
return To_Wide_String (Normalized_Namet_String (Arg_Node));
else
Image_Start := Sloc (Arg_Node);
-- Sloc points to << so we have to go right to the
-- first letter of the identifier
if Nkind (Arg_Node) = N_Label then
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;
when Internal_Defining_Operator_Kinds =>
if Sloc (Arg_Node) <= Standard_Location then
Not_Implemented_Yet ("Asis.Declarations.Defining_Name_Image: "
& "An operator symbol defined in Standard");
else
return To_Wide_String (String_Image (Arg_Node));
end if;
when A_Defining_Expanded_Name =>
-- there is nothing of this kind in Standard
Name_Prefix := Defining_Prefix (Defining_Name);
return Prefix_Image (Name_Prefix) & "."
& Defining_Name_Image (Defining_Selector (Defining_Name));
when others =>
-- this choice can never been reached, see the condition for
-- defining the appropriate argument
raise ASIS_Failed;
end case;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Defining_Name,
Outer_Call => "Asis.Declarations.Defining_Name_Image");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Defining_Name,
Diagnosis => "Asis.Declarations.Defining_Name_Image");
end Defining_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.Expressions.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.
----------------------------------------------------------------------------
function Position_Number_Image
(Defining_Name : in Asis.Defining_Name)
return Wide_String
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Defining_Name);
Arg_Node : Node_Id;
Arg_Nkind : Node_Kind;
Result : Uint;
begin
Check_Validity (Defining_Name,
"Asis.Declarations.Position_Number_Image");
if not (Arg_Kind = A_Defining_Character_Literal or else
Arg_Kind = A_Defining_Enumeration_Literal)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Declarations.Position_Number_Image");
end if;
Arg_Node := Node (Defining_Name);
Arg_Nkind := Nkind (Arg_Node);
if Arg_Nkind = N_Defining_Identifier or else
Arg_Nkind = N_Defining_Character_Literal
then
Result := Enumeration_Pos (Arg_Node);
UI_Image (Result, Format => Decimal);
return To_Wide_String (UI_Image_Buffer (1 .. UI_Image_Length));
else
-- this is the case of enumeration literals defined in Standard
Not_Implemented_Yet (Diagnosis =>
"Asis.Declarations.Position_Number_Image");
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Defining_Name,
Outer_Call => "Asis.Declarations.Position_Number_Image");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Defining_Name,
Diagnosis => "Asis.Declarations.Position_Number_Image");
end Position_Number_Image;
-------------------------------------------------------------------------
function Representation_Value_Image
(Defining_Name : in Asis.Defining_Name)
return Wide_String
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Defining_Name);
Arg_Node : Node_Id;
Arg_Nkind : Node_Kind;
Result : Uint;
begin
Check_Validity (Defining_Name,
"Asis.Declarations.Representation_Value_Image");
if not (Arg_Kind = A_Defining_Character_Literal or else
Arg_Kind = A_Defining_Enumeration_Literal)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Declarations.Representation_Value_Image");
end if;
Arg_Node := Node (Defining_Name);
Arg_Nkind := Nkind (Arg_Node);
if Arg_Nkind = N_Defining_Identifier or else
Arg_Nkind = N_Defining_Character_Literal
then
Result := Enumeration_Rep (Arg_Node);
UI_Image (Result, Format => Decimal);
return To_Wide_String (UI_Image_Buffer (1 .. UI_Image_Length));
else
-- this is the case of enumeration literals defined in Standard
Not_Implemented_Yet (Diagnosis =>
"Asis.Declarations.Representation_Value_Image");
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Defining_Name,
Outer_Call => "Asis.Declarations.Representation_Value_Image");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Defining_Name,
Diagnosis => "Asis.Declarations.Representation_Value_Image");
end Representation_Value_Image;
--------------------------------------------------------------------------
function Defining_Prefix
(Defining_Name : in Asis.Defining_Name)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Defining_Name);
Arg_Node : Node_Id;
Result_Node : Node_Id;
Result_Kind : Internal_Element_Kinds;
begin
Check_Validity (Defining_Name, "Asis.Declarations.Defining_Prefix");
if not (Arg_Kind = A_Defining_Expanded_Name) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Declarations.Defining_Prefix");
end if;
Arg_Node := Node (Defining_Name);
Result_Node := Sinfo.Name (Arg_Node);
if Nkind (Result_Node) = N_Identifier then
Result_Kind := An_Identifier;
else
Result_Kind := A_Selected_Component;
end if;
return Node_To_Element_New (
Node => Result_Node,
Starting_Element => Defining_Name,
Internal_Kind => Result_Kind);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Defining_Name,
Outer_Call => "Asis.Declarations.Defining_Prefix");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Defining_Name,
Diagnosis => "Asis.Declarations.Defining_Prefix");
end Defining_Prefix;
-------------------------------------------------------------------------
function Defining_Selector
(Defining_Name : in Asis.Defining_Name)
return Asis.Defining_Name
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Defining_Name);
Arg_Node : Node_Id;
begin
Check_Validity (Defining_Name, "Asis.Declarations.Defining_Selector");
if not (Arg_Kind = A_Defining_Expanded_Name) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Declarations.Defining_Selector");
end if;
Arg_Node := Node (Defining_Name);
return Node_To_Element_New (
Node => Defining_Identifier (Arg_Node),
Starting_Element => Defining_Name,
Internal_Kind => A_Defining_Identifier);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Defining_Name,
Outer_Call => "Asis.Declarations.Defining_Selector");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Defining_Name,
Diagnosis => "Asis.Declarations.Defining_Selector");
end Defining_Selector;
-------------------------------------------------------------------------
function Discriminant_Part
(Declaration : in Asis.Declaration)
return Asis.Definition
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
begin
Check_Validity (Declaration, "Asis.Declarations.Discriminant_Part");
if not (Arg_Kind = An_Ordinary_Type_Declaration or else
Arg_Kind = A_Task_Type_Declaration or else
Arg_Kind = A_Protected_Type_Declaration or else
Arg_Kind = An_Incomplete_Type_Declaration or else
Arg_Kind = A_Private_Type_Declaration or else
Arg_Kind = A_Private_Extension_Declaration or else
Arg_Kind = A_Formal_Type_Declaration)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Declarations.Discriminant_Part");
end if;
-- There is no appropriate Node in the tree to map the Asis Element
-- of the An_Unknown_Discriminant_Part or A_Known_Discriminant_Part
-- Definition_Kinds values. So the (non-nil) result of this function
-- contains just the same value in the field Node as the argument,
-- but it differs in the value of the Internal_Kind fields.
Arg_Node := Node (Declaration);
if Present (Discriminant_Specifications (Arg_Node)) then
return Node_To_Element_New
(Node => Arg_Node,
Starting_Element => Declaration,
Internal_Kind => A_Known_Discriminant_Part);
elsif Arg_Kind = An_Ordinary_Type_Declaration or else
Arg_Kind = A_Task_Type_Declaration or else
Arg_Kind = A_Protected_Type_Declaration
then
return Nil_Element;
elsif Unknown_Discriminants_Present (Arg_Node) then
return Node_To_Element_New
(Node => Arg_Node,
Starting_Element => Declaration,
Internal_Kind => An_Unknown_Discriminant_Part);
else
return Nil_Element;
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Discriminant_Part");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Discriminant_Part");
end Discriminant_Part;
-----------------------------------------------------------------------
function Type_Declaration_View
(Declaration : in Asis.Declaration)
return Asis.Type_Definition
is
Arg_Node : Node_Id;
Decl_Kind : Internal_Element_Kinds;
Result_Node : Node_Id;
Result_Internal_Kind : Internal_Element_Kinds;
begin
Check_Validity (Declaration, "Asis.Declarations.Type_Declaration_View");
Decl_Kind := Int_Kind (Declaration);
if not (Decl_Kind = An_Ordinary_Type_Declaration or else
Decl_Kind = A_Task_Type_Declaration or else
Decl_Kind = A_Protected_Type_Declaration or else
Decl_Kind = A_Private_Type_Declaration or else
Decl_Kind = A_Private_Extension_Declaration or else
Decl_Kind = A_Subtype_Declaration or else
Decl_Kind = A_Formal_Type_Declaration)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Declarations.Type_Declaration_View");
end if;
-- tree traversing:
-- first, we have to detect whether we have the declaration of a
-- root or universal numeric type, and if we have, we should
-- process it in a special way:
if Is_Root_Num_Type (Declaration) then
return Root_Type_Definition (Declaration);
end if;
-- forming the result for incompete and private types:
Arg_Node := Node (Declaration);
case Decl_Kind is
when A_Private_Type_Declaration |
A_Private_Extension_Declaration
=>
-- There is no appropriate Node in the tree to map the Asis
-- Element of the
--
-- A_Private_Type_Definition,
-- A_Tagged_Private_Type_Definition,
-- A_Private_Extension_Definition,
--
-- Definition_Kind values. So the result of this function
-- for the A_Private_Type_Declaration or
-- A_Private_Extension_Declaration passed as the argument
-- contains just the same value in the field Node as the , but
-- argument it differs in the values of the Kind and
-- Internal_Kind fields.
if Decl_Kind = A_Private_Extension_Declaration then
Result_Internal_Kind := A_Private_Extension_Definition;
elsif Tagged_Present (Arg_Node) then
Result_Internal_Kind := A_Tagged_Private_Type_Definition;
else
Result_Internal_Kind := A_Private_Type_Definition;
end if;
return Node_To_Element_New
(Node => Arg_Node,
Starting_Element => Declaration,
Internal_Kind => Result_Internal_Kind);
when An_Ordinary_Type_Declaration =>
Result_Node := Sinfo.Type_Definition (Arg_Node);
when A_Task_Type_Declaration =>
Result_Node := Task_Definition (Arg_Node);
if No (Result_Node) then
return Nil_Element;
end if;
when A_Protected_Type_Declaration =>
Result_Node := Protected_Definition (Arg_Node);
when A_Subtype_Declaration =>
Result_Node := Sinfo.Subtype_Indication (Arg_Node);
return Node_To_Element_New
(Node => Result_Node,
Starting_Element => Declaration,
Internal_Kind => A_Subtype_Indication);
-- Automatic Element Kind determination is also possible
-- here, but it seems unnecessary
when A_Formal_Type_Declaration =>
Result_Node := Sinfo.Formal_Type_Definition (Arg_Node);
when others =>
null;
end case;
-- forming the result for other kinds of types:
return Node_To_Element_New
(Node => Result_Node,
Starting_Element => Declaration);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Type_Declaration_View");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Type_Declaration_View");
end Type_Declaration_View;
------------------------------------------------------------------------
function Object_Declaration_View
(Declaration : in Asis.Declaration)
return Asis.Type_Definition
is
Arg_Node : Node_Id;
Decl_Kind : Internal_Declaration_Kinds;
Result_Node : Node_Id;
Result_Internal_Kind : Internal_Element_Kinds;
begin
Check_Validity (Declaration,
"Asis.Declarations.Object_Declaration_View");
Decl_Kind := Int_Kind (Declaration);
if not (Decl_Kind = A_Variable_Declaration or else
Decl_Kind = A_Constant_Declaration or else
Decl_Kind = A_Deferred_Constant_Declaration or else
Decl_Kind = A_Single_Protected_Declaration or else
Decl_Kind = A_Single_Task_Declaration or else
Decl_Kind = A_Component_Declaration)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Declarations.Object_Declaration_View");
end if;
Arg_Node := Node (Declaration);
case Decl_Kind is
when A_Variable_Declaration |
A_Constant_Declaration |
A_Deferred_Constant_Declaration =>
Result_Node := Object_Definition (Arg_Node);
if Nkind (Result_Node) = N_Constrained_Array_Definition then
Result_Internal_Kind := A_Constrained_Array_Definition;
else
Result_Internal_Kind := A_Subtype_Indication;
end if;
when A_Component_Declaration =>
Result_Node := Sinfo.Subtype_Indication (Arg_Node);
Result_Internal_Kind := A_Component_Definition;
when A_Single_Protected_Declaration =>
Result_Node := Protected_Definition (Arg_Node);
Result_Internal_Kind := A_Protected_Definition;
when A_Single_Task_Declaration =>
Result_Node := Task_Definition (Arg_Node);
Result_Internal_Kind := A_Task_Definition;
if No (Result_Node) then
return Nil_Element;
end if;
when others =>
null; -- see the condition for defining the appropriate argument
end case;
return Node_To_Element_New
(Node => Result_Node,
Starting_Element => Declaration,
Internal_Kind => Result_Internal_Kind);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Object_Declaration_View");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Object_Declaration_View");
end Object_Declaration_View;
--------------------------------------------------------------------------
function Initialization_Expression
(Declaration : in Asis.Declaration)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
Result_Node : Node_Id;
begin
Check_Validity
(Declaration, "Asis.Declarations.Initialization_Expression");
if not (Arg_Kind = A_Variable_Declaration or else
Arg_Kind = A_Constant_Declaration or else
Arg_Kind = An_Integer_Number_Declaration or else
Arg_Kind = A_Real_Number_Declaration or else
Arg_Kind = A_Discriminant_Specification or else
Arg_Kind = A_Component_Declaration or else
Arg_Kind = A_Parameter_Specification or else
Arg_Kind = A_Formal_Object_Declaration)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Declarations.Initialization_Expression");
end if;
Arg_Node := Node (Declaration);
Result_Node := Sinfo.Expression (Arg_Node);
if No (Result_Node) then
return Nil_Element;
else
-- --------- debugging for record attributes ----
-- --------- ??? GNAT exception is being raised for now. Why??? ----
--
-- Put_Debug_Line ("Initialization_Expression: Result Node: ");
-- Debug_New_Line;
-- Put_Debug_Node (Result_Node, "->");
-- Debug_new_line;
--
-- if Is_Rewrite_Substitution (Result_Node) then
-- Put_Debug_Line ("Result Node is rewritten, original node is:");
-- Debug_new_line;
-- Put_Debug_Node
-- (Original_Node (Result_Node), "Original Node ->");
-- Debug_new_line;
--
-- if Nkind (Original_Node (Result_Node)) = N_Aggregate then
-- Put_Debug_Node_list (Component_Associations
-- (Original_Node (Result_Node)), "Aggregeate Associations");
-- Debug_new_line;
-- Put_Debug_Node_list (Sinfo.Expressions --GNAT 3.05 ERROR?
-- (Original_Node (Result_Node)), "Aggregeate Expressions");
-- Debug_new_line;
-- end if;
-- Debug_new_line;
-- end if;
--
-- --------- end debugging for record attributes ----
return Node_To_Element_New
(Node => Result_Node,
Starting_Element => Declaration);
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Initialization_Expression");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Initialization_Expression");
end Initialization_Expression;
-----------------------------------------------------------------------
function Corresponding_Constant_Declaration
(Name : in Asis.Defining_Name)
return Asis.Declaration
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Name);
Arg_Node : Node_Id;
Arg_Decl_Node : Node_Id;
Result_Node : Node_Id;
begin
Check_Validity (Name,
"Asis.Declarations.Corresponding_Constant_Declaration");
Arg_Node := Node (Name);
Arg_Decl_Node := Parent (Arg_Node);
if not (Arg_Kind = A_Defining_Identifier and then
Nkind (Arg_Decl_Node) = N_Object_Declaration and then
Constant_Present (Arg_Decl_Node))
then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
"Asis.Declarations.Corresponding_Constant_Declaration");
end if;
-- first, we should find out, where we are - in a constant
-- declaration or in a deferred constant declaration:
if Present (Sinfo.Expression (Parent (Arg_Node))) then
-- we are in a full constant declaration.
-- Here we have to traverse the tree to find the corresponding
-- deferred constant declaration, if any. To optimize the search,
-- we first check if we are in the private part of a package.
--
-- Unfortunately, in 3.10a Is_Private is set on for enttities
-- declared immediatelly within package bodies, so we have
-- to do the corresponding check "by hands"::
if not (Nkind (Parent (Arg_Decl_Node)) =
N_Package_Specification
and then
List_Containing (Arg_Decl_Node) =
Private_Declarations (Parent (Arg_Decl_Node)))
then
-- it cannot be a completion of a deferred constant,
-- see RM95 7.4(4)
return Nil_Element;
end if;
-- and here we have to go into the visible part of the same
-- package and to look for the same defining name in it:
Result_Node := First_Non_Pragma (Visible_Declarations (Parent (
Parent (Arg_Node))));
while Present (Result_Node) loop
if Nkind (Result_Node) = N_Object_Declaration and then
Constant_Present (Result_Node) and then
No (Sinfo.Expression (Result_Node)) and then
Full_View (Defining_Identifier (Result_Node)) = Arg_Node
then
return Node_To_Element
(Node => Result_Node,
Internal_Kind => A_Deferred_Constant_Declaration,
In_Unit => Encl_Unit (Name));
end if;
Result_Node := Next_Non_Pragma (Result_Node);
end loop;
-- here we are only if there is no declaration of a deferred
-- constant corresponding to the given full constant declaration,
-- so:
return Nil_Element;
else
-- we are in deferred constant declaration
if Is_Imported (Arg_Node) then
-- a deferred constant completed by a pragma Import
return Nil_Element;
end if;
Result_Node := Parent (Full_View (Arg_Node));
return Node_To_Element_New
(Node => Result_Node,
Starting_Element => Name,
Internal_Kind => A_Constant_Declaration);
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Name,
Outer_Call =>
"Asis.Declarations.Corresponding_Constant_Declaration");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Name,
Diagnosis =>
"Asis.Declarations.Corresponding_Constant_Declaration");
end Corresponding_Constant_Declaration;
--------------------------------------------------------------------------
function Declaration_Subtype_Mark
(Declaration : in Asis.Declaration)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
Result_Node : Node_Id;
Result_Kind : Internal_Element_Kinds := Not_An_Element;
begin
Check_Validity (Declaration,
"Asis.Declarations.Declaration_Subtype_Mark");
if not (Arg_Kind = A_Discriminant_Specification or else
Arg_Kind = A_Parameter_Specification or else
Arg_Kind = A_Formal_Object_Declaration or else
Arg_Kind = An_Object_Renaming_Declaration)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Declarations.Declaration_Subtype_Mark");
end if;
Arg_Node := Node (Declaration);
if Arg_Kind = A_Formal_Object_Declaration or else
Arg_Kind = An_Object_Renaming_Declaration
then
Result_Node := Sinfo.Subtype_Mark (Arg_Node);
elsif Arg_Kind = A_Discriminant_Specification then
Result_Node := Discriminant_Type (Arg_Node);
else -- Arg_Kind = A_Parameter_Specification
Result_Node := Parameter_Type (Arg_Node);
end if;
if Nkind (Result_Node) = N_Access_Definition then
Result_Node := Sinfo.Subtype_Mark (Result_Node);
end if;
-- if the result node is of N_Attribute_Reference kind, we should
-- define the kind of this attribute, so general Node_To_Element
-- function is used, otherwise we set An_Identifier or
-- A_Selected_Component result kind "by hand"
-- starting from GNAT 3.09, the compiler rewrite the node corresponding
-- to the attribute reference in the a context like this:
-- function "**" (Left: Precision_Float; Right: Integer'Base)
-- ^^^^^^^^^^^^^^^^^^^^
if Nkind (Result_Node) = N_Attribute_Reference or else
(Is_Rewrite_Substitution (Result_Node) and then
Nkind (Original_Node (Result_Node)) = N_Attribute_Reference)
then
null;
-- not a very elegant solution, but the idea is to keep
-- Result_Kind set to Not_An_Element and not to disturb the old
-- workable code
elsif Nkind (Result_Node) = N_Identifier then
Result_Kind := An_Identifier;
else
Result_Kind := A_Selected_Component;
end if;
return Node_To_Element_New
(Node => Result_Node,
Starting_Element => Declaration,
Internal_Kind => Result_Kind);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Declaration_Subtype_Mark");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Declaration_Subtype_Mark");
end Declaration_Subtype_Mark;
----------------------------------------------------------------------
function Corresponding_Type_Declaration
(Declaration : in Asis.Declaration)
return Asis.Declaration
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
Arg_Unit : Asis.Compilation_Unit;
Entity_Node : Node_Id;
Result_Node : Node_Id;
Result_Unit : Asis.Compilation_Unit := Nil_Compilation_Unit;
Arg_Element : Asis.Declaration;
begin
Check_Validity (Declaration,
"Asis.Declarations.Corresponding_Type_Declaration");
if not (Arg_Kind = An_Ordinary_Type_Declaration or else
Arg_Kind = A_Task_Type_Declaration or else
Arg_Kind = A_Protected_Type_Declaration or else
Arg_Kind = An_Incomplete_Type_Declaration or else
Arg_Kind = A_Private_Type_Declaration or else
Arg_Kind = A_Private_Extension_Declaration)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Declarations.Corresponding_Type_Declaration");
end if;
-- this query can cross compilation unit boundaries for an
-- incomplete type defined in the private part of a library
-- package spec and completed in the package body.
Arg_Node := R_Node (Declaration);
Entity_Node := Defining_Identifier (Arg_Node);
Arg_Unit := Get_Comp_Unit
(Encl_Unit_Id (Declaration), Encl_Cont_Id (Declaration));
if Arg_Kind = An_Incomplete_Type_Declaration or else
Arg_Kind = A_Private_Type_Declaration or else
Arg_Kind = A_Private_Extension_Declaration
then
-- finding the full view for incomplete/private type
Result_Node := Full_View (Entity_Node);
if No (Result_Node) then
-- for a legal Ada unit it is possible only for
-- An_Incomplete_Type_Declaration in the private part of a
-- package, privided that enclosing unit is a library package or
-- a library generic package.
Result_Unit := Corresponding_Body (Arg_Unit);
if not Exists (Result_Unit) then
return Nil_Element;
else
Arg_Element := Declaration;
Reset_For_Body (Arg_Element, Result_Unit);
Arg_Node := R_Node (Arg_Element);
Entity_Node := Defining_Identifier (Arg_Node);
Result_Node := Full_View (Entity_Node);
end if;
end if;
else
-- trying to find the private/incomplete view, if any
Result_Node := Serach_First_View (Entity_Node);
if Result_Node = Entity_Node then
-- no private/incolplete view, therefore:
return Nil_Element;
end if;
end if;
-- and, finally, one step up from the defining name to the
-- corresponding type declaration
Result_Node := Parent (Result_Node);
-- if we are here, Result_Node is not Empty!
pragma Assert (Present (Result_Node));
if not Exists (Result_Unit) then
Result_Unit :=
Enclosing_Unit (Encl_Cont_Id (Declaration), Result_Node);
end if;
return Node_To_Element_New (Node => Result_Node,
In_Unit => Result_Unit);
exception
when Assert_Error : System.Assertions.Assert_Failure =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis =>
"Asis.Declarations.Corresponding_Type_Declaration - " & LT
& "Assert_Failure at "
& Ada.Exceptions.Exception_Message (Assert_Error));
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Corresponding_Type_Declaration");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Corresponding_Type_Declaration");
end Corresponding_Type_Declaration;
------------------------------------------------------------------------
-- NOT IMPLEMENTED
function Corresponding_Type_Declaration
(Declaration : in Asis.Declaration;
The_Context : in Asis.Context) return Asis.Declaration
is
Arg_Node : Node_Id;
begin
Check_Validity (Declaration,
"Asis.Declarations.Corresponding_Type_Declaration");
Check_Validity (The_Context,
"Asis.Declarations.Corresponding_Type_Declaration");
Arg_Node := Node (Declaration);
Not_Implemented_Yet (Diagnosis =>
"Asis.Declarations.Corresponding_Type_Declaration");
-- ASIS_Failed is raised, Not_Implemented_Error status is setted
return Nil_Element; -- to make the code syntactically correct
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call =>
"Asis.Declarations.Corresponding_Type_Declaration");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis =>
"Asis.Declarations.Corresponding_Type_Declaration");
end Corresponding_Type_Declaration;
----------------------------------------------------------------
function Corresponding_First_Subtype
(Declaration : in Asis.Declaration)
return Asis.Declaration
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
Result_Node : Node_Id;
Result_Kind : Internal_Element_Kinds := Not_An_Element;
Result_Unit : Asis.Compilation_Unit;
begin
Check_Validity (Declaration,
"Asis.Declarations.Corresponding_First_Subtype");
if not (Arg_Kind = An_Ordinary_Type_Declaration or else
Arg_Kind = A_Task_Type_Declaration or else
Arg_Kind = A_Protected_Type_Declaration or else
Arg_Kind = A_Private_Type_Declaration or else
Arg_Kind = A_Private_Extension_Declaration or else
Arg_Kind = A_Subtype_Declaration or else
Arg_Kind = A_Formal_Type_Declaration)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Declarations.Corresponding_First_Subtype");
end if;
if Arg_Kind = An_Ordinary_Type_Declaration or else
Arg_Kind = A_Task_Type_Declaration or else
Arg_Kind = A_Protected_Type_Declaration or else
Arg_Kind = A_Private_Type_Declaration or else
Arg_Kind = A_Private_Extension_Declaration or else
Arg_Kind = A_Formal_Type_Declaration
then
return Declaration;
end if;
Arg_Node := Node (Declaration);
-- now we are processing a subtype declaration, therefore Arg_Node
-- is of N_Subtype_Declaration kind
pragma Assert (Nkind (Arg_Node) = N_Subtype_Declaration);
Result_Node := Einfo.First_Subtype (Defining_Identifier (Arg_Node));
-- We are in the suntype declaration now, so we can detect this
-- situation like this:
if Result_Node = Defining_Identifier (Arg_Node) then
Result_Node := Sinfo.Subtype_Indication (Arg_Node);
if Nkind (Result_Node) = N_Subtype_Indication then
Result_Node := Sinfo.Subtype_Mark (Result_Node);
end if;
Result_Node := Entity (Result_Node);
while Nkind (Parent (Result_Node)) = N_Subtype_Declaration loop
Result_Node := Sinfo.Subtype_Indication (Parent (Result_Node));
if Nkind (Result_Node) = N_Subtype_Indication then
Result_Node := Sinfo.Subtype_Mark (Result_Node);
end if;
Result_Node := Entity (Result_Node);
end loop;
end if;
-- and now - from defining name to the corresponding type declaration:
if No (Parent (Result_Node)) then
if Is_Itype (Result_Node) then
-- for now, the only discovered case is the subtyping
-- from a formal array type.
Result_Node := Associated_Node_For_Itype (Result_Node);
else
-- for now, the only truly discovered case when
-- Parent (Result_Node) is Empty and Is_Itype is NOT set on
-- is when Result_Node points
-- to the implicit entity created by the compiler for
-- a formal integer type. In this case the following approach
-- should work:
Result_Node := Next_Entity (Result_Node);
end if;
end if;
if Nkind (Result_Node) = N_Defining_Identifier then
-- we should not do this step up when Associated_Node_For_Itype
-- has been applied!
Result_Node := Parent (Result_Node);
end if;
Result_Unit := Enclosing_Unit (Encl_Cont_Id (Declaration), Result_Node);
return Node_To_Element_New (Node => Result_Node,
Internal_Kind => Result_Kind,
In_Unit => Result_Unit);
exception
when Assert_Error : System.Assertions.Assert_Failure =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis =>
"Asis.Declarations.Corresponding_First_Subtype - " & LT
& "Assert_Failure at "
& Ada.Exceptions.Exception_Message (Assert_Error));
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call =>
"Asis.Declarations.Corresponding_First_Subtype");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis =>
"Asis.Declarations.Corresponding_First_Subtype");
end Corresponding_First_Subtype;
----------------------------------------------------------------
function Corresponding_Last_Constraint
(Declaration : in Asis.Declaration)
return Asis.Declaration
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
Result_Node : Node_Id;
Result_Unit : Asis.Compilation_Unit;
begin
Check_Validity (Declaration,
"Asis.Declarations.Corresponding_Last_Constraint");
if not (Arg_Kind = An_Ordinary_Type_Declaration or else
Arg_Kind = A_Task_Type_Declaration or else
Arg_Kind = A_Protected_Type_Declaration or else
Arg_Kind = A_Private_Type_Declaration or else
Arg_Kind = A_Private_Extension_Declaration or else
Arg_Kind = A_Subtype_Declaration or else
Arg_Kind = A_Formal_Type_Declaration)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Declarations.Corresponding_Last_Constraint");
end if;
if Arg_Kind = An_Ordinary_Type_Declaration or else
Arg_Kind = A_Task_Type_Declaration or else
Arg_Kind = A_Protected_Type_Declaration or else
Arg_Kind = A_Private_Type_Declaration or else
Arg_Kind = A_Private_Extension_Declaration or else
Arg_Kind = A_Formal_Type_Declaration
then
return Declaration;
end if;
Arg_Node := Node (Declaration);
-- now we are processing a subtype declaration, therefore Arg_Node
-- is of N_Subtype_Declaration kind
Result_Node := Sinfo.Subtype_Indication (Arg_Node);
if Nkind (Result_Node) = N_Subtype_Indication then
Result_Node := Sinfo.Subtype_Mark (Result_Node);
end if;
Result_Node := Parent (Entity (Result_Node));
while Nkind (Result_Node) = N_Subtype_Declaration and then
Nkind (Sinfo.Subtype_Indication (Result_Node)) /=
N_Subtype_Indication
loop
Result_Node := Sinfo.Subtype_Indication (Result_Node);
if Nkind (Result_Node) = N_Subtype_Indication then
Result_Node := Sinfo.Subtype_Mark (Result_Node);
end if;
Result_Node := Parent (Entity (Result_Node));
end loop;
Result_Unit := Enclosing_Unit (Encl_Cont_Id (Declaration), Result_Node);
return Node_To_Element_New (Node => Result_Node,
In_Unit => Result_Unit);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call =>
"Asis.Declarations.Corresponding_Last_Constraint");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis =>
"Asis.Declarations.Corresponding_Last_Constraint");
end Corresponding_Last_Constraint;
----------------------------------------------------------------
function Corresponding_Last_Subtype
(Declaration : in Asis.Declaration) return Asis.Declaration
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
Result_Node : Node_Id;
Result_Unit : Asis.Compilation_Unit;
begin
Check_Validity (Declaration,
"Asis.Declarations.Corresponding_Last_Subtype");
if not (Arg_Kind = An_Ordinary_Type_Declaration or else
Arg_Kind = A_Task_Type_Declaration or else
Arg_Kind = A_Protected_Type_Declaration or else
Arg_Kind = A_Private_Type_Declaration or else
Arg_Kind = A_Private_Extension_Declaration or else
Arg_Kind = A_Subtype_Declaration or else
Arg_Kind = A_Formal_Type_Declaration)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Declarations.Corresponding_Last_Subtype");
end if;
if Arg_Kind = An_Ordinary_Type_Declaration or else
Arg_Kind = A_Task_Type_Declaration or else
Arg_Kind = A_Protected_Type_Declaration or else
Arg_Kind = A_Private_Type_Declaration or else
Arg_Kind = A_Private_Extension_Declaration or else
Arg_Kind = A_Formal_Type_Declaration
then
return Declaration;
end if;
Arg_Node := Node (Declaration);
-- now we are processing a subtype declaration, therefore Arg_Node
-- is of N_Subtype_Declaration kind
Result_Node := Sinfo.Subtype_Indication (Arg_Node);
if Nkind (Result_Node) = N_Subtype_Indication then
Result_Node := Sinfo.Subtype_Mark (Result_Node);
end if;
Result_Node := Parent (Entity (Result_Node));
Result_Unit := Enclosing_Unit (Encl_Cont_Id (Declaration), Result_Node);
return Node_To_Element_New (Node => Result_Node,
In_Unit => Result_Unit);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Corresponding_Last_Subtype");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Corresponding_Last_Subtype");
end Corresponding_Last_Subtype;
------------------------------------------------------------------
function Corresponding_Representation_Clauses
(Declaration : in Asis.Declaration)
return Asis.Representation_Clause_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id := Node (Declaration);
Arg_Node_Kind : Node_Kind := Nkind (Arg_Node);
Entity_Node : Node_Id;
First_Rep_Item_Node : Node_Id;
Next_Rep_Item_Node : Node_Id;
Max_Res_Len : ASIS_Integer := 0;
begin
Check_Validity (Declaration,
"Asis.Declarations.Corresponding_Representation_Clauses");
if not (Arg_Kind in Internal_Declaration_Kinds) then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
"Asis.Declarations.Corresponding_Representation_Clauses");
end if;
-- first, we have to get entity from the declaration:
if Arg_Node_Kind = N_Subprogram_Declaration or else
Arg_Node_Kind = N_Abstract_Subprogram_Declaration or else
Arg_Node_Kind = N_Subprogram_Body or else
Arg_Node_Kind = N_Package_Declaration or else
Arg_Node_Kind = N_Package_Declaration or else
Arg_Node_Kind = N_Subprogram_Renaming_Declaration or else
Arg_Node_Kind = N_Generic_Package_Declaration or else
Arg_Node_Kind = N_Generic_Subprogram_Declaration or else
Arg_Node_Kind = N_Formal_Subprogram_Declaration
then
Entity_Node := Defining_Unit_Name (Specification (Arg_Node));
elsif
Arg_Node_Kind = N_Package_Body or else
Arg_Node_Kind = N_Package_Renaming_Declaration or else
Arg_Node_Kind = N_Generic_Package_Renaming_Declaration or else
Arg_Node_Kind = N_Generic_Procedure_Renaming_Declaration or else
Arg_Node_Kind = N_Generic_Function_Renaming_Declaration or else
Arg_Node_Kind = N_Package_Instantiation or else
Arg_Node_Kind = N_Procedure_Instantiation or else
Arg_Node_Kind = N_Function_Instantiation
then
Entity_Node := Defining_Unit_Name (Arg_Node);
elsif
Arg_Node_Kind = N_Defining_Identifier or else
Arg_Node_Kind = N_Defining_Character_Literal
then
Entity_Node := Arg_Node;
else
Entity_Node := Defining_Identifier (Arg_Node);
end if;
if Nkind (Entity_Node) = N_Defining_Program_Unit_Name then
Entity_Node := Defining_Identifier (Entity_Node);
end if;
-- now we compute the maximum possible length of the result by
-- traversing the list of the representation items that apply to the
-- corresponding entity
First_Rep_Item_Node := First_Rep_Item (Entity_Node);
Next_Rep_Item_Node := First_Rep_Item_Node;
while Present (Next_Rep_Item_Node) loop
Max_Res_Len := Max_Res_Len + 1;
Next_Rep_Item_Node := Next_Rep_Item (Next_Rep_Item_Node);
end loop;
-- now Max_Res_Len is equal to the whole number of all the
-- representatation items that apply to the given entity, including
-- representation pragmas and possible duplications of representation
-- clauses
if Max_Res_Len = 0 then
return Nil_Element_List;
end if;
declare
Res : Element_List (1 .. Max_Res_Len);
Res_Len : ASIS_Integer := 0;
Actual_Repr_Cl : array (N_Representation_Clause)
of Boolean := (others => True);
Rep_Node_Kind : Node_Kind;
begin
-- we go through the whole list of the representation items once
-- again, and we create in Res the list of elements
-- representing the representation clauses that apply to the
-- given entity, and we use Actual_Repr_Cl boolean array to
-- filter out all the possible duplications for derived types.
Next_Rep_Item_Node := First_Rep_Item_Node;
while Present (Next_Rep_Item_Node) loop
Rep_Node_Kind := Nkind (Next_Rep_Item_Node);
if (Rep_Node_Kind in N_Representation_Clause) and then
(Rep_Node_Kind /= N_Mod_Clause)
-- N_Mod_Clause nodes are not used by ASIS
then
if Actual_Repr_Cl (Rep_Node_Kind) then
Res_Len := Res_Len + 1;
Res (Res_Len) := Node_To_Element_New ( -- ???
Starting_Element => Declaration,
Node => Next_Rep_Item_Node);
Actual_Repr_Cl (Rep_Node_Kind) := False;
end if;
end if;
Next_Rep_Item_Node := Next_Rep_Item (Next_Rep_Item_Node);
end loop;
return Res (1 .. Res_Len);
end;
exception
when Assert_Error : System.Assertions.Assert_Failure =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis =>
"Asis.Declarations.Corresponding_Representation_Clauses - " & LT
& "Assert_Failure at "
& Ada.Exceptions.Exception_Message (Assert_Error));
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call =>
"Asis.Declarations.Corresponding_Representation_Clauses");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis =>
"Asis.Declarations.Corresponding_Representation_Clauses");
end Corresponding_Representation_Clauses;
-----------------------------------------------------------------------
function Specification_Subtype_Definition
(Specification : in Asis.Declaration)
return Asis.Discrete_Subtype_Definition
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Specification);
Arg_Node : Node_Id;
Result_Node : Node_Id;
Result_Kind : Internal_Element_Kinds;
Result_Node_Kind : Node_Kind;
begin
Check_Validity (Specification,
"Asis.Declarations.Specification_Subtype_Definition");
if not (Arg_Kind = A_Loop_Parameter_Specification or else
Arg_Kind = An_Entry_Index_Specification)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis =>
"Asis.Declarations.Specification_Subtype_Definition");
end if;
Arg_Node := Node (Specification);
Result_Node := Sinfo.Discrete_Subtype_Definition (Arg_Node);
Result_Node_Kind := Nkind (Original_Node (Result_Node));
if (Result_Node_Kind = N_Subtype_Indication or else
Result_Node_Kind = N_Identifier or else
Result_Node_Kind = N_Expanded_Name)
then
Result_Kind := A_Discrete_Subtype_Indication_As_Subtype_Definition;
elsif Result_Node_Kind = N_Attribute_Reference then
Result_Kind :=
A_Discrete_Range_Attribute_Reference_As_Subtype_Definition;
elsif Result_Node_Kind = N_Range then
Result_Kind :=
A_Discrete_Simple_Expression_Range_As_Subtype_Definition;
else
-- unespected Node Kind for DISCRETE_SUBTYPE_DEFINITION!!!
Raise_ASIS_Failed (Diagnosis =>
"Unexpected Node Kind "
& Node_Kind'Image (Nkind (Result_Node))
& " for DISCRETE_SUBTYPE_DEFINITION ");
end if;
return Node_To_Element_New
(Node => Result_Node,
Starting_Element => Specification,
Internal_Kind => Result_Kind);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Specification,
Outer_Call =>
"Asis.Declarations.Specification_Subtype_Definition");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Specification,
Diagnosis => "Asis.Declarations.Specification_Subtype_Definition");
end Specification_Subtype_Definition;
-------------------------------------------------------------------
function Parameter_Profile
(Declaration : in Asis.Declaration)
return Asis.Parameter_Specification_List
is
Arg_Node : Node_Id;
Decl_Kind : Internal_Element_Kinds;
Result_List : List_Id;
begin
Check_Validity (Declaration, "Asis.Declarations.Parameter_Profile");
Decl_Kind := Int_Kind (Declaration);
if not (Decl_Kind = A_Procedure_Declaration or else
Decl_Kind = A_Function_Declaration or else
Decl_Kind = A_Procedure_Body_Declaration or else
Decl_Kind = A_Function_Body_Declaration or else
Decl_Kind = A_Procedure_Renaming_Declaration or else
Decl_Kind = A_Function_Renaming_Declaration or else
Decl_Kind = An_Entry_Declaration or else
Decl_Kind = An_Entry_Body_Declaration or else
Decl_Kind = A_Procedure_Body_Stub or else
Decl_Kind = A_Function_Body_Stub or else
Decl_Kind = A_Generic_Procedure_Declaration or else
Decl_Kind = A_Generic_Function_Declaration or else
Decl_Kind = A_Formal_Procedure_Declaration or else
Decl_Kind = A_Formal_Function_Declaration)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Declarations.Parameter_Profile");
end if;
Arg_Node := Node (Declaration);
if (Decl_Kind = A_Procedure_Declaration or else
Decl_Kind = A_Function_Declaration or else
Decl_Kind = A_Procedure_Body_Declaration or else
Decl_Kind = A_Function_Body_Declaration or else
Decl_Kind = A_Procedure_Renaming_Declaration or else
Decl_Kind = A_Function_Renaming_Declaration or else
Decl_Kind = A_Procedure_Body_Stub or else
Decl_Kind = A_Function_Body_Stub or else
Decl_Kind = A_Generic_Procedure_Declaration or else
Decl_Kind = A_Generic_Function_Declaration or else
Decl_Kind = A_Formal_Procedure_Declaration or else
Decl_Kind = A_Formal_Function_Declaration)
then
Result_List := Parameter_Specifications (Specification (Arg_Node));
elsif Decl_Kind = An_Entry_Declaration then
Result_List := Parameter_Specifications (Arg_Node);
else
-- elsif Decl_Kind = An_Entry_Body_Declaration
Result_List := Parameter_Specifications
(Entry_Body_Formal_Part (Arg_Node));
end if;
if No (Result_List) then
return Nil_Element_List;
else
return N_To_E_List_New (List => Result_List,
Starting_Element => Declaration,
Internal_Kind => A_Parameter_Specification);
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Parameter_Profile");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Parameter_Profile");
end Parameter_Profile;
-----------------------------------------------------------------------
function Result_Profile
(Declaration : in Asis.Declaration)
return Asis.Expression
is
Arg_Node : Node_Id;
Decl_Kind : Internal_Element_Kinds;
Result_Node : Node_Id;
Result_Kind : Internal_Element_Kinds := Not_An_Element;
begin
Check_Validity (Declaration, "Asis.Declarations.Result_Profile");
Decl_Kind := Int_Kind (Declaration);
if not (Decl_Kind = A_Function_Declaration or else
Decl_Kind = A_Function_Body_Declaration or else
Decl_Kind = A_Function_Renaming_Declaration or else
Decl_Kind = A_Function_Body_Stub or else
Decl_Kind = A_Generic_Function_Declaration or else
Decl_Kind = A_Formal_Function_Declaration)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Declarations.Result_Profile");
end if;
Arg_Node := Node (Declaration);
Result_Node := Sinfo.Subtype_Mark (Specification (Arg_Node));
if Nkind (Original_Node (Result_Node)) = N_Attribute_Reference then
null;
-- the idea is to keep Result_Kind indefined. May be,
-- this is not very elegant, but we do not want to
-- disturb the old workable code
elsif Nkind (Result_Node) = N_Identifier then
Result_Kind := An_Identifier;
else
Result_Kind := A_Selected_Component;
end if;
return Node_To_Element_New (
Node => Result_Node,
Starting_Element => Declaration,
Internal_Kind => Result_Kind);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Result_Profile");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Result_Profile");
end Result_Profile;
----------------------------------------------------------------------
function Body_Declarative_Items
(Declaration : in Asis.Declaration;
Include_Pragmas : in Boolean := False)
return Asis.Declarative_Item_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
begin
Check_Validity (Declaration,
"Asis.Declarations.Body_Declarative_Items");
if not (Arg_Kind = A_Function_Body_Declaration or else
Arg_Kind = A_Procedure_Body_Declaration or else
Arg_Kind = A_Package_Body_Declaration or else
Arg_Kind = A_Task_Body_Declaration or else
Arg_Kind = An_Entry_Body_Declaration)
then
Raise_ASIS_Inappropriate_Element
("Asis.Declarations.Body_Declarative_Items");
end if;
Arg_Node := Node (Declaration);
return N_To_E_List_New
(List => Sinfo.Declarations (Arg_Node),
Include_Pragmas => Include_Pragmas,
Starting_Element => Declaration);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Body_Declarative_Items",
Bool_Par => Include_Pragmas);
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Body_Declarative_Items",
Bool_Par => Include_Pragmas);
end Body_Declarative_Items;
----------------------------------------------------------------------
function Body_Statements
(Declaration : in Asis.Declaration;
Include_Pragmas : in Boolean := False)
return Asis.Statement_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
begin
Check_Validity (Declaration, "Asis.Declarations.Body_Statements");
if not (Arg_Kind = A_Function_Body_Declaration or else
Arg_Kind = A_Procedure_Body_Declaration or else
Arg_Kind = A_Package_Body_Declaration or else
Arg_Kind = A_Task_Body_Declaration or else
Arg_Kind = An_Entry_Body_Declaration)
then
Raise_ASIS_Inappropriate_Element
("Asis.Declarations.Body_Statements");
end if;
Arg_Node := Node (Declaration);
return Statements_Node_To_Element_List (
Statements_Seq => Handled_Statement_Sequence (Arg_Node),
Include_Pragmas => Include_Pragmas,
Starting_Element => Declaration);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Body_Statements",
Bool_Par => Include_Pragmas);
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Body_Statements",
Bool_Par => Include_Pragmas);
end Body_Statements;
---------------------------------------------------------------------
function Body_Exception_Handlers
(Declaration : in Asis.Declaration;
Include_Pragmas : in Boolean := False)
return Asis.Exception_Handler_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
begin
Check_Validity (Declaration,
"Asis.Declarations.Body_Exception_Handlers");
if not (Arg_Kind = A_Function_Body_Declaration
or Arg_Kind = A_Procedure_Body_Declaration
or Arg_Kind = A_Package_Body_Declaration
or Arg_Kind = A_Task_Body_Declaration
or Arg_Kind = An_Entry_Body_Declaration)
then
Raise_ASIS_Inappropriate_Element
("Asis.Declarations.Body_Exception_Handlers");
end if;
Arg_Node := Node (Declaration);
if No (Handled_Statement_Sequence (Arg_Node)) then
return Nil_Element_List;
elsif Include_Pragmas then
return N_To_E_List_With_Pragmas
(List => Exception_Handlers (
Handled_Statement_Sequence (Arg_Node)),
In_Unit => Encl_Unit (Declaration));
else
return N_To_E_List_Without_Pragmas
(List => Exception_Handlers (
Handled_Statement_Sequence (Arg_Node)),
In_Unit => Encl_Unit (Declaration));
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Body_Exception_Handlers",
Bool_Par => Include_Pragmas);
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Body_Exception_Handlers",
Bool_Par => Include_Pragmas);
end Body_Exception_Handlers;
------------------------------------------------------------------------
-- |GNAT-ASIS: If the body passed as the actual have no decrative items
-- |GNAT-ASIS on its own, the result of the functiuon will not test
-- |GNAT-ASIS Statements.Is_Declare_Block
function Body_Block_Statement
(Declaration : in Asis.Declaration)
return Asis.Statement
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
begin
Check_Validity (Declaration,
"Asis.Declarations.Body_Block_Statement");
if not (Arg_Kind = A_Function_Body_Declaration or else
Arg_Kind = A_Procedure_Body_Declaration or else
Arg_Kind = A_Package_Body_Declaration or else
Arg_Kind = A_Task_Body_Declaration or else
Arg_Kind = An_Entry_Body_Declaration)
then
Raise_ASIS_Inappropriate_Element
("Asis.Declarations.Body_Block_Statement");
end if;
Arg_Node := Node (Declaration);
-- the dummy block statement is created on the base on the
-- argument's node; it requires the special processing to be
-- performed by the block-related functions from Asis_Statements.
return Node_To_Element_New (
Node => Arg_Node,
Starting_Element => Declaration,
Internal_Kind => A_Block_Statement,
Spec_Case => A_Dummy_Block_Statement);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Body_Block_Statement");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Body_Block_Statement");
end Body_Block_Statement;
------------------------------------------------------------------------------
function Is_Name_Repeated (Declaration : in Asis.Declaration)
return Boolean
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
Last_Comp : Asis.Element;
S : Source_Ptr;
Result : Boolean;
begin
Check_Validity (Declaration, "Asis.Declarations.Is_Name_Repeated");
if not (Arg_Kind = A_Package_Declaration or else
Arg_Kind = A_Package_Body_Declaration or else
Arg_Kind = A_Procedure_Body_Declaration or else
Arg_Kind = A_Function_Body_Declaration or else
Arg_Kind = A_Generic_Package_Declaration or else
Arg_Kind = A_Task_Type_Declaration or else
Arg_Kind = A_Single_Task_Declaration or else
Arg_Kind = A_Task_Body_Declaration or else
Arg_Kind = A_Protected_Type_Declaration or else
Arg_Kind = A_Single_Protected_Declaration or else
Arg_Kind = A_Protected_Body_Declaration or else
Arg_Kind = An_Entry_Body_Declaration)
then
return False;
end if;
Arg_Node := Node (Declaration);
-- the only need for this operator is to reset the tree. Probably, this
-- is not a good style, and we need a procedure resetting Context and
-- tree for an Element if needed
if Arg_Kind = A_Task_Type_Declaration or else
Arg_Kind = A_Single_Task_Declaration or else
Arg_Kind = A_Protected_Type_Declaration or else
Arg_Kind = A_Single_Protected_Declaration
then
-- this situation differs from the rest of the appropriate element
-- kinds, because here we have to analyse type or object declaration
-- view as the last component, and the potentially repeated name is
-- a part of this component:
if Arg_Kind = A_Task_Type_Declaration or else
Arg_Kind = A_Protected_Type_Declaration
then
Last_Comp := Type_Declaration_View (Declaration);
else
Last_Comp := Object_Declaration_View (Declaration);
end if;
if Is_Nil (Last_Comp) then
-- this is the case for a single task or task type declaration
-- without any entry declaration. such a declaration does not
-- contain a "is ... end" part in its structure, therefore there
-- is no "end" for a name to repeat after:
Result := False;
else
-- here we have the end after which the name may be repeated in
-- the very end of Last_Comp:
S := Set_Image_End (Last_Comp);
if not (Get_Character (S) = 'd' or else
Get_Character (S) = 'D')
then
Result := True;
elsif not (Get_Character (S - 1) = 'n' or else
Get_Character (S - 1) = 'N')
then
Result := True;
elsif not (Get_Character (S - 2) = 'e' or else
Get_Character (S - 2) = 'E')
then
Result := True;
elsif not (Get_Character (S - 3) = ' ') then
Result := True;
else
Result := False;
end if;
end if;
else
-- here we are in the situation when the "end" to repeat the name
-- after is not a part of any subcomponent of Declaration
Last_Comp := Get_Last_Component (Declaration);
S := Set_Image_End (Last_Comp);
S := S + 1;
S := Rightmost_Non_Blank (S);
-- there may be a patological case of a package or protected spec
-- with no declaration inside, moreover, in such a case a protected
-- type declaration may or may not contain a discriminant part
if (Get_Character (S) = 'i' or else Get_Character (S) = 'I') then
-- the reserved word IS is the only possibility here, therefore:
S := S + 2;
S := Rightmost_Non_Blank (S);
end if;
-- here the only possibility for S is to point to the beginning
-- of the trailing "end" of the declaration:
S := S + 3;
-- the first character after "end"
S := Rightmost_Non_Blank (S);
-- and the final check - what follows the final "end"
if Get_Character (S) = ';' then
Result := False;
else
Result := True;
end if;
end if;
return Result;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call =>
"Asis.Declarations.Is_Name_Repeated");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Is_Name_Repeated");
end Is_Name_Repeated;
------------------------------------------------------------------------------
function Corresponding_Declaration
(Declaration : in Asis.Declaration)
return Asis.Declaration
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
Inherited : Boolean := Is_From_Inherited (Declaration);
Result_Node : Node_Id;
Result_Kind : Internal_Element_Kinds := Not_An_Element;
Result_Spec_Case : Special_Cases := Not_A_Special_Case;
Argument_Unit : Asis.Compilation_Unit;
Result_Unit : Asis.Compilation_Unit;
begin
Check_Validity (Declaration,
"Asis.Declarations.Corresponding_Declaration");
-- Appropriate Declaration_Kinds returning the argument Declaration:
if (Arg_Kind = A_Function_Declaration and then not Inherited) or else
Arg_Kind = A_Generic_Function_Declaration or else
Arg_Kind = A_Generic_Package_Declaration or else
Arg_Kind = A_Generic_Procedure_Declaration or else
Arg_Kind = A_Package_Declaration or else
Arg_Kind = A_Package_Renaming_Declaration or else
(Arg_Kind = A_Procedure_Declaration and then not Inherited) or else
Arg_Kind = A_Single_Task_Declaration or else
Arg_Kind = A_Task_Type_Declaration or else
Arg_Kind = A_Single_Protected_Declaration or else
Arg_Kind = A_Protected_Type_Declaration
then
return Declaration;
end if;
-- Appropriate Declaration_Kinds returning a specification -
-- first, checking the argument kind:
if not (Arg_Kind = A_Function_Declaration or else
Arg_Kind = A_Function_Body_Declaration or else
Arg_Kind = A_Function_Body_Stub or else
Arg_Kind = A_Function_Instantiation or else
Arg_Kind = A_Function_Renaming_Declaration or else
Arg_Kind = A_Package_Body_Declaration or else
Arg_Kind = A_Package_Body_Stub or else
Arg_Kind = A_Package_Instantiation or else
Arg_Kind = A_Procedure_Declaration or else
Arg_Kind = A_Procedure_Body_Declaration or else
Arg_Kind = A_Procedure_Body_Stub or else
Arg_Kind = A_Procedure_Instantiation or else
Arg_Kind = A_Procedure_Renaming_Declaration or else
Arg_Kind = A_Task_Body_Declaration or else
Arg_Kind = A_Task_Body_Stub or else
Arg_Kind = A_Protected_Body_Declaration or else
Arg_Kind = A_Protected_Body_Stub or else
Arg_Kind = A_Formal_Package_Declaration) -- ???
then
Raise_ASIS_Inappropriate_Element
("Asis.Declarations.Corresponding_Declaration");
end if;
-- and here we have to (try to) return the corresponding spec:
--
-- There are the following cases:
--
-- 1. A body which is the library_item of some compilation
-- unit;
-- 2. Bodies declared immediately within a library package/library
-- generic package, but it does not make any problem for this
-- query, because the tree containong a package body also
-- contains the package spec;
-- 3. Generic instantiations;
-- 3.1 Formal package declrations (this is ASIS-for-GNAT-specific and
-- we beleive, that in fact this is a fix of the hole in the
-- ASIS definition
-- 4. making the difference between renaming-as-declaration and
-- renaming-as-body (the problem does not exist together with
-- the case No.1);
-- 5. body stubs
-- 7. declarations of implicit inherited subprograms
-- 6. The "common" case;
-- 8. ???
if Arg_Kind = A_Function_Instantiation then
Result_Kind := A_Function_Declaration;
Result_Spec_Case := Expanded_Subprogram_Instantiation;
elsif Arg_Kind = A_Procedure_Instantiation then
Result_Kind := A_Procedure_Declaration;
Result_Spec_Case := Expanded_Subprogram_Instantiation;
elsif Arg_Kind = A_Package_Instantiation or else
Arg_Kind = A_Formal_Package_Declaration -- ???
then
Result_Kind := A_Package_Declaration;
Result_Spec_Case := Expanded_Package_Instantiation;
end if;
-- first, we compute the result enclosing unit, and we return
-- Nil_Element if it is Nil_Compilation_Unit or if it is
-- of Nonexistent kind:
Argument_Unit := Get_Comp_Unit
(Encl_Unit_Id (Declaration), Encl_Cont_Id (Declaration));
-- 1. A body which is the library_item of some compilation unit
if Is_Identical (Declaration, Unit_Declaration (Argument_Unit)) then
if Class (Argument_Unit) = A_Public_Declaration_And_Body or else
Kind (Argument_Unit) in A_Subunit
then
return Nil_Element;
elsif not (Arg_Kind = A_Function_Instantiation or else
Arg_Kind = A_Package_Instantiation or else
Arg_Kind = A_Procedure_Instantiation or else
Arg_Kind = A_Formal_Package_Declaration) -- ???
then
Result_Unit := Corresponding_Declaration (Argument_Unit);
if not Exists (Result_Unit) then
return Nil_Element;
-- Note, that this case includes the cases when the spec of a
-- library unit is inconsistent with its body. We prefer to
-- return a nil result instead of raising an exception.
--
-- Note also, that this makes the implementation of this query
-- "inconsistency-safe"
else
return Unit_Declaration (Result_Unit);
end if;
else
-- here we have to return the expanded generic specification:
Result_Node := Unit (Top (Argument_Unit));
-- note, that in case of a library-level generic instantiation,
-- this is a rewritten node!
if Arg_Kind = A_Function_Instantiation or else
Arg_Kind = A_Procedure_Instantiation
then
-- the difference between the library-level package
-- instantiation and the library-level function or procedure
-- instantiation is that in the latter case the compiler
-- creates the artificial enclosing package:
-- Note, that this path may not work correctly because of the
-- bug in the tree structure for library-level subprogram
-- instantiations
Result_Node :=
Last (Visible_Declarations (Specification (Result_Node)));
else
-- In case of a package instantiations, the node is rewritten
-- in package body node in case if the generic unit has a body
if Nkind (Result_Node) = N_Package_Body then
Result_Node := Corresponding_Spec (Result_Node);
Result_Node := Parent (Parent (Result_Node));
end if;
end if;
return Node_To_Element_New
(Node => Result_Node,
Internal_Kind => Result_Kind,
Spec_Case => Result_Spec_Case,
Using_Original_Node => False,
Starting_Element => Declaration);
end if;
end if;
-- filtering out some special cases:
if (Arg_Kind = A_Function_Renaming_Declaration or else
Arg_Kind = A_Procedure_Renaming_Declaration)
and then
not Is_Renaming_As_Body (Declaration)
then
-- renaming-as-declaration - the argument element
-- should be returned
return Declaration;
elsif Acts_As_Spec (Declaration) then
-- subprogram body or subprogram body stub with no explicit spec:
return Nil_Element;
end if;
-- and now - processing the general case, in which we separate the
-- following situations:
-- - generic instantiations - the expanded templaye should be returned
-- - a declaration of an implicit inherited subprogram - the
-- corresponding explicit user-defined subprogran should be returned;
-- - all the rest
Arg_Node := Node (Declaration);
-- this resets the tree if needed!
if Arg_Kind = A_Function_Instantiation or else
Arg_Kind = A_Procedure_Instantiation or else
Arg_Kind = A_Package_Instantiation or else
Arg_Kind = A_Formal_Package_Declaration -- ???
then
Result_Node := Get_Expanded_Spec (Arg_Node);
Result_Unit := Argument_Unit;
elsif Inherited then
-- coming from the declaration of implicit ihherited subprogram to
-- the corresponding explicit declaration of user-defined subprogram,
-- from which it was ultimately inherited
Result_Node := Arg_Node;
while Present (Alias (Result_Node)) loop
Result_Node := Alias (Result_Node);
end loop;
-- and now - up the tree to the declaration node
if Is_Generic_Instance (Result_Node) then
Result_Node :=
Next (Parent (Parent (Parent (Parent (Result_Node)))));
else
Result_Node := Parent (Result_Node);
if Nkind (Result_Node) = N_Procedure_Specification or else
Nkind (Result_Node) = N_Function_Specification
then
Result_Node := Parent (Result_Node);
end if;
end if;
Result_Unit :=
Enclosing_Unit (Encl_Cont_Id (Declaration), Result_Node);
else
-- and, finally, the general case
Result_Node := Corresponding_Decl_Node (Arg_Node);
-- Note, that when called here, Corresponding_Decl_Node should
-- return some non-Empty node.
-- and here we should check the situation when the corresponding
-- declaration is located in another Compilation Unit.
if Is_From_Instance (Declaration) then
Result_Unit := Argument_Unit;
else
Result_Unit :=
Enclosing_Unit (Encl_Cont_Id (Declaration), Result_Node);
end if;
end if;
-- if not Is_Identical (Result_Unit, Argument_Unit) then
-- -- and here we have to check if Result_Unit and Argument_Unit
-- -- are consistent. Result_Unit is a supporter of Argument_Unit
-- if not Is_Consistent (Result_Unit, Argument_Unit) then
-- return Nil_Element;
-- end if;
-- end if;
if Special_Case (Declaration) in Expanded_Spec then
Result_Spec_Case := Special_Case (Declaration);
end if;
return Node_To_Element_New (Node => Result_Node,
Internal_Kind => Result_Kind,
Spec_Case => Result_Spec_Case,
In_Unit => Result_Unit);
exception
when Assert_Error : System.Assertions.Assert_Failure =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis =>
"Asis.Declarations.Corresponding_Declaration - " & LT
& "Assert_Failure at "
& Ada.Exceptions.Exception_Message (Assert_Error));
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Corresponding_Declaration");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Corresponding_Declaration");
end Corresponding_Declaration;
-----------------------------------------------------------------------------
-- NOT IMPLEMENTED
function Corresponding_Declaration
(Declaration : in Asis.Declaration;
The_Context : in Asis.Context)
return Asis.Declaration
is
Arg_Node : Node_Id;
begin
Check_Validity (Declaration,
"Asis.Declarations.Corresponding_Declaration");
Check_Validity (The_Context,
"Asis.Declarations.Corresponding_Declaration");
Arg_Node := Node (Declaration);
Not_Implemented_Yet (Diagnosis =>
"Asis.Declarations.Corresponding_Declaration");
-- ASIS_Failed is raised, Not_Implemented_Error status is setted
return Nil_Element; -- to make the code syntactically correct
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Corresponding_Declaration");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Corresponding_Declaration");
end Corresponding_Declaration;
------------------------------------------------------------------------------
function Corresponding_Body
(Declaration : in Asis.Declaration)
return Asis.Declaration
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
Arg_Element : Asis.Declaration := Declaration;
Result_Node : Node_Id := Empty;
Result_Kind : Internal_Element_Kinds := Not_An_Element;
Result_Spec_Case : Special_Cases := Not_A_Special_Case;
Argument_Unit : Asis.Compilation_Unit;
Result_Unit : Asis.Compilation_Unit;
Use_Original_Node : Boolean := True;
Success : Boolean := False;
begin
Check_Validity (Declaration, "Asis.Declarations.Corresponding_Body");
-- Appropriate Declaration_Kinds returning the argument Declaration:
if Arg_Kind = A_Function_Body_Declaration or else
Arg_Kind = A_Function_Body_Stub or else
Arg_Kind = A_Function_Renaming_Declaration or else
Arg_Kind = A_Package_Body_Declaration or else
Arg_Kind = A_Package_Body_Stub or else
Arg_Kind = A_Package_Renaming_Declaration or else
Arg_Kind = A_Procedure_Body_Declaration or else
Arg_Kind = A_Procedure_Renaming_Declaration or else
Arg_Kind = A_Procedure_Body_Stub or else
Arg_Kind = A_Task_Body_Declaration or else
Arg_Kind = A_Task_Body_Stub or else
Arg_Kind = A_Protected_Body_Declaration or else
Arg_Kind = A_Protected_Body_Stub
then
return Arg_Element;
end if;
-- Appropriate Declaration_Kinds returning a body:
if not (Arg_Kind = A_Function_Declaration or else
Arg_Kind = A_Function_Instantiation or else
Arg_Kind = A_Generic_Package_Declaration or else
Arg_Kind = A_Generic_Procedure_Declaration or else
Arg_Kind = A_Generic_Function_Declaration or else
Arg_Kind = A_Package_Declaration or else
Arg_Kind = A_Package_Instantiation or else
Arg_Kind = A_Procedure_Declaration or else
Arg_Kind = A_Procedure_Instantiation or else
Arg_Kind = A_Single_Task_Declaration or else
Arg_Kind = A_Task_Type_Declaration or else
Arg_Kind = A_Protected_Type_Declaration or else
Arg_Kind = A_Single_Protected_Declaration)
then
Raise_ASIS_Inappropriate_Element
("Asis.Declarations.Corresponding_Body");
end if;
if (Arg_Kind = A_Function_Declaration or else
Arg_Kind = A_Procedure_Declaration)
and then
Is_From_Inherited (Declaration)
then
-- for an implicit inherited subprogram ASIS Corresponding_Body is
-- a body of an explicit subprogram from which it is inherited
-- (possibly indirectly)
Arg_Element := Corresponding_Declaration (Declaration);
if Is_Nil (Arg_Element) then
-- this stands hare because implicit consracts are supported
-- only partially for ASIS (???)
return Nil_Element;
end if;
else
Arg_Element := Declaration;
-- in case if Declaration is in a library package spec and the
-- package body is not in the eclosing element's tree, Arg_Element
-- should be reset to Is_Equial Element ontained from the tree
-- for the package body, but we are trying to do this expensive
-- operation only when it is really necessary.
end if;
Arg_Kind := Int_Kind (Arg_Element);
if Arg_Kind = A_Function_Instantiation then
Result_Kind := A_Function_Body_Declaration;
Result_Spec_Case := Expanded_Subprogram_Instantiation;
elsif Arg_Kind = A_Procedure_Instantiation then
Result_Kind := A_Procedure_Body_Declaration;
Result_Spec_Case := Expanded_Subprogram_Instantiation;
elsif Arg_Kind = A_Package_Instantiation or else
Arg_Kind = A_Formal_Package_Declaration -- ???
then
Result_Kind := A_Package_Body_Declaration;
Result_Spec_Case := Expanded_Package_Instantiation;
end if;
-- and for these cases we return the corresponding body, if any:
--
-- A_Function_Declaration
-- A_Generic_Package_Declaration
-- A_Generic_Procedure_Declaration
-- A_Generic_Function_Declaration
-- A_Package_Declaration
-- A_Procedure_Declaration
-- A_Single_Task_Declaration
-- A_Task_Type_Declaration
-- A_Protected_Type_Declaration
-- A_Single_Protected_Declaration
-- A_Function_Instantiation
-- A_Package_Instantiation
-- A_Procedure_Instantiation
--
-- There are following cases which require special processing:
-- 1. Program units declared within a library package or a library
-- generic package (directly or within a nested package)- we have
-- to use the tree containing the corresponding library unit body,
-- if any, otherwise Corresponding_Body will be Nil_Element;
-- 2. renaming-as-body: in this case in the tree the Corresponding_Body
-- field set for nodes representing declarations which can (must)
-- have bodies as completions points not to the corresponding
-- renaming declaration, but to the body implicitly created by the
-- compiler;
-- 3. Library-level program units
-- 4. Expanded generic bodies
Argument_Unit := Get_Comp_Unit
(Encl_Unit_Id (Arg_Element), Encl_Cont_Id (Arg_Element));
if Result_Spec_Case in Expanded_Spec or else
Is_From_Instance (Arg_Element)
then
-- ??? Expanded_Spec should be renamed as Expanded_Generic
Result_Unit := Argument_Unit;
else
Result_Unit := Corresponding_Body (Argument_Unit);
-- Note, that this is not a correct enclosing unit for a result
-- in case for a subprogram declared in a local pakage for which
-- the package body is presented by the stub. So we'll have to
-- recompute Result_Unit before forming a result.
if Is_Identical (Arg_Element, Unit_Declaration (Argument_Unit)) then
if not Exists (Result_Unit) then
return Nil_Element;
-- what else could we do?
else
return Unit_Declaration (Result_Unit);
end if;
end if;
end if;
Arg_Node := R_Node (Arg_Element);
-- this resets the tree!
-- we use R_Node, because a single task declaration is rewritten
-- in a task type declaration, and the Corresponding_Body field
-- is not set for the original node
-- if we are here, we have Arg_Element as some declaration inside the
-- spec of a library package or library generic package (may be, nested
-- in a local subpackage). There are two possibilities for a
-- corresponding body (which is to be a completion of Arg_Element):
-- renaming as a body in the library (generic) package spec or
-- some construct in the corresponding library package body.
-- For the second possibility, we have to be in the tree created for
-- a package body (if any) to be able to compute the corresponding
-- body for Arg_Element. But if Arg_Element is obtained from the tree
-- containing only spec for this package, we have to recompute
-- Arg_Element from the tree for the package body. It is expansive,
-- and we would like to avoid this if possible.
if Arg_Kind = A_Function_Declaration or else
Arg_Kind = A_Procedure_Declaration
then
Result_Node := Get_Renaming_As_Body (Node => Arg_Node,
Spec_Only => True);
if Present (Result_Node) then
-- this means, that the subprogram declaration is completed
-- by renaming-as-body already in the package spec, and we can
-- return the non-nil result without dealing with the body
-- of this package
if Arg_Kind = A_Function_Declaration then
Result_Kind := A_Function_Renaming_Declaration;
else
Result_Kind := A_Procedure_Renaming_Declaration;
end if;
return Node_To_Element_New -- ???
(Node => Result_Node,
Internal_Kind => Result_Kind,
Starting_Element => Arg_Element);
end if;
end if;
-- if we are here, Arg_Element is not completed in the spec of the
-- library (generic) package, so we need the corresponding package
-- body, and we may for sure return Nil_Element if the body is
-- absent:
if not Exists (Result_Unit) then
return Nil_Element;
end if;
if Result_Spec_Case in Expanded_Spec then
-- ??? two cases are really possible here:
-- ??? instance -> expanded body
-- ??? and
-- ??? expaded spec -> expanded body
Result_Node := Get_Expanded_Body (Arg_Node);
if Nkind (Result_Node) = N_Package_Declaration then
-- This corresponds to the situation when we came to the
-- instantiation of a library package from some tree created for
-- a unit which "withes" this instantiation. This tree does not
-- contain the expanded body. So we have to go to the tree whih
-- has this library-level package instantiation as its main unit
-- (if any)
Reset_Main_Tree (Argument_Unit, Success);
if Success then
Result_Node := Unit (Top (Argument_Unit));
else
return Nil_Element;
end if;
end if;
-- The following is needed for library-level package instantiations
Use_Original_Node := False;
if No (Result_Node) then
return Nil_Element;
end if;
else
if Is_From_Instance (Arg_Element) and then
Kind (Encl_Unit (Arg_Element)) = A_Package_Instance
then
Reset_For_Lib_Level_Instantiation (Arg_Element);
else
Reset_For_Body (Arg_Element, Result_Unit);
end if;
Arg_Node := R_Node (Arg_Element);
Result_Node := Corresponding_Body_Node (Arg_Node);
end if;
if Special_Case (Declaration) in Expanded_Spec then
Result_Spec_Case := Special_Case (Declaration);
end if;
Result_Unit :=
Enclosing_Unit (Encl_Cont_Id (Declaration), Result_Node);
return Node_To_Element_New
(Node => Result_Node,
Internal_Kind => Result_Kind,
Spec_Case => Result_Spec_Case,
Using_Original_Node => Use_Original_Node,
In_Unit => Result_Unit);
exception
when Assert_Error : System.Assertions.Assert_Failure =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis =>
"Asis.Declarations.Corresponding_Body - " & LT
& "Assert_Failure at "
& Ada.Exceptions.Exception_Message (Assert_Error));
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Corresponding_Body");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Corresponding_Body");
end Corresponding_Body;
------------------------------------------------------------------------------
-- NOT IMPLEMENTED
function Corresponding_Body
(Declaration : in Asis.Declaration;
The_Context : in Asis.Context)
return Asis.Declaration
is
Arg_Node : Node_Id;
begin
Check_Validity (Declaration, "Asis.Declarations.Corresponding_Body");
Check_Validity (The_Context, "Asis.Declarations.Corresponding_Body");
Arg_Node := Node (Declaration);
Not_Implemented_Yet (Diagnosis =>
"Asis.Declarations.Corresponding_Body");
-- ASIS_Failed is raised, Not_Implemented_Error status is setted
return Nil_Element; -- to make the code syntactically correct
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Corresponding_Body");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Corresponding_Body");
end Corresponding_Body;
------------------------------------------------------------------------------
function Corresponding_Subprogram_Derivation
(Declaration : in Asis.Declaration)
return Asis.Declaration
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Result_Unit : Asis.Compilation_Unit;
Result_Node : Node_Id;
Result_Kind : Internal_Element_Kinds := Not_An_Element;
Inherited : Boolean := False;
begin
Check_Validity (Declaration,
"Asis.Declarations.Corresponding_Subprogram_Derivation");
if not ((Arg_Kind = A_Function_Declaration or else
Arg_Kind = A_Procedure_Declaration)
and then
Is_From_Inherited (Declaration))
then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
"Asis.Declarations.Corresponding_Subprogram_Derivation");
end if;
Result_Node := Alias (Node (Declaration));
-- and now - up the tree to the declaration node if needed
if No (Alias (Result_Node)) then
Result_Node := Parent (Result_Node);
if Nkind (Result_Node) = N_Procedure_Specification or else
Nkind (Result_Node) = N_Function_Specification
then
Result_Node := Parent (Result_Node);
end if;
else
Inherited := True;
if Arg_Kind = A_Function_Declaration then
Result_Kind := A_Function_Declaration;
else
Result_Kind := A_Procedure_Declaration;
end if;
end if;
Result_Unit := Enclosing_Unit (Encl_Cont_Id (Declaration), Result_Node);
return Node_To_Element_New
(Node => Result_Node,
Internal_Kind => Result_Kind,
Inherited => Inherited,
In_Unit => Result_Unit);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call =>
"Asis.Declarations.Corresponding_Subprogram_Derivation");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis =>
"Asis.Declarations.Corresponding_Subprogram_Derivation");
end Corresponding_Subprogram_Derivation;
------------------------------------------------------------------------------
function Corresponding_Type
(Declaration : in Asis.Declaration)
return Asis.Type_Definition
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Result_Node : Node_Id;
Result_Unit : Asis.Compilation_Unit;
begin
Check_Validity (Declaration, "Asis.Declarations.Corresponding_Type");
if not ((Arg_Kind = A_Function_Declaration or else
Arg_Kind = A_Procedure_Declaration)
and then
Is_From_Implicit (Declaration))
then
Raise_ASIS_Inappropriate_Element
("Asis.Declarations.Corresponding_Type");
end if;
Result_Node := Parent (Node_Field_1 (Declaration));
Result_Unit := Enclosing_Unit (Encl_Cont_Id (Declaration), Result_Node);
return Node_To_Element_New (Node => Result_Node,
In_Unit => Result_Unit);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Corresponding_Type");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Corresponding_Type");
end Corresponding_Type;
------------------------------------------------------------------------------
-- NOT IMPLEMENTED
function Corresponding_Equality_Operator
(Declaration : in Asis.Declaration) return Asis.Declaration
is
Arg_Node : Node_Id;
begin
Check_Validity (Declaration,
"Asis.Declarations.Corresponding_Equality_Operator");
Arg_Node := Node (Declaration);
Not_Implemented_Yet (Diagnosis =>
"Asis.Declarations.Corresponding_Equality_Operator");
-- ASIS_Failed is raised, Not_Implemented_Error status is setted
return Nil_Element; -- to make the code syntactically correct
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Corresponding_Equality_Operator");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Corresponding_Equality_Operator");
end Corresponding_Equality_Operator;
-----------------------------------------------------------------------------
function Visible_Part_Declarative_Items
(Declaration : in Asis.Declaration;
Include_Pragmas : in Boolean := False)
return Asis.Declarative_Item_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
begin
Check_Validity (Declaration,
"Asis.Declarations.Visible_Part_Declarative_Items");
if not (Arg_Kind = A_Package_Declaration or else
Arg_Kind = A_Generic_Package_Declaration)
then
Raise_ASIS_Inappropriate_Element
("Asis.Declarations.Visible_Part_Declarative_Items");
end if;
Arg_Node := Node (Declaration);
return N_To_E_List_New
(List => Visible_Declarations (Specification (Arg_Node)),
Include_Pragmas => Include_Pragmas,
Starting_Element => Declaration);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Visible_Part_Declarative_Items",
Bool_Par => Include_Pragmas);
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Visible_Part_Declarative_Items",
Bool_Par => Include_Pragmas);
end Visible_Part_Declarative_Items;
------------------------------------------------------------------------------
function Is_Private_Present
(Declaration : in Asis.Declaration)
return Boolean
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
begin
Check_Validity (Declaration, "Asis.Declarations.Is_Private_Present");
if not (Arg_Kind = A_Package_Declaration or else
Arg_Kind = A_Generic_Package_Declaration)
then
return False; -- unexpected element
end if;
Arg_Node := Node (Declaration);
return Present (Private_Declarations (Specification (Arg_Node)));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Is_Private_Present");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Is_Private_Present");
end Is_Private_Present;
------------------------------------------------------------------------------
function Private_Part_Declarative_Items
(Declaration : in Asis.Declaration;
Include_Pragmas : in Boolean := False)
return Asis.Declarative_Item_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
begin
Check_Validity (Declaration,
"Asis.Declarations.Private_Part_Declarative_Items");
if not (Arg_Kind = A_Package_Declaration or else
Arg_Kind = A_Generic_Package_Declaration)
then
Raise_ASIS_Inappropriate_Element
("Private_Part_Declarative_Items");
end if;
Arg_Node := Node (Declaration);
return N_To_E_List_New
(List => Private_Declarations (Specification (Arg_Node)),
Include_Pragmas => Include_Pragmas,
Starting_Element => Declaration);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Private_Part_Declarative_Items",
Bool_Par => Include_Pragmas);
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Private_Part_Declarative_Items",
Bool_Par => Include_Pragmas);
end Private_Part_Declarative_Items;
------------------------------------------------------------------------------
function Renamed_Entity
(Declaration : in Asis.Declaration)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
Result_Node : Node_Id;
Result_Kind : Internal_Element_Kinds := Not_An_Element;
begin
Check_Validity (Declaration, "Asis.Declarations.Renamed_Entity");
if not (Arg_Kind = An_Object_Renaming_Declaration or else
Arg_Kind = An_Exception_Renaming_Declaration or else
Arg_Kind = A_Package_Renaming_Declaration or else
Arg_Kind = A_Procedure_Renaming_Declaration or else
Arg_Kind = A_Function_Renaming_Declaration or else
Arg_Kind = A_Generic_Package_Renaming_Declaration or else
Arg_Kind = A_Generic_Procedure_Renaming_Declaration or else
Arg_Kind = A_Generic_Function_Renaming_Declaration)
then
Raise_ASIS_Inappropriate_Element
("Asis.Declarations.Renamed_Entity");
end if;
Arg_Node := Node (Declaration);
Result_Node := Sinfo.Name (Arg_Node);
if Nkind (Result_Node) = N_Attribute_Reference then
Result_Kind := Subprogram_Attribute_Kind (Result_Node);
end if;
return Node_To_Element_New
(Node => Result_Node,
Internal_Kind => Result_Kind,
Starting_Element => Declaration);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Renamed_Entity");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Renamed_Entity");
end Renamed_Entity;
------------------------------------------------------------------------------
function Corresponding_Base_Entity
(Declaration : in Asis.Declaration)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
Result_Node : Node_Id := Empty;
Res_Kind : Node_Kind;
Result_Unit : Asis.Compilation_Unit;
begin
Check_Validity (Declaration,
"Asis.Declarations.Corresponding_Base_Entity");
if not (Arg_Kind = An_Object_Renaming_Declaration or else
Arg_Kind = An_Exception_Renaming_Declaration or else
Arg_Kind = A_Procedure_Renaming_Declaration or else
Arg_Kind = A_Function_Renaming_Declaration or else
Arg_Kind = A_Package_Renaming_Declaration or else
Arg_Kind = A_Generic_Package_Renaming_Declaration or else
Arg_Kind = A_Generic_Procedure_Renaming_Declaration or else
Arg_Kind = A_Generic_Function_Renaming_Declaration)
then
Raise_ASIS_Inappropriate_Element
("Asis.Declarations.Corresponding_Base_Entity");
end if;
Arg_Node := Node (Declaration);
-- the first renaming declaration in the renaming chain
Result_Node := Sinfo.Name (Arg_Node);
Arg_Node := R_Node (Declaration);
-- to be able to deal with renamings of task entries in a uniform way
while Present (Arg_Node) loop
if Is_Rewrite_Substitution (Arg_Node) and then
Nkind (Arg_Node) = N_Subprogram_Declaration
then
exit;
-- renaming a task entry as a subprogram, no renaming chain
-- any more
end if;
Res_Kind := Nkind (Result_Node);
if Res_Kind = N_Selected_Component or else
Res_Kind = N_Indexed_Component or else
Res_Kind = N_Explicit_Dereference or else
Res_Kind = N_Slice
then
if Nkind (Prefix (Result_Node)) = N_Function_Call then
exit;
-- if the object_name in a renaming declaration has a
-- function_call as its prefix, it cannot itself be defined by
-- (another) renaming declaration
end if;
Arg_Node := Entity (Sinfo.Prefix (Result_Node));
elsif Present (Entity (Result_Node)) then
Arg_Node := Entity (Result_Node);
else
null;
pragma Assert (False);
end if;
Arg_Node := Parent (Arg_Node);
if Nkind (Arg_Node) not in N_Renaming_Declaration then
-- we have achieved the end of the renaming chain
exit;
else
-- we are still in the chain
Result_Node := Sinfo.Name (Arg_Node);
end if;
end loop;
-- and now we have to compute the Result_Unit and to make the
-- consistency check:
Result_Unit := Enclosing_Unit
(Encl_Cont_Id (Declaration), Result_Node);
return Node_To_Element_New (Node => Result_Node,
In_Unit => Result_Unit);
exception
when Assert_Error : System.Assertions.Assert_Failure =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis =>
"Asis.Declarations.Corresponding_Base_Entity - " & LT
& "Assert_Failure at "
& Ada.Exceptions.Exception_Message (Assert_Error));
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Corresponding_Base_Entity");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Corresponding_Base_Entity");
end Corresponding_Base_Entity;
------------------------------------------------------------------------------
function Protected_Operation_Items
(Declaration : in Asis.Declaration;
Include_Pragmas : in Boolean := False)
return Asis.Declarative_Item_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
begin
Check_Validity (Declaration,
"Asis.Declarations.Protected_Operation_Items");
if not (Arg_Kind = A_Protected_Body_Declaration) then
Raise_ASIS_Inappropriate_Element
("Asis.Declarations.Protected_Operation_Items");
end if;
Arg_Node := Node (Declaration);
if Include_Pragmas then
return Node_To_Element_List
(List => Sinfo.Declarations (Arg_Node),
In_Unit => Encl_Unit (Declaration));
else
return Node_To_Element_List
(List => Sinfo.Declarations (Arg_Node),
In_Unit => Encl_Unit (Declaration),
To_Be_Included => No_Pragma'Access);
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Protected_Operation_Items",
Bool_Par => Include_Pragmas);
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Protected_Operation_Items",
Bool_Par => Include_Pragmas);
end Protected_Operation_Items;
------------------------------------------------------------------------------
function Entry_Family_Definition
(Declaration : in Asis.Declaration)
return Asis.Discrete_Subtype_Definition
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
Result_Node : Node_Id;
begin
Check_Validity (Declaration,
"Asis.Declarations.Entry_Family_Definition");
if not (Arg_Kind = An_Entry_Declaration) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Declarations.Entry_Family_Definition");
end if;
Arg_Node := Node (Declaration);
Result_Node := Sinfo.Discrete_Subtype_Definition (Arg_Node);
if Present (Result_Node) then
return Node_To_Element_New
(Node => Result_Node,
Starting_Element => Declaration);
else
return Nil_Element;
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Entry_Family_Definition");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Entry_Family_Definition");
end Entry_Family_Definition;
------------------------------------------------------------------------------
function Entry_Index_Specification
(Declaration : in Asis.Declaration)
return Asis.Declaration
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
Result_Node : Node_Id;
begin
Check_Validity (Declaration,
"Asis.Declarations.Entry_Index_Specification");
if not (Arg_Kind = An_Entry_Body_Declaration) then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
"Asis.Declarations.Entry_Index_Specification");
end if;
Arg_Node := Node (Declaration);
Result_Node := Entry_Index_Specification
(Entry_Body_Formal_Part (Arg_Node));
if Present (Result_Node) then
return Node_To_Element_New
(Node => Result_Node,
Starting_Element => Declaration,
Internal_Kind => An_Entry_Index_Specification);
else
return Nil_Element;
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Entry_Index_Specification");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Entry_Index_Specification");
end Entry_Index_Specification;
------------------------------------------------------------------------------
function Entry_Barrier
(Declaration : in Asis.Declaration)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
begin
Check_Validity (Declaration, "Asis.Declarations.Entry_Barrier");
if not (Arg_Kind = An_Entry_Body_Declaration) then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
"Asis.Declarations.Entry_Barrier");
end if;
Arg_Node := Node (Declaration);
return Node_To_Element_New
(Node => Condition (Entry_Body_Formal_Part (Arg_Node)),
Starting_Element => Declaration);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Entry_Barrier");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Entry_Barrier");
end Entry_Barrier;
------------------------------------------------------------------------------
function Corresponding_Subunit
(Body_Stub : in Asis.Declaration)
return Asis.Declaration
is
Arg_Node : Node_Id;
Arg_Kind : Internal_Element_Kinds := Int_Kind (Body_Stub);
Arg_Unit : Asis.Compilation_Unit;
Result_Subunit : Asis.Compilation_Unit;
begin
Check_Validity (Body_Stub, "Asis.Declarations.Corresponding_Subunit");
if not (Arg_Kind = A_Function_Body_Stub or else
Arg_Kind = A_Package_Body_Stub or else
Arg_Kind = A_Procedure_Body_Stub or else
Arg_Kind = A_Task_Body_Stub or else
Arg_Kind = A_Protected_Body_Stub)
then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
"Asis.Declarations.Corresponding_Subunit");
end if;
Arg_Node := Node (Body_Stub);
Arg_Unit := Encl_Unit (Body_Stub);
Result_Subunit := Get_Subunit (Parent_Body => Arg_Unit,
Stub_Node => Arg_Node);
if Exists (Result_Subunit) then
return Unit_Declaration (Result_Subunit);
else
return Nil_Element;
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Body_Stub,
Outer_Call => "Asis.Declarations.Corresponding_Subunit");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Body_Stub,
Diagnosis => "Asis.Declarations.Corresponding_Subunit");
end Corresponding_Subunit;
------------------------------------------------------------------------------
-- NOT IMPLEMENTED
function Corresponding_Subunit
(Body_Stub : in Asis.Declaration;
The_Context : in Asis.Context)
return Asis.Declaration
is
Arg_Node : Node_Id;
begin
Check_Validity (Body_Stub, "Asis.Declarations.Corresponding_Subunit");
Check_Validity (The_Context, "Asis.Declarations.Corresponding_Subunit");
Arg_Node := Node (Body_Stub);
Not_Implemented_Yet (Diagnosis =>
"Asis.Declarations.Corresponding_Subunit");
-- ASIS_Failed is raised, Not_Implemented_Error status is setted
return Nil_Element; -- to make the code syntactically correct
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Body_Stub,
Outer_Call => "Asis.Declarations.Corresponding_Subunit");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Body_Stub,
Diagnosis => "Asis.Declarations.Corresponding_Subunit");
end Corresponding_Subunit;
------------------------------------------------------------------------------
function Is_Subunit (Declaration : in Asis.Declaration) return Boolean
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_R_Node : Node_Id;
begin
Check_Validity (Declaration, "Asis.Declarations.Is_Subunit");
if not (Arg_Kind in Internal_Declaration_Kinds) then
return False;
else
Arg_R_Node := R_Node (Declaration);
return Nkind (Parent (Arg_R_Node)) = N_Subunit;
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Is_Subunit");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Is_Subunit");
end Is_Subunit;
------------------------------------------------------------------------------
function Corresponding_Body_Stub
(Subunit : in Asis.Declaration)
return Asis.Declaration
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Subunit);
Arg_Node : Node_Id;
Result_Node : Node_Id;
Result_Unit : Asis.Compilation_Unit;
begin
Check_Validity (Subunit, "Asis.Declarations.Corresponding_Body_Stub");
if not (Arg_Kind = A_Function_Body_Declaration or else
Arg_Kind = A_Package_Body_Declaration or else
Arg_Kind = A_Procedure_Body_Declaration or else
Arg_Kind = A_Task_Body_Declaration or else
Arg_Kind = A_Protected_Body_Declaration)
then
Raise_ASIS_Inappropriate_Element
("Asis.Declarations.Corresponding_Body_Stub");
end if;
Arg_Node := Node (Subunit);
Result_Node := Corresponding_Stub (Parent (Arg_Node));
Result_Unit := Enclosing_Unit
(Encl_Cont_Id (Subunit), Result_Node);
return Node_To_Element_New (Node => Result_Node,
In_Unit => Result_Unit);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Subunit,
Outer_Call => "Asis.Declarations.Corresponding_Body_Stub");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Subunit,
Diagnosis => "Asis.Declarations.Corresponding_Body_Stub");
end Corresponding_Body_Stub;
-----------------------------------------------------------------------------
-- NOT IMPLEMENTED
function Corresponding_Body_Stub
(Subunit : in Asis.Declaration;
The_Context : in Asis.Context)
return Asis.Declaration
is
Arg_Node : Node_Id;
begin
Check_Validity (Subunit, "Asis.Declarations.Corresponding_Body_Stub");
Check_Validity (
The_Context, "Asis.Declarations.Corresponding_Body_Stub");
Arg_Node := Node (Subunit);
Not_Implemented_Yet (Diagnosis =>
"Asis.Declarations.Corresponding_Body_Stub");
-- ASIS_Failed is raised, Not_Implemented_Error status is setted
return Nil_Element; -- to make the code syntactically correct
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Subunit,
Outer_Call => "Asis.Declarations.Corresponding_Body_Stub");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Subunit,
Diagnosis => "Asis.Declarations.Corresponding_Body_Stub");
end Corresponding_Body_Stub;
------------------------------------------------------------------------------
function Generic_Formal_Part
(Declaration : in Asis.Declaration;
Include_Pragmas : in Boolean := False)
return Asis.Generic_Formal_Parameter_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
Result_Node_List : List_Id;
begin
Check_Validity (Declaration, "Asis.Declarations.Generic_Formal_Part");
if not (Arg_Kind = A_Generic_Package_Declaration or else
Arg_Kind = A_Generic_Procedure_Declaration or else
Arg_Kind = A_Generic_Function_Declaration)
then
Raise_ASIS_Inappropriate_Element
("Asis.Declarations.Generic_Formal_Part");
end if;
Arg_Node := Node (Declaration);
Result_Node_List := Generic_Formal_Declarations (Arg_Node);
return N_To_E_List_New
(List => Result_Node_List,
Include_Pragmas => Include_Pragmas,
Starting_Element => Declaration);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Generic_Formal_Part",
Bool_Par => Include_Pragmas);
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Generic_Formal_Part",
Bool_Par => Include_Pragmas);
end Generic_Formal_Part;
-----------------------------------------------------------------------------
function Generic_Unit_Name
(Declaration : in Asis.Declaration)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
begin
Check_Validity (Declaration, "Asis.Declarations.Generic_Unit_Name");
if not (Arg_Kind = A_Function_Instantiation or else
Arg_Kind = A_Package_Instantiation or else
Arg_Kind = A_Procedure_Instantiation or else
Arg_Kind = A_Formal_Package_Declaration or else
Arg_Kind = A_Formal_Package_Declaration_With_Box)
then
Raise_ASIS_Inappropriate_Element
("Asis.Declarations.Generic_Unit_Name");
end if;
Arg_Node := Node (Declaration);
return Node_To_Element_New
(Node => Sinfo.Name (Arg_Node),
Starting_Element => Declaration);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Generic_Unit_Name");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Generic_Unit_Name");
end Generic_Unit_Name;
------------------------------------------------------------------------------
function Generic_Actual_Part
(Declaration : in Asis.Declaration;
Normalized : in Boolean := False)
return Asis.Association_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
Template_Node : Node_Id;
Ass_Number : Natural;
-- used if Normalized => True, to optimize the creation of the
-- normalized association list
begin
Check_Validity (Declaration, "Asis.Declarations.Generic_Actual_Part");
if not (Arg_Kind = A_Function_Instantiation or else
Arg_Kind = A_Package_Instantiation or else
Arg_Kind = A_Procedure_Instantiation or else
Arg_Kind = A_Formal_Package_Declaration)
then
Raise_ASIS_Inappropriate_Element
("Asis.Declarations.Generic_Actual_Part");
end if;
Arg_Node := Node (Declaration);
if Normalized then
-- the only things we do here are calculating the node of the
-- template and the number of the normalized associations in the
-- result list. Then we call Normalized_Generic_Associations,
-- which does the actual job.
Template_Node := Entity (Sinfo.Name (Arg_Node));
if Nkind (Parent (Template_Node)) = N_Defining_Program_Unit_Name then
-- ???
Template_Node := Parent (Template_Node);
end if;
Template_Node := Parent (Parent (Template_Node));
if Is_Non_Empty_List (
Generic_Formal_Declarations (Template_Node))
then
Ass_Number := Natural (List_Length (
Generic_Formal_Declarations (Template_Node)));
return Normalized_Generic_Associations
(Inst_Elem => Declaration,
Templ_Node => Template_Node,
Ass_Number => Ass_Number);
else
return Nil_Element_List;
end if;
else
return Node_To_Element_List (
List => Generic_Associations (Arg_Node),
Internal_Kind => A_Generic_Association,
In_Unit => Encl_Unit (Declaration));
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Generic_Actual_Part",
Bool_Par => Normalized);
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Generic_Actual_Part",
Bool_Par => Normalized);
end Generic_Actual_Part;
------------------------------------------------------------------------------
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,
"Asis.Declarations.Formal_Subprogram_Default");
if not ((Arg_Kind = A_Formal_Procedure_Declaration or else
Arg_Kind = A_Formal_Function_Declaration)
and Present (Default_Name (Arg_Node)))
then
Raise_ASIS_Inappropriate_Element
("Asis.Declarations.Formal_Subprogram_Default");
end if;
return Node_To_Element_New
(Node => Default_Name (Arg_Node),
Starting_Element => Declaration);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Declaration,
Outer_Call => "Asis.Declarations.Formal_Subprogram_Default");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Declaration,
Diagnosis => "Asis.Declarations.Formal_Subprogram_Default");
end Formal_Subprogram_Default;
------------------------------------------------------------------------------
function Corresponding_Generic_Element
(Reference : in Asis.Element)
return Asis.Defining_Name
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Reference);
Arg_Def_Name : Asis.Element;
Name_Def_Node : Node_Id;
Gen_Unit_Node : Node_Id;
Gen_Unit_Elem : Asis.Element;
Result_Unit : Asis.Compilation_Unit;
Argument_Unit : Asis.Compilation_Unit; -- ???
Result_Element : Asis.Element;
begin
Check_Validity (Reference,
"Asis.Declarations.Corresponding_Generic_Element");
if not (Arg_Kind in Internal_Defining_Name_Kinds or else
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
("Asis.Declarations.Corresponding_Generic_Element");
end if;
-- first, we heed the defining name in case if an argument is of
-- An_Expression kind
if Arg_Kind in Internal_Defining_Name_Kinds then
Arg_Def_Name := Reference;
else
Arg_Def_Name :=
Asis.Expressions.Corresponding_Name_Definition (Reference);
end if;
-- then, checking if there is a corresponding generic element
if Is_Nil (Arg_Def_Name) or else
not (Is_From_Instance (Arg_Def_Name))
then
return Nil_Element;
end if;
-- and now - the most interesting part: finding the corresponding
-- generic element
--
-- the following approach is used:
-- 1. The Element representing the declaration of the coppesponding
-- generic package is obtained;
-- 2. Then this declaration is traversed to find the corresponding
-- defining name
-- We use the instance of Traverse_Element for the second
-- step, it may be not the best solution from the efficiency
-- viewpoint, but we choose it because of the maintenance
-- reasons.
--
-- !!! NOTE: references to formal parameters cannot be processed
-- for now
Name_Def_Node := Node (Arg_Def_Name);
-- first, finding the N_Package_Declaration node for the artificial
-- package created by the compiler as an expanded generic spec:
Gen_Unit_Node := Name_Def_Node;
while not (Nkind (Gen_Unit_Node) = N_Package_Declaration and then
not Comes_From_Source (Gen_Unit_Node))
loop
Gen_Unit_Node := Parent (Gen_Unit_Node);
end loop;
if Nkind (Parent (Gen_Unit_Node)) = N_Compilation_Unit then
-- library-level instantiation, therefore:
Gen_Unit_Node := Original_Node (Gen_Unit_Node);
-- ??? may not work for procedure instantiations, but let's
-- ??? see it first
else
-- "local" instantiation, therefore - one or two steps down the
-- declaration list to get in the instantiation node:
Gen_Unit_Node := Next_Non_Pragma (Gen_Unit_Node);
if Nkind (Gen_Unit_Node) = N_Package_Body then
-- This is an expanded generic body
Gen_Unit_Node := Next_Non_Pragma (Gen_Unit_Node);
end if;
end if;
-- here we have two possibilities:
-- (1) a package instantiation
-- (2) a procedure or a function instantiation; this is the case of
-- a reference to a formal parameter of a subprogram instance,
-- we cannot process it now because of the fact, that the Entity
-- field is not set for references to formal parameters in named
-- parameter associations, therefore, for now we cannot really
-- get here this case, because the above call to
-- Corresponding_Name_Definition will fail
-- ??? !!! Temporary solution
pragma Assert (Nkind (Gen_Unit_Node) = N_Package_Instantiation);
Gen_Unit_Node := Entity (Sinfo.Name (Gen_Unit_Node));
if Nkind (Parent (Gen_Unit_Node)) = N_Defining_Program_Unit_Name then
Gen_Unit_Node := Parent (Gen_Unit_Node);
end if;
Gen_Unit_Node := Parent (Parent (Gen_Unit_Node));
Result_Unit := Enclosing_Unit (Encl_Cont_Id (Reference), Gen_Unit_Node);
Argument_Unit := Get_Comp_Unit
(Encl_Unit_Id (Reference), Encl_Cont_Id (Reference));
-- if not Is_Identical (Result_Unit, Argument_Unit) then
-- -- and here we have to check if Result_Unit and Argument_Unit
-- -- are consistent. Result_Unit is a supporter of Argument_Unit
-- if not Is_Consistent (Result_Unit, Argument_Unit) then
-- return Nil_Element;
-- end if;
-- end if;
Gen_Unit_Elem := Node_To_Element_New (Node => Gen_Unit_Node,
In_Unit => Result_Unit);
Result_Element := Get_Corresponding_Generic_Element (
Gen_Unit => Gen_Unit_Elem,
Def_Name => Arg_Def_Name);
return Result_Element;
exception
when Assert_Error : System.Assertions.Assert_Failure =>
Raise_ASIS_Failed (
Argument => Reference,
Diagnosis =>
"Asis.Declarations.Corresponding_Generic_Element - " & LT
& "Assert_Failure at "
& Ada.Exceptions.Exception_Message (Assert_Error));
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Outer_Call => "Asis.Declarations.Corresponding_Generic_Element",
Argument => Reference);
raise;
when others =>
Raise_ASIS_Failed (
Argument => Reference,
Diagnosis => "Asis.Declarations.Corresponding_Generic_Element");
end Corresponding_Generic_Element;
------------------------------
-- Is_Dispatching_Operation --
------------------------------
function Is_Dispatching_Operation
(Declaration : in Asis.Element)
return Boolean
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Declaration);
Arg_Node : Node_Id;
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
return False;
end if;
Arg_Node := Defining_Unit_Name (Specification (Node (Declaration)));
if Nkind (Arg_Node) = N_Defining_Program_Unit_Name then
return False;
else
return Is_Dispatching_Operation (Arg_Node);
end if;
end Is_Dispatching_Operation;
end Asis.Declarations