File : asis-definitions.adb
------------------------------------------------------------------------------
-- --
-- ASIS-for-GNAT IMPLEMENTATION COMPONENTS --
-- --
-- A S I S . D E F I N I 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 System.Assertions;
with Ada.Exceptions;
with Asis.Exceptions; use Asis.Exceptions;
with Asis.Declarations; use Asis.Declarations;
with Asis.Set_Get; use Asis.Set_Get;
with A4G.A_Types; use A4G.A_Types;
with A4G.Int_Knds; use A4G.Int_Knds;
with A4G.Mapping; use A4G.Mapping;
with A4G.Norm; use A4G.Norm;
with A4G.Vcheck; use A4G.Vcheck;
with A4G.C_U_Info; use A4G.C_U_Info;
with Types; use Types;
with Sinfo; use Sinfo;
with Nlists; use Nlists;
with Atree; use Atree;
package body Asis.Definitions is
LT : String renames ASIS_Line_Terminator;
------------------------------------------------------------------------------
-- NOT IMPLEMENTED
function Corresponding_Type_Operators
(Type_Definition : in Asis.Type_Definition)
return Asis.Declaration_List
is
-- Arg_Kind : Internal_Element_Kinds := Int_Kind (Type_Definition);
Arg_Node : Node_Id;
begin
Check_Validity (Type_Definition,
"Asis.Definitions.Corresponding_Type_Operators");
Arg_Node := Node (Type_Definition);
Not_Implemented_Yet (Diagnosis =>
"Asis.Definitions.Corresponding_Type_Operators");
-- ASIS_Failed is raised, Not_Implemented_Error status is setted
return Nil_Element_List; -- to make the code syntactically correct
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Type_Definition,
Outer_Call => "Asis.Definitions.Corresponding_Type_Operators");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Type_Definition,
Diagnosis => "Asis.Definitions.Corresponding_Type_Operators");
end Corresponding_Type_Operators;
-----------------------------------------------------------------------------
function Parent_Subtype_Indication
(Type_Definition : in Asis.Type_Definition)
return Asis.Subtype_Indication
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Type_Definition);
Arg_Node : Node_Id;
begin
Check_Validity (Type_Definition,
"Asis.Definitions.Parent_Subtype_Indication");
if not (Arg_Kind = A_Derived_Type_Definition or else
Arg_Kind = A_Derived_Record_Extension_Definition)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Definitions.Parent_Subtype_Indication");
end if;
Arg_Node := Node (Type_Definition);
return Node_To_Element_New
(Node => Sinfo.Subtype_Indication (Arg_Node),
Starting_Element => Type_Definition,
Internal_Kind => A_Subtype_Indication);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Type_Definition,
Outer_Call => "Asis.Definitions.Parent_Subtype_Indication");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Type_Definition,
Diagnosis => "Asis.Definitions.Parent_Subtype_Indication");
end Parent_Subtype_Indication;
-----------------------------------------------------------------------------
function Record_Definition
(Type_Definition : in Asis.Type_Definition)
return Asis.Record_Definition
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Type_Definition);
Arg_Node : Node_Id;
Result_Kind : Internal_Element_Kinds;
Result_Node : Node_Id;
begin
Check_Validity (Type_Definition, "Asis.Definitions.Record_Definition");
if not (Arg_Kind = A_Derived_Record_Extension_Definition or else
Arg_Kind = A_Record_Type_Definition or else
Arg_Kind = A_Tagged_Record_Type_Definition)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Definitions.Record_Definition");
end if;
Arg_Node := Node (Type_Definition);
if Arg_Kind = A_Derived_Record_Extension_Definition then
Result_Node := Record_Extension_Part (Arg_Node);
else
Result_Node := Arg_Node;
end if;
if Null_Present (Result_Node) then
Result_Kind := A_Null_Record_Definition;
else
Result_Kind := A_Record_Definition;
end if;
return Node_To_Element_New
(Node => Result_Node,
Starting_Element => Type_Definition,
Internal_Kind => Result_Kind);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Type_Definition,
Outer_Call => "Asis.Definitions.Record_Definition");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Type_Definition,
Diagnosis => "Asis.Definitions.Record_Definition");
end Record_Definition;
------------------------------------------------------------------------------
-- NOT IMPLEMENTED
function Implicit_Inherited_Declarations
(Definition : in Asis.Definition) return Asis.Declaration_List
is
-- Arg_Kind : Internal_Element_Kinds := Int_Kind (Definition);
Arg_Node : Node_Id;
begin
Check_Validity (Definition,
"Asis.Definitions.Implicit_Inherited_Declarations");
Arg_Node := Node (Definition);
Not_Implemented_Yet (Diagnosis =>
"Asis.Definitions.Implicit_Inherited_Declarations");
-- ASIS_Failed is raised, Not_Implemented_Error status is setted
return Nil_Element_List; -- to make the code syntactically correct
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Definition,
Outer_Call => "Asis.Definitions.Implicit_Inherited_Declarations");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Definition,
Diagnosis => "Asis.Definitions.Implicit_Inherited_Declarations");
end Implicit_Inherited_Declarations;
------------------------------------------------------------------------------
-- NOT IMPLEMENTED
function Implicit_Inherited_Subprograms
(Definition : in Asis.Definition)
return Asis.Declaration_List
is
-- Arg_Kind : Internal_Element_Kinds := Int_Kind (Definition);
Arg_Node : Node_Id;
begin
Check_Validity (Definition,
"Asis.Definitions.Implicit_Inherited_Subprograms");
Arg_Node := Node (Definition);
Not_Implemented_Yet (Diagnosis =>
"Asis.Definitions.Implicit_Inherited_Subprograms");
-- ASIS_Failed is raised, Not_Implemented_Error status is setted
return Nil_Element_List; -- to make the code syntactically correct
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Definition,
Outer_Call => "Asis.Definitions.Implicit_Inherited_Subprograms");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Definition,
Diagnosis => "Asis.Definitions.Implicit_Inherited_Subprograms");
end Implicit_Inherited_Subprograms;
-----------------------------------------------------------------------------
function Corresponding_Parent_Subtype
(Type_Definition : in Asis.Type_Definition)
return Asis.Declaration
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Type_Definition);
Type_Mark_Node : Node_Id;
Result_Node : Node_Id;
Result_Unit : Asis.Compilation_Unit;
begin
Check_Validity (Type_Definition,
"Asis.Definitions.Corresponding_Parent_Subtype");
if not (Arg_Kind = A_Derived_Type_Definition or else
Arg_Kind = A_Derived_Record_Extension_Definition)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Definitions.Corresponding_Parent_Subtype");
end if;
Type_Mark_Node := Sinfo.Subtype_Indication (Node (Type_Definition));
if Nkind (Type_Mark_Node) = N_Subtype_Indication then
Type_Mark_Node := Sinfo.Subtype_Mark (Type_Mark_Node);
end if;
Result_Node := Entity (Type_Mark_Node);
Result_Node := Parent (Result_Node);
Result_Unit :=
Enclosing_Unit (Encl_Cont_Id (Type_Definition), 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 => Type_Definition,
Diagnosis =>
"Asis.Definitions.Corresponding_Parent_Subtype - " & LT
& "Assert_Failure at "
& Ada.Exceptions.Exception_Message (Assert_Error));
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Type_Definition,
Outer_Call => "Asis.Definitions.Corresponding_Parent_Subtype");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Type_Definition,
Diagnosis => "Asis.Definitions.Corresponding_Parent_Subtype");
end Corresponding_Parent_Subtype;
-----------------------------------------------------------------------------
function Corresponding_Root_Type
(Type_Definition : in Asis.Type_Definition)
return Asis.Declaration
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Type_Definition);
Result_El : Asis.Declaration;
Result_Kind : Internal_Element_Kinds;
Def_El : Asis.Type_Definition;
Def_Kind : Internal_Element_Kinds;
begin
Check_Validity (Type_Definition,
"Asis.Definitions.Corresponding_Root_Type");
if not (Arg_Kind = A_Derived_Type_Definition or else
Arg_Kind = A_Derived_Record_Extension_Definition)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Definitions.Corresponding_Root_Type");
end if;
Result_El := Corresponding_Parent_Subtype (Type_Definition);
loop
Result_Kind := Int_Kind (Result_El);
if Result_Kind = A_Subtype_Declaration then
Result_El := Corresponding_First_Subtype (Result_El);
else
-- Result_El can be of An_Ordinary_Type_Declaration,
-- A_Task_Type_Declaration, A_Protected_Type_Declaration,
-- A_Private_Type_Declaration, A_Private_Extension_Declaration
-- or A_Formal_Type_Declaration only
if Result_Kind = An_Ordinary_Type_Declaration or else
Result_Kind = A_Formal_Type_Declaration
then
Def_El := Type_Declaration_View (Result_El);
Def_Kind := Int_Kind (Def_El);
if Def_Kind = A_Derived_Type_Definition or else
Def_Kind = A_Derived_Record_Extension_Definition
then
Result_El := Corresponding_Parent_Subtype (Def_El);
else
return Result_El;
end if;
else
return Result_El;
end if;
end if;
end loop;
return Result_El;
-- for now, we implement this query as secondary one, without explicut
-- tree traversing on its own. The reasons are:
-- 1. problems with the tree structure for Standard indicated as
-- ??? <tree problem 5>
-- 2. to save the development time abd maintenance efforts.
-- 3. The Einfo.Root_Type attribute function was supposed to be used
-- to implement this query, but for types derived from integer
-- types Root_Type returns the *predefined* ultimate ancestor,
-- such as Integer, Short_Integer etc. It is useful for defining
-- the representation issues, but it corresoponds neither to ASIS
-- nor RM95 meanings of the notion of a root type
--
-- The old Einfo.Root_Type-based code is kept as commented out -
-- just in case.
-- Entity_Node := Defining_Identifier (Parent (Node (Type_Definition)));
-- -- Node or R_Node??? the declaration of a derived type may
-- -- be rewritten...
-- Result_Node := Root_Type (Entity_Node);
-- -- is it really so easy???
-- -- from a defining name to the type declaration:
-- if Is_Itype (Result_Node) then
-- Result_Node := Associated_Node_For_Itype (Result_Node);
-- else
-- Result_Node := Parent (Result_Node);
-- end if;
--
-- pragma Assert (Comes_From_Source (Result_Node));
--
-- return Node_To_Element_New
-- (Starting_Element => Type_Definition,
-- Node => Result_Node);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Type_Definition,
Outer_Call => "Asis.Definitions.Corresponding_Root_Type");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Type_Definition,
Diagnosis => "Asis.Definitions.Corresponding_Root_Type");
end Corresponding_Root_Type;
------------------------------------------------------------------------------
-- NOT IMPLEMENTED
function Corresponding_Type_Structure
(Type_Definition : in Asis.Type_Definition)
return Asis.Declaration
is
-- Arg_Kind : Internal_Element_Kinds := Int_Kind (Type_Definition);
Arg_Node : Node_Id;
begin
Check_Validity (Type_Definition,
"Asis.Definitions.Corresponding_Type_Structure");
Arg_Node := Node (Type_Definition);
Not_Implemented_Yet (Diagnosis =>
"Asis.Definitions.Corresponding_Type_Structure");
-- 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 => Type_Definition,
Outer_Call => "Asis.Definitions.Corresponding_Type_Structure");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Type_Definition,
Diagnosis => "Asis.Definitions.Corresponding_Type_Structure");
end Corresponding_Type_Structure;
------------------------------------------------------------------------------
-- ???: may crash on the definitions of Standard.Character and
-- ??? Standard.Whide_Character types.
function Enumeration_Literal_Declarations
(Type_Definition : in Asis.Type_Definition)
return Asis.Declaration_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Type_Definition);
Arg_Node : Node_Id;
begin
Check_Validity (Type_Definition,
"Asis.Definitions.Enumeration_Literal_Declarations");
if not (Arg_Kind = An_Enumeration_Type_Definition) then
Raise_ASIS_Inappropriate_Element
(Diagnosis =>
"Asis.Definitions.Enumeration_Literal_Declarations");
end if;
Arg_Node := Node (Type_Definition);
declare
Result_List : Asis.Declaration_List := Node_To_Element_List
(List => Literals (Arg_Node),
In_Unit => Encl_Unit (Type_Definition));
-- Result_List contains Elements of the
-- A_Defining_Character_Literal or A_Defining_Enumeration_Literal
-- Internal Kind values. To obtain the proper result of the
-- function, the Internal_Kind and Kind fields of each list
-- member should be corrected
begin
for I in Result_List'Range loop
Set_Int_Kind (
Result_List (I), An_Enumeration_Literal_Specification);
end loop;
return Result_List;
end;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Type_Definition,
Outer_Call => "Asis.Definitions.Enumeration_Literal_Declarations");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Type_Definition,
Diagnosis => "Asis.Definitions.Enumeration_Literal_Declarations");
end Enumeration_Literal_Declarations;
------------------------------------------------------------------------------
-- OPEN PROBLEMS:
--
-- 1. Standard.Character and Standard.Whide_Character types have
-- to be processed specifically (See Sinfo.ads item for
-- N_Enumeration_Type_Definition Node. This is not implemented yet.
------------------------------------------------------------------------------
function Integer_Constraint
(Type_Definition : in Asis.Type_Definition)
return Asis.Range_Constraint
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Type_Definition);
Arg_Node : Node_Id;
begin
Check_Validity (Type_Definition,
"Asis.Definitions.Integer_Constraint");
if not (Arg_Kind = A_Signed_Integer_Type_Definition) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Definitions.Integer_Constraint");
end if;
Arg_Node := Node (Type_Definition);
return Node_To_Element_New
(Node => Arg_Node,
Starting_Element => Type_Definition,
Internal_Kind => A_Simple_Expression_Range);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Type_Definition,
Outer_Call => "Asis.Definitions.Integer_Constraint");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Type_Definition,
Diagnosis => "Asis.Definitions.Integer_Constraint");
end Integer_Constraint;
-----------------------------------------------------------------------------
function Mod_Static_Expression
(Type_Definition : in Asis.Type_Definition) return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Type_Definition);
Arg_Node : Node_Id;
begin
Check_Validity (Type_Definition,
"Asis.Definitions.Mod_Static_Expression");
if not (Arg_Kind = A_Modular_Type_Definition) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Definitions.Mod_Static_Expression");
end if;
Arg_Node := Node (Type_Definition);
return Node_To_Element_New
(Node => Sinfo.Expression (Arg_Node),
Starting_Element => Type_Definition);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Type_Definition,
Outer_Call => "Asis.Definitions.Mod_Static_Expression");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Type_Definition,
Diagnosis => "Asis.Definitions.Mod_Static_Expression");
end Mod_Static_Expression;
-----------------------------------------------------------------------------
function Digits_Expression
(Definition : in Asis.Definition)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Definition);
Arg_Node : Node_Id;
begin
Check_Validity (Definition, "Asis.Definitions.Digits_Expression");
if not (Arg_Kind = A_Floating_Point_Definition or else
Arg_Kind = A_Decimal_Fixed_Point_Definition or else
Arg_Kind = A_Digits_Constraint)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Definitions.Digits_Expression");
end if;
Arg_Node := Node (Definition);
return Node_To_Element_New
(Node => Digits_Expression (Arg_Node),
Starting_Element => Definition);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Definition,
Outer_Call => "Asis.Definitions.Digits_Expression");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Definition,
Diagnosis => "Asis.Definitions.Digits_Expression");
end Digits_Expression;
-----------------------------------------------------------------------------
function Delta_Expression
(Definition : in Asis.Definition)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Definition);
Arg_Node : Node_Id;
begin
Check_Validity (Definition, "Asis.Definitions.Delta_Expression");
if not (Arg_Kind = An_Ordinary_Fixed_Point_Definition or else
Arg_Kind = A_Decimal_Fixed_Point_Definition or else
Arg_Kind = A_Delta_Constraint)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Definitions.Delta_Expression");
end if;
Arg_Node := Node (Definition);
return Node_To_Element_New
(Node => Delta_Expression (Arg_Node),
Starting_Element => Definition);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Definition,
Outer_Call => "Asis.Definitions.Delta_Expression");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Definition,
Diagnosis => "Asis.Definitions.Delta_Expression");
end Delta_Expression;
-----------------------------------------------------------------------------
function Real_Range_Constraint
(Definition : in Asis.Definition)
return Asis.Range_Constraint
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Definition);
Arg_Node : Node_Id;
Result_Node : Node_Id;
begin
Check_Validity (Definition, "Asis.Definitions.Real_Range_Constraint");
if not (Arg_Kind = A_Floating_Point_Definition or else
Arg_Kind = An_Ordinary_Fixed_Point_Definition or else
Arg_Kind = A_Decimal_Fixed_Point_Definition or else
Arg_Kind = A_Digits_Constraint or else
Arg_Kind = A_Delta_Constraint)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Definitions.Real_Range_Constraint");
end if;
Arg_Node := Node (Definition);
if (Arg_Kind = A_Floating_Point_Definition or else
Arg_Kind = An_Ordinary_Fixed_Point_Definition or else
Arg_Kind = A_Decimal_Fixed_Point_Definition)
then
Result_Node := Real_Range_Specification (Arg_Node);
else
-- Arg_Kind = A_Digits_Constraint or Arg_Kind = A_Delta_Constraint
Result_Node := Sinfo.Range_Constraint (Arg_Node);
end if;
if No (Result_Node) then
return Nil_Element;
else
return Node_To_Element_New
(Node => Result_Node,
Starting_Element => Definition,
Internal_Kind => A_Simple_Expression_Range);
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Definition,
Outer_Call => "Asis.Definitions.Real_Range_Constraint");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Definition,
Diagnosis => "Asis.Definitions.Real_Range_Constraint");
end Real_Range_Constraint;
-----------------------------------------------------------------------------
function Index_Subtype_Definitions
(Type_Definition : in Asis.Type_Definition)
return Asis.Expression_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Type_Definition);
Arg_Node : Node_Id;
begin
Check_Validity (Type_Definition,
"Asis.Definitions.Index_Subtype_Definitions");
if not (Arg_Kind = An_Unconstrained_Array_Definition or else
Arg_Kind = A_Formal_Unconstrained_Array_Definition)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Definitions.Index_Subtype_Definitions");
end if;
Arg_Node := Node (Type_Definition);
return Node_To_Element_List (
List => Subtype_Marks (Arg_Node),
In_Unit => Encl_Unit (Type_Definition));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Type_Definition,
Outer_Call => "Asis.Definitions.Index_Subtype_Definitions");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Type_Definition,
Diagnosis => "Asis.Definitions.Index_Subtype_Definitions");
end Index_Subtype_Definitions;
-----------------------------------------------------------------------------
function Discrete_Subtype_Definitions
(Type_Definition : in Asis.Type_Definition)
return Asis.Definition_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Type_Definition);
Arg_Node : Node_Id;
begin
Check_Validity (Type_Definition,
"Asis.Definitions.Discrete_Subtype_Definitions");
if not (Arg_Kind = A_Constrained_Array_Definition or else
Arg_Kind = A_Formal_Constrained_Array_Definition)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Definitions.Discrete_Subtype_Definitions");
end if;
Arg_Node := Node (Type_Definition);
return N_To_E_List_New (
List => Discrete_Subtype_Definitions (Arg_Node),
Starting_Element => Type_Definition);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Type_Definition,
Outer_Call => "Asis.Definitions.Discrete_Subtype_Definitions");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Type_Definition,
Diagnosis => "Asis.Definitions.Discrete_Subtype_Definitions");
end Discrete_Subtype_Definitions;
-----------------------------------------------------------------------------
function Array_Component_Definition
(Type_Definition : in Asis.Type_Definition)
return Asis.Component_Definition
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Type_Definition);
Arg_Node : Node_Id;
begin
Check_Validity (Type_Definition,
"Asis.Definitions.Array_Component_Definition");
if not (Arg_Kind = An_Unconstrained_Array_Definition or else
Arg_Kind = A_Constrained_Array_Definition or else
Arg_Kind = A_Formal_Unconstrained_Array_Definition or else
Arg_Kind = A_Formal_Constrained_Array_Definition)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Definitions.Array_Component_Definition");
end if;
Arg_Node := Node (Type_Definition);
return Node_To_Element_New
(Node => Sinfo.Subtype_Indication (Arg_Node),
Starting_Element => Type_Definition,
Internal_Kind => A_Component_Definition);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Type_Definition,
Outer_Call => "Asis.Definitions.Array_Component_Definition");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Type_Definition,
Diagnosis => "Asis.Definitions.Array_Component_Definition");
end Array_Component_Definition;
-----------------------------------------------------------------------------
function Access_To_Object_Definition
(Type_Definition : in Asis.Type_Definition)
return Asis.Subtype_Indication
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Type_Definition);
Arg_Node : Node_Id;
begin
Check_Validity (Type_Definition,
"Asis.Definitions.Access_To_Object_Definition");
if not (Arg_Kind = A_Pool_Specific_Access_To_Variable or else
Arg_Kind = An_Access_To_Variable or else
Arg_Kind = An_Access_To_Constant or else
Arg_Kind = A_Formal_Pool_Specific_Access_To_Variable or else
Arg_Kind = A_Formal_Access_To_Variable or else
Arg_Kind = A_Formal_Access_To_Constant)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Definitions.Access_To_Object_Definition");
end if;
Arg_Node := Node (Type_Definition);
return Node_To_Element_New
(Node => Sinfo.Subtype_Indication (Arg_Node),
Starting_Element => Type_Definition,
Internal_Kind => A_Subtype_Indication);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Type_Definition,
Outer_Call => "Asis.Definitions.Access_To_Object_Definition");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Type_Definition,
Diagnosis => "Asis.Definitions.Access_To_Object_Definition");
end Access_To_Object_Definition;
-----------------------------------------------------------------------------
function Access_To_Subprogram_Parameter_Profile
(Type_Definition : in Asis.Type_Definition)
return Asis.Parameter_Specification_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Type_Definition);
Arg_Node : Node_Id;
Result_List : List_Id;
begin
Check_Validity (Type_Definition,
"Asis.Definitions.Access_To_Subprogram_Parameter_Profile");
if not (Arg_Kind = An_Access_To_Procedure or else
Arg_Kind = An_Access_To_Protected_Procedure or else
Arg_Kind = An_Access_To_Function or else
Arg_Kind = An_Access_To_Protected_Function or else
Arg_Kind = A_Formal_Access_To_Procedure or else
Arg_Kind = A_Formal_Access_To_Protected_Procedure or else
Arg_Kind = A_Formal_Access_To_Function or else
Arg_Kind = A_Formal_Access_To_Protected_Function)
then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
"Asis.Definitions.Access_To_Subprogram_Parameter_Profile");
end if;
Arg_Node := Node (Type_Definition);
Result_List := Parameter_Specifications (Arg_Node);
if No (Result_List) then
return Nil_Element_List;
else
return N_To_E_List_New
(List => Result_List,
Starting_Element => Type_Definition,
Internal_Kind => A_Parameter_Specification);
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Type_Definition,
Outer_Call =>
"Asis.Definitions.Access_To_Subprogram_Parameter_Profile");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Type_Definition,
Diagnosis =>
"Asis.Definitions.Access_To_Subprogram_Parameter_Profile");
end Access_To_Subprogram_Parameter_Profile;
-----------------------------------------------------------------------------
function Access_To_Function_Result_Profile
(Type_Definition : in Asis.Type_Definition)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Type_Definition);
Arg_Node : Node_Id;
begin
Check_Validity (Type_Definition,
"Asis.Definitions.Access_To_Function_Result_Profile");
if not (Arg_Kind = An_Access_To_Function or else
Arg_Kind = An_Access_To_Protected_Function or else
Arg_Kind = A_Formal_Access_To_Function or else
Arg_Kind = A_Formal_Access_To_Protected_Function)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Definitions.Access_To_Function_Result_Profile");
end if;
Arg_Node := Node (Type_Definition);
return Node_To_Element_New
(Node => Sinfo.Subtype_Mark (Arg_Node),
Starting_Element => Type_Definition);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Type_Definition,
Outer_Call =>
"Asis.Definitions.Access_To_Function_Result_Profile");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Type_Definition,
Diagnosis =>
"Asis.Definitions.Access_To_Function_Result_Profile");
end Access_To_Function_Result_Profile;
-----------------------------------------------------------------------------
function Subtype_Mark
(Definition : in Asis.Definition)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Definition);
Arg_Node : Node_Id;
Result_Node : Node_Id;
Result_Kind : Internal_Element_Kinds := Not_An_Element;
begin
Check_Validity (Definition, "Asis.Definitions.Subtype_Mark");
if not (Arg_Kind = A_Subtype_Indication or else
Arg_Kind = A_Discrete_Subtype_Indication or else
Arg_Kind = A_Formal_Derived_Type_Definition or else
Arg_Kind = A_Discrete_Subtype_Indication_As_Subtype_Definition)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Definitions.Subtype_Mark");
end if;
Arg_Node := Node (Definition);
if (Nkind (Arg_Node) = N_Subtype_Indication or else
Nkind (Arg_Node) = N_Formal_Derived_Type_Definition)
then
Result_Node := Sinfo.Subtype_Mark (Arg_Node);
else
Result_Node := Arg_Node;
end if;
if Nkind (Result_Node) = N_Identifier then
Result_Kind := An_Identifier;
elsif Nkind (Result_Node) = N_Expanded_Name then
Result_Kind := A_Selected_Component;
end if;
return Node_To_Element_New
(Node => Result_Node,
Starting_Element => Definition,
Internal_Kind => Result_Kind);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Definition,
Outer_Call => "Asis.Definitions.Subtype_Mark");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Definition,
Diagnosis => "Asis.Definitions.Subtype_Mark");
end Subtype_Mark;
-----------------------------------------------------------------------------
function Subtype_Constraint
(Definition : in Asis.Definition)
return Asis.Constraint
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Definition);
Arg_Node : Node_Id;
begin
Check_Validity (Definition, "Asis.Definitions.Subtype_Constraint");
if not (Arg_Kind = A_Subtype_Indication or else
Arg_Kind = A_Discrete_Subtype_Indication or else
Arg_Kind = A_Discrete_Subtype_Indication_As_Subtype_Definition)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Definitions.Subtype_Constraint");
end if;
Arg_Node := Node (Definition);
if Nkind (Arg_Node) = N_Subtype_Indication then
return Node_To_Element_New
(Node => Sinfo.Constraint (Arg_Node),
Starting_Element => Definition);
else
return Nil_Element;
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Definition,
Outer_Call => "Asis.Definitions.Subtype_Constraint");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Definition,
Diagnosis => "Asis.Definitions.Subtype_Constraint");
end Subtype_Constraint;
-----------------------------------------------------------------------------
function Lower_Bound
(Constraint : in Asis.Range_Constraint)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Constraint);
Arg_Node : Node_Id;
Result_Node : Node_Id;
begin
Check_Validity (Constraint, "Asis.Definitions.Lower_Bound");
if not (Arg_Kind = A_Simple_Expression_Range or else
Arg_Kind = A_Discrete_Simple_Expression_Range or else
Arg_Kind =
A_Discrete_Simple_Expression_Range_As_Subtype_Definition)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Definitions.Lower_Bound");
end if;
Arg_Node := Node (Constraint);
if Nkind (Arg_Node) = N_Range_Constraint then
Result_Node := Low_Bound (Range_Expression (Arg_Node));
elsif Nkind (Arg_Node) = N_Component_Clause then
Result_Node := First_Bit (Arg_Node);
else
-- Nkind (Arg_Node) = N_Range or else
-- Nkind (Arg_Node) = N_Real_Range_Specification
Result_Node := Low_Bound (Arg_Node);
end if;
return Node_To_Element_New
(Node => Result_Node,
Starting_Element => Constraint);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Constraint,
Outer_Call => "Asis.Definitions.Lower_Bound");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Constraint,
Diagnosis => "Asis.Definitions.Lower_Bound");
end Lower_Bound;
-----------------------------------------------------------------------------
function Upper_Bound (Constraint : in Asis.Range_Constraint)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Constraint);
Arg_Node : Node_Id;
Result_Node : Node_Id;
begin
Check_Validity (Constraint, "Asis.Definitions.Upper_Bound");
if not (Arg_Kind = A_Simple_Expression_Range or else
Arg_Kind = A_Discrete_Simple_Expression_Range or else
Arg_Kind =
A_Discrete_Simple_Expression_Range_As_Subtype_Definition)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Definitions.Upper_Bound");
end if;
Arg_Node := Node (Constraint);
if Nkind (Arg_Node) = N_Range_Constraint then
Result_Node := High_Bound (Range_Expression (Arg_Node));
elsif Nkind (Arg_Node) = N_Component_Clause then
Result_Node := Last_Bit (Arg_Node);
else
Result_Node := High_Bound (Arg_Node);
end if;
return Node_To_Element_New
(Node => Result_Node,
Starting_Element => Constraint);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Constraint,
Outer_Call => "Asis.Definitions.Upper_Bound");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Constraint,
Diagnosis => "Asis.Definitions.Upper_Bound");
end Upper_Bound;
-----------------------------------------------------------------------------
function Range_Attribute
(Constraint : in Asis.Range_Constraint)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Constraint);
Arg_Node : Node_Id := Node (Constraint);
Result_Node : Node_Id;
begin
Check_Validity (Constraint, "Asis.Definitions.Range_Attribute");
if not (Arg_Kind = A_Range_Attribute_Reference or else
Arg_Kind = A_Discrete_Range_Attribute_Reference or else
Arg_Kind =
A_Discrete_Range_Attribute_Reference_As_Subtype_Definition)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Definitions.Range_Attribute");
end if;
if Nkind (Arg_Node) = N_Range_Constraint then
-- one step down to N_Attruibute_Reference node
Result_Node := Range_Expression (Arg_Node);
else
Result_Node := R_Node (Constraint);
end if;
return Node_To_Element_New
(Starting_Element => Constraint,
Node => Result_Node,
Internal_Kind => A_Range_Attribute);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Constraint,
Outer_Call => "Asis.Definitions.Range_Attribute");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Constraint,
Diagnosis => "Asis.Definitions.Range_Attribute");
end Range_Attribute;
-------------------------------------------------------------------------
function Discrete_Ranges (Constraint : in Asis.Constraint)
return Asis.Discrete_Range_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Constraint);
Arg_Node : Node_Id;
begin
Check_Validity (Constraint, "Asis.Definitions.Discrete_Ranges");
if not (Arg_Kind = An_Index_Constraint) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Definitions.Discrete_Ranges");
end if;
Arg_Node := Node (Constraint);
return Node_To_Element_List (
List => Constraints (Arg_Node),
In_Unit => Encl_Unit (Constraint));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Constraint,
Outer_Call => "Asis.Definitions.Discrete_Ranges");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Constraint,
Diagnosis => "Asis.Definitions.Discrete_Ranges");
end Discrete_Ranges;
------------------------------------------------------------------------------
-- ??? PARTIALLY IMPLEMENTED, CANNOT PROCESS THE CASE WHEN
-- ??? NORMALIZED = TRUE
function Discriminant_Associations
(Constraint : in Asis.Constraint;
Normalized : in Boolean := False)
return Asis.Discriminant_Association_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Constraint);
Arg_Node : Node_Id;
begin
Check_Validity (Constraint,
"Asis.Definitions.Discriminant_Associations");
if not (Arg_Kind = A_Discriminant_Constraint) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Definitions.Discriminant_Associations");
end if;
Arg_Node := Node (Constraint);
if Normalized then
return Normalized_Discriminant_Associations (
Constr_Elem => Constraint,
Constr_Node => Arg_Node);
else
return Node_To_Element_List (
List => Constraints (Arg_Node),
Internal_Kind => A_Discriminant_Association,
In_Unit => Encl_Unit (Constraint));
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Constraint,
Bool_Par => Normalized,
Outer_Call => "Asis.Definitions.Discriminant_Associations");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Constraint,
Bool_Par => Normalized,
Diagnosis => "Asis.Definitions.Discriminant_Associations");
end Discriminant_Associations;
-----------------------------------------------------------------------------
function Component_Subtype_Indication
(Component_Definition : in Asis.Definition)
return Asis.Definition
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Component_Definition);
Arg_Node : Node_Id;
begin
Check_Validity (Component_Definition,
"Asis.Definitions.Component_Subtype_Indication");
if not (Arg_Kind = A_Component_Definition) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Definitions.Component_Subtype_Indication");
end if;
Arg_Node := Node (Component_Definition);
return Node_To_Element_New
(Node => Arg_Node,
Starting_Element => Component_Definition,
Internal_Kind => A_Subtype_Indication);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Component_Definition,
Outer_Call => "Asis.Definitions.Component_Subtype_Indication");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Component_Definition,
Diagnosis => "Asis.Definitions.Component_Subtype_Indication");
end Component_Subtype_Indication;
-----------------------------------------------------------------------------
function Discriminants
(Definition : in Asis.Definition)
return Asis.Discriminant_Specification_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Definition);
Arg_Node : Node_Id;
begin
Check_Validity (Definition, "Asis.Definitions.Discriminants");
if not (Arg_Kind = A_Known_Discriminant_Part) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Definitions.Discriminants");
end if;
Arg_Node := Node (Definition);
return N_To_E_List_New
(List => Discriminant_Specifications (Arg_Node),
Starting_Element => Definition,
Internal_Kind => A_Discriminant_Specification);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Definition,
Outer_Call => "Asis.Definitions.Discriminants");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Definition,
Diagnosis => "Asis.Definitions.Discriminants");
end Discriminants;
-----------------------------------------------------------------------------
function Record_Components
(Definition : in Asis.Record_Definition;
Include_Pragmas : in Boolean := False)
return Asis.Record_Component_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Definition);
Arg_Node : Node_Id;
Component_List_Node : Node_Id;
Result_List : List_Id; -- All nodes except the Variant Node
Variant_Part_Node : Node_Id;
begin
Check_Validity (Definition,
"Asis.Definitions.Record_Components");
if not (Arg_Kind = A_Record_Definition or else
Arg_Kind = A_Variant)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Definitions.Record_Components");
end if;
Arg_Node := Node (Definition);
Component_List_Node := Component_List (Arg_Node);
-- first, we should check the nul record case:
if Null_Present (Component_List_Node) then
return Element_List'(1 =>
Node_To_Element_New (Node => Arg_Node,
Starting_Element => Definition,
Internal_Kind => A_Null_Component));
end if;
Result_List := Component_Items (Component_List_Node);
Variant_Part_Node := Variant_Part (Component_List_Node);
if No (Variant_Part_Node) then
return N_To_E_List_New (List => Result_List,
Include_Pragmas => Include_Pragmas,
Starting_Element => Definition);
else
return (
N_To_E_List_New (List => Result_List,
Include_Pragmas => Include_Pragmas,
Starting_Element => Definition)
&
Element_List'(1 =>
Node_To_Element_New (Node => Variant_Part_Node,
Starting_Element => Definition,
Internal_Kind => A_Variant_Part))
);
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Definition,
Bool_Par => Include_Pragmas,
Outer_Call => "Asis.Definitions.Record_Components");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Definition,
Bool_Par => Include_Pragmas,
Diagnosis => "Asis.Definitions.Record_Components");
end Record_Components;
------------------------------------------------------------------------------
-- NOT IMPLEMENTED
function Implicit_Components
(Definition : in Asis.Record_Definition)
return Asis.Record_Component_List
is
-- Arg_Kind : Internal_Element_Kinds := Int_Kind (Definition);
Arg_Node : Node_Id;
begin
Check_Validity (Definition,
"Asis.Definitions.Implicit_Components");
Arg_Node := Node (Definition);
Not_Implemented_Yet (Diagnosis =>
"Asis.Definitions.Implicit_Components");
-- ASIS_Failed is raised, Not_Implemented_Error status is setted
return Nil_Element_List; -- to make the code syntactically correct
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Definition,
Outer_Call => "Asis.Definitions.Implicit_Components");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Definition,
Diagnosis => "Asis.Definitions.Implicit_Components");
end Implicit_Components;
-----------------------------------------------------------------------------
function Discriminant_Direct_Name
(Variant_Part : in Asis.Record_Component)
return Asis.Name
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Variant_Part);
Arg_Node : Node_Id;
begin
Check_Validity (Variant_Part,
"Asis.Definitions.Discriminant_Direct_Name");
if not (Arg_Kind = A_Variant_Part) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Definitions.Discriminant_Direct_Name");
end if;
Arg_Node := Node (Variant_Part);
return Node_To_Element_New
(Node => Sinfo.Name (Arg_Node),
Starting_Element => Variant_Part,
Internal_Kind => An_Identifier);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Variant_Part,
Outer_Call => "Asis.Definitions.Discriminant_Direct_Name");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Variant_Part,
Diagnosis => "Asis.Definitions.Discriminant_Direct_Name");
end Discriminant_Direct_Name;
-----------------------------------------------------------------------------
function Variants
(Variant_Part : in Asis.Record_Component;
Include_Pragmas : in Boolean := False)
return Asis.Variant_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Variant_Part);
Arg_Node : Node_Id;
begin
Check_Validity (Variant_Part, "Asis.Definitions.Variants");
if not (Arg_Kind = A_Variant_Part) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Definitions.Variants");
end if;
Arg_Node := Node (Variant_Part);
if Include_Pragmas then
return Node_To_Element_List
(List => Variants (Arg_Node),
In_Unit => Encl_Unit (Variant_Part));
else
return Node_To_Element_List
(List => Variants (Arg_Node),
In_Unit => Encl_Unit (Variant_Part),
To_Be_Included => No_Pragma'Access);
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Variant_Part,
Bool_Par => Include_Pragmas,
Outer_Call => "Asis.Definitions.Variants");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Variant_Part,
Bool_Par => Include_Pragmas,
Diagnosis => "Asis.Definitions.Variants");
end Variants;
-----------------------------------------------------------------------------
function Variant_Choices
(Variant : in Asis.Variant)
return Asis.Element_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Variant);
Arg_Node : Node_Id;
begin
Check_Validity (Variant, "Asis.Definitions.Variant_Choices");
if not (Arg_Kind = A_Variant) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Definitions.Variant_Choices");
end if;
Arg_Node := Node (Variant);
return Discrete_Choice_Node_To_Element_List (
Choice_List => Discrete_Choices (Arg_Node),
In_Unit => Encl_Unit (Variant));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Variant,
Outer_Call => "Asis.Definitions.Variant_Choices");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Variant,
Diagnosis => "Asis.Definitions.Variant_Choices");
end Variant_Choices;
------------------------------------------------------------------------------
-- OPEN PROBLEMS:
--
-- 1. Is using of the special list constructin function
-- Discrete_Choice_Node_To_Element_List really neseccary here? We should
-- try to replace it by non-special (trivial) constructor (all
-- neseccary local mapping items for Nodes in the Node List have
-- already been defined - ???).
--
-- IT SEEMS TO BE NOT ONLY OK, BUT REALLY NECESSARY HERE (03.11.95)
------------------------------------------------------------------------------
function Ancestor_Subtype_Indication
(Definition : in Asis.Definition)
return Asis.Definition
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Definition);
Arg_Node : Node_Id;
begin
Check_Validity (Definition,
"Asis.Definitions.Ancestor_Subtype_Indication");
if not (Arg_Kind = A_Private_Extension_Definition) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Definitions.Ancestor_Subtype_Indication");
end if;
Arg_Node := Node (Definition);
return Node_To_Element_New
(Node => Sinfo.Subtype_Indication (Arg_Node),
Starting_Element => Definition,
Internal_Kind => A_Subtype_Indication);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Definition,
Outer_Call => "Asis.Definitions.Ancestor_Subtype_Indication");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Definition,
Diagnosis => "Asis.Definitions.Ancestor_Subtype_Indication");
end Ancestor_Subtype_Indication;
-----------------------------------------------------------------------------
function Visible_Part_Items
(Definition : in Asis.Definition;
Include_Pragmas : in Boolean := False)
return Asis.Definition_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Definition);
Arg_Node : Node_Id;
begin
Check_Validity (Definition, "Asis.Definitions.Visible_Part_Items");
if not (Arg_Kind = A_Task_Definition or else
Arg_Kind = A_Protected_Definition)
then
Raise_ASIS_Inappropriate_Element
("Asis.Definitions.Visible_Part_Items");
end if;
Arg_Node := Node (Definition);
if Include_Pragmas then
return Node_To_Element_List
(List => Visible_Declarations (Arg_Node),
In_Unit => Encl_Unit (Definition));
else
return Node_To_Element_List
(List => Visible_Declarations (Arg_Node),
In_Unit => Encl_Unit (Definition),
To_Be_Included => No_Pragma'Access);
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Definition,
Bool_Par => Include_Pragmas,
Outer_Call => "Asis.Definitions.Visible_Part_Items");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Definition,
Bool_Par => Include_Pragmas,
Diagnosis => "Asis.Definitions.Visible_Part_Items");
end Visible_Part_Items;
-----------------------------------------------------------------------------
function Private_Part_Items
(Definition : in Asis.Definition;
Include_Pragmas : in Boolean := False)
return Asis.Definition_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Definition);
Arg_Node : Node_Id;
begin
Check_Validity (Definition, "Asis.Definitions.Private_Part_Items");
if not (Arg_Kind = A_Task_Definition or else
Arg_Kind = A_Protected_Definition)
then
Raise_ASIS_Inappropriate_Element
("Asis.Definitions.Private_Part_Items");
end if;
Arg_Node := Node (Definition);
return N_To_E_List_New
(List => Private_Declarations (Arg_Node),
Include_Pragmas => Include_Pragmas,
Starting_Element => Definition);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Definition,
Bool_Par => Include_Pragmas,
Outer_Call => "Asis.Definitions.Private_Part_Items");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Definition,
Bool_Par => Include_Pragmas,
Diagnosis => "Asis.Definitions.Private_Part_Items");
end Private_Part_Items;
-----------------------------------------------------------------------------
function Is_Private_Present (Definition : in Asis.Definition)
return Boolean
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Definition);
Arg_Node : Node_Id;
begin
Check_Validity (Definition, "Asis.Definitions.Is_Private_Present");
if not (Arg_Kind = A_Task_Definition or else
Arg_Kind = A_Protected_Definition)
then
-- unexpected element
return False;
end if;
Arg_Node := Node (Definition);
return Present (Private_Declarations (Arg_Node));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Definition,
Outer_Call => "Asis.Definitions.Is_Private_Present");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Definition,
Diagnosis => "Asis.Definitions.Is_Private_Present");
end Is_Private_Present;
-----------------------------------------------------------------------------
end Asis.Definitions