File : asis-statements.adb
------------------------------------------------------------------------------
-- --
-- ASIS-for-GNAT IMPLEMENTATION COMPONENTS --
-- --
-- A S I S . S T A T E M E N T S --
-- --
-- B o d y --
-- --
-- Copyright (c) 1995-1999, Free Software Foundation, Inc. --
-- --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
-- Software Foundation; either version 2, or (at your option) any later --
-- version. ASIS-for-GNAT is distributed in the hope that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General --
-- Public License for more details. You should have received a copy of the --
-- GNU General Public License distributed with ASIS-for-GNAT; see file --
-- COPYING. If not, write to the Free Software Foundation, 59 Temple Place --
-- - Suite 330, Boston, MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the --
-- Software Engineering Laboratory of the Swiss Federal Institute of --
-- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the --
-- Scientific Research Computer Center of Moscow State University (SRCC --
-- MSU), Russia, with funding partially provided by grants from the Swiss --
-- National Science Foundation and the Swiss Academy of Engineering --
-- Sciences. ASIS-for-GNAT is now maintained by Ada Core Technologies Inc --
-- (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
-- ASIS-specific contex clauses:
with Asis.Exceptions; use Asis.Exceptions;
with Asis.Elements; use Asis.Elements;
with Asis.Declarations; use Asis.Declarations;
with Asis.Expressions; use Asis.Expressions;
with Asis.Extensions; use Asis.Extensions;
-- Implementation-specific contex clauses:
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.A_Sem; use A4G.A_Sem;
with A4G.A_Sinput; use A4G.A_Sinput;
with A4G.Span_End; use A4G.Span_End;
with Asis.Extensions; use Asis.Extensions;
-- GNAT-specific contex clauses:
with Types; use Types;
with Sinfo; use Sinfo;
with Nlists; use Nlists;
with Atree; use Atree;
with Sinput; use Sinput;
package body Asis.Statements is
-- !!!??? This file is '-gnatg-compilable', but both its content and its
-- !!!??? documentation need revising
LT : String renames ASIS_Line_Terminator;
------------------------------------------------------------------------------
function Label_Names (Statement : in Asis.Statement)
return Asis.Defining_Name_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
Labels_Number : Nat := 0; -- how many labels the statement has
Label_Node : Node_Id;
begin
Check_Validity (Statement, "Asis.Statements.Label_Names");
if not (Arg_Kind in Internal_Statement_Kinds) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Statements.Label_Names");
end if;
Arg_Node := Node (Statement);
if not Is_List_Member (Arg_Node) then
-- the accept statement in accept alternative, it cannot
-- have lables at all
return Nil_Element_List;
end if;
Label_Node := Prev (Arg_Node);
while Nkind (Label_Node) = N_Label loop
Labels_Number := Labels_Number + 1;
Label_Node := Prev (Label_Node);
end loop;
-- Label_Node is not the Node of N_Label kind now
if Labels_Number = 0 then
return Nil_Element_List;
else
declare
Result_List : Asis.Element_List
(1 .. ASIS_Integer (Labels_Number));
begin
if Label_Node = Empty then
-- special case: the first statement in the statement
-- sequence is labeled
Label_Node := First (List_Containing (Arg_Node));
else
Label_Node := Next (Label_Node);
end if;
-- the first label attached to the statement and the number of
-- attached lables are obtained
-- forming the result:
for I in 1 .. ASIS_Integer (Labels_Number) loop
-- the order of labels is important !
Result_List (I) := Node_To_Element_New (
Node => Label_Node,
Internal_Kind => A_Defining_Identifier,
Starting_Element => Statement);
Label_Node := Next (Label_Node);
end loop;
return Result_List;
end;
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Outer_Call => "Asis.Statements.Label_Names");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Diagnosis => "Asis.Statements.Label_Names");
end Label_Names;
-----------------------------------------------------------------------------
function Assignment_Variable_Name (Statement : in Asis.Statement)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
begin
Check_Validity (Statement, "Asis.Statements.Assignment_Name");
if not (Arg_Kind = An_Assignment_Statement) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Statements.Assignment_Name");
end if;
Arg_Node := Node (Statement);
return Node_To_Element_New (
Node => Sinfo.Name (Arg_Node),
Starting_Element => Statement);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Outer_Call => "Asis.Statements.Assignment_Name");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Diagnosis => "Asis.Statements.Assignment_Name");
end Assignment_Variable_Name;
-----------------------------------------------------------------------------
function Assignment_Expression (Statement : in Asis.Statement)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
begin
Check_Validity (Statement, "Asis.Statements.Assignment_Expression");
if not (Arg_Kind = An_Assignment_Statement) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Statements.Assignment_Expression");
end if;
Arg_Node := Node (Statement);
return Node_To_Element_New (
Node => Sinfo.Expression (Arg_Node),
Starting_Element => Statement);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Outer_Call => "Asis.Statements.Assignment_Expression");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Diagnosis => "Asis.Statements.Assignment_Expression");
end Assignment_Expression;
-----------------------------------------------------------------------------
function Statement_Paths (Statement : in Asis.Statement;
Include_Pragmas : in Boolean := False)
return Asis.Path_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
Path_List_Length : ASIS_Integer; -- Length of returned list
Elsif_Or_Length : ASIS_Integer; -- Number of Elsif or Or paths
Else_Present : Boolean;
begin
Check_Validity (Statement, "Asis.Statements.Statement_Paths");
if not (Arg_Kind = An_If_Statement
or Arg_Kind = A_Case_Statement
or Arg_Kind = A_Selective_Accept_Statement
or Arg_Kind = A_Timed_Entry_Call_Statement
or Arg_Kind = A_Conditional_Entry_Call_Statement
or Arg_Kind = An_Asynchronous_Select_Statement)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Statements.Statement_Paths");
end if;
Arg_Node := Node (Statement);
case Arg_Kind is
when An_If_Statement =>
Path_List_Length := 1; -- An_If_Path
Else_Present := Present (Else_Statements (Arg_Node));
if Else_Present then
Path_List_Length := Path_List_Length + 1;
end if;
if Present (Elsif_Parts (Arg_Node)) then
Elsif_Or_Length := ASIS_Integer
(List_Length (Elsif_Parts (Arg_Node)));
else
Elsif_Or_Length := 0;
end if;
Path_List_Length := Path_List_Length + Elsif_Or_Length;
declare
Path_List : Asis.Element_List (1 .. Path_List_Length);
begin -- Element List to be returned by the function
Path_List (1) := Node_To_Element_New
(Node => Arg_Node,
Internal_Kind => An_If_Path,
Starting_Element => Statement);
Path_List (2 .. Elsif_Or_Length + 1) := Node_To_Element_List
(List => Elsif_Parts (Arg_Node),
Internal_Kind => An_Elsif_Path,
In_Unit => Encl_Unit (Statement));
if Else_Present then
Path_List (Path_List_Length) := Node_To_Element_New
(Node => Arg_Node,
Internal_Kind => An_Else_Path,
Starting_Element => Statement);
end if;
return Path_List;
end;
when A_Case_Statement =>
-- only here the value of Include_Pragmas is important
if Include_Pragmas then
return N_To_E_List_With_Pragmas
(List => Alternatives (Arg_Node),
In_Unit => Encl_Unit (Statement));
else
return N_To_E_List_Without_Pragmas
(List => Alternatives (Arg_Node),
In_Unit => Encl_Unit (Statement));
end if;
when A_Selective_Accept_Statement =>
Elsif_Or_Length := ASIS_Integer
(List_Length (Select_Alternatives (Arg_Node)));
Path_List_Length := Elsif_Or_Length;
Else_Present := Present (Else_Statements (Arg_Node));
if Else_Present then
Path_List_Length := Path_List_Length + 1;
end if;
declare
Path_List : Asis.Element_List (1 .. Path_List_Length);
begin -- Element List to be returned by the function
Path_List (1 .. Elsif_Or_Length) := Node_To_Element_List
(List => Select_Alternatives (Arg_Node),
In_Unit => Encl_Unit (Statement));
if Else_Present then
Path_List (Path_List_Length) := Node_To_Element_New
(Node => Arg_Node,
Internal_Kind => An_Else_Path,
Starting_Element => Statement);
end if;
return Path_List;
end;
when A_Timed_Entry_Call_Statement =>
return Asis.Path_List' (
1 => Node_To_Element_New (
Node => Entry_Call_Alternative (Arg_Node),
Internal_Kind => A_Select_Path,
Starting_Element => Statement),
2 => Node_To_Element_New (
Node => Delay_Alternative (Arg_Node),
Internal_Kind => An_Or_Path,
Starting_Element => Statement));
when A_Conditional_Entry_Call_Statement =>
return Asis.Path_List' (
1 => Node_To_Element_New (
Node => Entry_Call_Alternative (Arg_Node),
Internal_Kind => A_Select_Path,
Starting_Element => Statement),
2 => Node_To_Element_New (
Node => Arg_Node,
Internal_Kind => An_Else_Path,
Starting_Element => Statement));
when An_Asynchronous_Select_Statement =>
return Asis.Path_List' (
1 => Node_To_Element_New (
Node => Triggering_Alternative (Arg_Node),
Internal_Kind => A_Select_Path,
Starting_Element => Statement),
2 => Node_To_Element_New (
Node => Abortable_Part (Arg_Node),
Internal_Kind => A_Then_Abort_Path,
Starting_Element => Statement));
when others =>
raise ASIS_Failed;
-- this choice can never be reached, see the condition
-- for defining the appropriate element
end case;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Bool_Par => Include_Pragmas,
Outer_Call => "Asis.Statements.Statement_Paths");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Diagnosis => "Asis.Statements.Statement_Paths");
end Statement_Paths;
-----------------------------------------------------------------------------
function Condition_Expression (Path : in Asis.Path) return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Path);
Arg_Node : Node_Id;
begin
Check_Validity (Path, "Asis.Statements.Condition_Expression");
if not (Arg_Kind = An_If_Path or
Arg_Kind = An_Elsif_Path)
then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Statements.Condition_Expression");
end if;
Arg_Node := Node (Path);
return Node_To_Element_New (Node => Condition (Arg_Node),
Starting_Element => Path);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Path,
Outer_Call => "Asis.Statements.Condition_Expression");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Path,
Diagnosis => "Asis.Statements.Condition_Expression");
end Condition_Expression;
-----------------------------------------------------------------------------
function Sequence_Of_Statements
(Path : in Asis.Path;
Include_Pragmas : in Boolean := False)
return Asis.Statement_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Path);
Arg_Node : Node_Id;
Result_List : List_Id;
-- for processing An_If_Path, An_Elsif_Path, An_Else_Path, A_Case_Path
-- and A_Then_Abort_Path arguments; the node of such argument has
-- regular structure
-- local variables for processing A_Select_Path and An_Or_Path
-- arguments; the node of such arguments has irregular structure
Statement_List : List_Id;
First_Element : Asis.Element := Nil_Element;
Alternative_Node_Kind : Node_Kind;
Incl_Cond : Inclusion_Condition;
begin
Check_Validity (Path, "Asis.Statements.Sequence_Of_Statements");
if not (Arg_Kind in Internal_Path_Kinds) then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
"Asis.Statements.Sequence_Of_Statements");
end if;
Arg_Node := Node (Path);
if Include_Pragmas then
Incl_Cond := Every_Node'Access;
else
Incl_Cond := No_Pragma'Access;
end if;
case Arg_Kind is
when An_If_Path | An_Elsif_Path =>
Result_List := Then_Statements (Arg_Node);
when An_Else_Path =>
Result_List := Else_Statements (Arg_Node);
when A_Case_Path =>
Result_List := Sinfo.Statements (Arg_Node);
when A_Then_Abort_Path =>
Result_List := Sinfo.Statements (Arg_Node);
when A_Select_Path | An_Or_Path =>
Alternative_Node_Kind := Nkind (Arg_Node);
if Alternative_Node_Kind = N_Terminate_Alternative then
-- special case: result list contains only one dummy terminate
-- statement; no tree traversing needed: the result is based
-- on the same node as the argument
return Asis.Statement_List'(
1 => Node_To_Element_New (
Node => Arg_Node,
Internal_Kind => A_Terminate_Alternative_Statement,
Starting_Element => Path));
else
-- this alternative corresponds to the situation of
-- N_Accept_Alternative, N_Delay_Alternative,
-- N_Entry_Call_Alternative or N_Triggering_Alternative
-- forming the first element of the element list to be
-- returned:
if Alternative_Node_Kind = N_Accept_Alternative then
First_Element :=
Node_To_Element_New (
Node => Accept_Statement (Arg_Node),
Internal_Kind => An_Accept_Statement,
Starting_Element => Path);
elsif Alternative_Node_Kind = N_Delay_Alternative then
First_Element :=
Node_To_Element_New (
Node => Delay_Statement (Arg_Node),
Starting_Element => Path);
elsif Alternative_Node_Kind = N_Entry_Call_Alternative then
First_Element :=
Node_To_Element_New (
Node => Entry_Call_Statement (Arg_Node),
Internal_Kind => An_Entry_Call_Statement,
Starting_Element => Path);
elsif Alternative_Node_Kind = N_Triggering_Alternative then
First_Element :=
Node_To_Element_New (
Node => Triggering_Statement (Arg_Node),
Starting_Element => Path);
end if;
-- the rest of the returned list:
Statement_List := Sinfo.Statements (Arg_Node);
return Asis.Statement_List'(1 => First_Element) &
Node_To_Element_List (List => Statement_List,
In_Unit => Encl_Unit (Path),
To_Be_Included => Incl_Cond);
end if;
when others =>
null; -- see condition for defining the appropriate element
end case;
return Node_To_Element_List (List => Result_List,
In_Unit => Encl_Unit (Path),
To_Be_Included => Incl_Cond);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Path,
Bool_Par => Include_Pragmas,
Outer_Call => "Asis.Statements.Sequence_Of_Statements");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Path,
Bool_Par => Include_Pragmas,
Diagnosis => "Asis.Statements.Sequence_Of_Statements");
end Sequence_Of_Statements;
-----------------------------------------------------------------------------
function Case_Expression (Statement : in Asis.Statement)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
begin
Check_Validity (Statement, "Asis.Statements.Case_Expression");
if not (Arg_Kind = A_Case_Statement) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Statements.Case_Expression");
end if;
Arg_Node := Node (Statement);
return Node_To_Element_New
(Node => Sinfo.Expression (Arg_Node),
Starting_Element => Statement);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Outer_Call => "Asis.Statements.Case_Expression");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Diagnosis => "Asis.Statements.Case_Expression");
end Case_Expression;
-----------------------------------------------------------------------------
function Case_Statement_Alternative_Choices (Path : in Asis.Path)
return Asis.Element_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Path);
Arg_Node : Node_Id;
begin
Check_Validity (Path,
"Asis.Statements.Case_Statement_Alternative_Choices");
if not (Arg_Kind = A_Case_Path) then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
"Asis.Statements.Case_Statement_Alternative_Choices");
end if;
Arg_Node := Node (Path);
return Discrete_Choice_Node_To_Element_List (
Choice_List => Discrete_Choices (Arg_Node),
In_Unit => Encl_Unit (Path));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Path,
Outer_Call =>
"Asis.Statements.Case_Statement_Alternative_Choices");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Path,
Diagnosis => "Asis.Statements.Case_Statement_Alternative_Choices");
end Case_Statement_Alternative_Choices;
------------------------------------------------------------------------------
function Statement_Identifier (Statement : in Asis.Statement)
return Asis.Defining_Name
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
begin
Check_Validity (Statement,
"Asis.Statements.Loop_Statement_Identifier");
if not (Arg_Kind = A_Loop_Statement
or Arg_Kind = A_While_Loop_Statement
or Arg_Kind = A_For_Loop_Statement
or Arg_Kind = A_Block_Statement)
then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
"Asis_Statement.Statement_Identifier");
end if;
Arg_Node := Node (Statement);
if Special_Case (Statement) = A_Dummy_Block_Statement or else
Has_Created_Identifier (Arg_Node)
then
return Nil_Element;
else
return Node_To_Element_New (
Node => Sinfo.Identifier (Arg_Node),
Internal_Kind => A_Defining_Identifier,
Starting_Element => Statement);
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Outer_Call => "Asis.Statements.Statement_Identifier");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Diagnosis => "Asis.Statements.Statement_Identifier");
end Statement_Identifier;
-----------------------------------------------------------------------------
function Is_Name_Repeated (Statement : in Asis.Statement) return Boolean
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Last_Comp : Asis.Element;
S : Source_Ptr;
Result : Boolean;
begin
Check_Validity (Statement, "Asis.Statements.Is_Name_Repeated");
if not (Arg_Kind = A_Loop_Statement or else
Arg_Kind = A_While_Loop_Statement or else
Arg_Kind = A_For_Loop_Statement or else
Arg_Kind = A_Block_Statement or else
Arg_Kind = An_Accept_Statement)
then
Result := False;
end if;
if Arg_Kind = A_Loop_Statement or else
Arg_Kind = A_While_Loop_Statement or else
Arg_Kind = A_For_Loop_Statement or else
Arg_Kind = A_Block_Statement
then
Result := not Asis.Elements.Is_Nil (Statement_Identifier (Statement));
elsif Arg_Kind = An_Accept_Statement then
if Is_Nil (Accept_Body_Statements (Statement, True)) then
-- no statements - no "do .. end;" part - no "end"
-- to repeat the name after
Result := False;
else
Last_Comp := Get_Last_Component (Statement);
S := Set_Image_End (Last_Comp);
-- now S points to the last character (it for sure is ';')
-- of the last component (a statement, an exception
-- handler or pragma) in the accept statement.
-- First, we reset S to point onto the first character
-- after the final end of the accept statement:
-- the final "end" lexically is an identifier, so:
S := Next_Identifier (S);
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;
end if;
return Result;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Outer_Call => "Asis.Statements.Is_Name_Repeated");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Diagnosis => "Asis.Statements.Is_Name_Repeated");
end Is_Name_Repeated;
-----------------------------------------------------------------------------
function While_Condition (Statement : in Asis.Statement)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
begin
Check_Validity (Statement, "Asis.Statements.While_Condition");
if not (Arg_Kind = A_While_Loop_Statement) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Statements.While_Condition");
end if;
Arg_Node := Node (Statement);
return Node_To_Element_New (
Node => Condition (Iteration_Scheme (Arg_Node)),
Starting_Element => Statement);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Outer_Call => "Asis.Statements.While_Condition");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Diagnosis => "Asis.Statements.While_Condition");
end While_Condition;
-----------------------------------------------------------------------------
function For_Loop_Parameter_Specification (Statement : in Asis.Statement)
return Asis.Declaration
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
begin
Check_Validity (Statement,
"Asis.Statements.For_Loop_Parameter_Specification");
if not (Arg_Kind = A_For_Loop_Statement) then
Raise_ASIS_Inappropriate_Element
(Diagnosis => "Asis.Statements.For_Loop_Parameter_Specification");
end if;
Arg_Node := Node (Statement);
return Node_To_Element_New (
Node => Loop_Parameter_Specification
(Iteration_Scheme (Arg_Node)),
Internal_Kind => A_Loop_Parameter_Specification,
Starting_Element => Statement);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Outer_Call => "Asis.Statements.For_Loop_Parameter_Specification");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Diagnosis => "Asis.Statements.For_Loop_Parameter_Specification");
end For_Loop_Parameter_Specification;
-----------------------------------------------------------------------------
function Loop_Statements
(Statement : in Asis.Statement;
Include_Pragmas : in Boolean := False)
return Asis.Statement_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
begin
Check_Validity (Statement, "Asis.Statements.Loop_Statements");
if not (Arg_Kind = A_Loop_Statement or else
Arg_Kind = A_While_Loop_Statement or else
Arg_Kind = A_For_Loop_Statement)
then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
"Asis_Statement.Loop_Statements");
end if;
Arg_Node := Node (Statement);
if Include_Pragmas then
return Node_To_Element_List (
List => Sinfo.Statements (Arg_Node),
In_Unit => Encl_Unit (Statement));
else
return Node_To_Element_List (
List => Sinfo.Statements (Arg_Node),
In_Unit => Encl_Unit (Statement),
To_Be_Included => No_Pragma'Access);
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Bool_Par => Include_Pragmas,
Outer_Call => "Asis.Statements.Loop_Statements");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Bool_Par => Include_Pragmas,
Diagnosis => "Asis.Statements.Loop_Statements");
end Loop_Statements;
------------------------------------------------------------------------------
function Is_Declare_Block (Statement : in Asis.Statement) return Boolean
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
First_Letter : Character;
-- the first character of the statement, should be either
-- B[egin] or D[eclare]
begin
-- If the argument represents the dummy block statement created by
-- the Asis_Declarations.Body_Block_Statement (obsolescent!)
-- function, the result will be True if and only if the
-- corresponding body has any declarative item on its own.
Check_Validity (Statement, "Asis.Statements.Is_Declare_Block");
if not (Arg_Kind = A_Block_Statement) then
return False;
end if;
Arg_Node := Node (Statement);
if Special_Case (Statement) = A_Dummy_Block_Statement then
if Present (Sinfo.Declarations (Arg_Node)) then
return True;
else
return False;
end if;
else
-- a "normal" block statement: here we should be more accurate, and
-- we cannot rely on "Present (Declarations (Arg_Node))" approach
-- because of the implicit label declarations
First_Letter := Source_Text (Get_Source_File_Index (
Sloc (Arg_Node))) -- the unit's text buffer
(Sloc (Arg_Node));
case First_Letter is
when 'b' | 'B' =>
return False;
when 'd' | 'D' =>
return True;
when others =>
Raise_ASIS_Failed (Diagnosis =>
"Unexpected beginning of a block statement");
return False; -- to avoid GNAT warning
end case;
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Outer_Call => "Asis.Statements.Is_Declare_Block");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Diagnosis => "Asis.Statements.Is_Declare_Block");
end Is_Declare_Block;
------------------------------------------------------------------------------
function Block_Declarative_Items
(Statement : in Asis.Statement;
Include_Pragmas : in Boolean := False)
return Asis.Declarative_Item_List
is
Arg_El : Asis.Element;
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
begin
Check_Validity (Statement, "Asis.Statements.Block_Declarative_Items");
if not (Arg_Kind = A_Block_Statement)then
Raise_ASIS_Inappropriate_Element
("Asis.Statements.Block_Declarative_Items");
end if;
Arg_Node := Node (Statement);
Arg_El := Statement;
if Special_Case (Arg_El) = A_Dummy_Block_Statement then
Set_Special_Case (Arg_El, Not_A_Special_Case);
end if;
return N_To_E_List_New
(List => Sinfo.Declarations (Arg_Node),
Include_Pragmas => Include_Pragmas,
Starting_Element => Arg_El);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Bool_Par => Include_Pragmas,
Outer_Call => "Asis.Statements.Block_Declarative_Items");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Bool_Par => Include_Pragmas,
Diagnosis => "Asis.Statements.Block_Declarative_Items");
end Block_Declarative_Items;
-----------------------------------------------------------------------------
function Block_Statements
(Statement : in Asis.Statement;
Include_Pragmas : in Boolean := False)
return Asis.Statement_List
is
Arg_El : Asis.Element;
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
begin
Check_Validity (Statement, "Asis.Statements.Block_Statements");
if not (Arg_Kind = A_Block_Statement) then
Raise_ASIS_Inappropriate_Element
("Asis.Statements.Block_Statements");
end if;
Arg_Node := Node (Statement);
Arg_El := Statement;
if Special_Case (Arg_El) = A_Dummy_Block_Statement then
Set_Special_Case (Arg_El, Not_A_Special_Case);
end if;
return Statements_Node_To_Element_List (
Statements_Seq => Handled_Statement_Sequence (Arg_Node),
Include_Pragmas => Include_Pragmas,
Starting_Element => Arg_El);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Bool_Par => Include_Pragmas,
Outer_Call => "Asis.Statements.Block_Statements");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Bool_Par => Include_Pragmas,
Diagnosis => "Asis.Statements.Block_Statements");
end Block_Statements;
-----------------------------------------------------------------------------
function Block_Exception_Handlers
(Statement : in Asis.Statement;
Include_Pragmas : in Boolean := False)
return Asis.Exception_Handler_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
begin
Check_Validity (Statement, "Asis.Statements.Block_Exception_Handlers");
if not (Arg_Kind = A_Block_Statement) then
Raise_ASIS_Inappropriate_Element
("Asis.Statements.Block_Exception_Handlers");
end if;
Arg_Node := Node (Statement);
if Special_Case (Statement) = A_Dummy_Block_Statement and then
No (Handled_Statement_Sequence (Arg_Node))
then
-- for the dummy block originated from the package_body_declaration
-- having no handled_sequence_of_statements on its own.
return Nil_Element_List;
end if;
if Include_Pragmas then
return N_To_E_List_With_Pragmas
(List => Exception_Handlers (
Handled_Statement_Sequence (Arg_Node)),
In_Unit => Encl_Unit (Statement));
else
return N_To_E_List_Without_Pragmas
(List => Exception_Handlers (
Handled_Statement_Sequence (Arg_Node)),
In_Unit => Encl_Unit (Statement));
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Bool_Par => Include_Pragmas,
Outer_Call => "Asis.Statements.Block_Exception_Handlers");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Bool_Par => Include_Pragmas,
Diagnosis => "Asis.Statements.Block_Exception_Handlers");
end Block_Exception_Handlers;
-----------------------------------------------------------------------------
function Exit_Loop_Name (Statement : in Asis.Statement)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
Result_Node : Node_Id;
begin
Check_Validity (Statement, "Asis.Statements.Exit_Loop_Name");
if not (Arg_Kind = An_Exit_Statement) then
Raise_ASIS_Inappropriate_Element
("Asis.Statements.Exit_Loop_Name");
end if;
Arg_Node := Node (Statement);
Result_Node := Sinfo.Name (Arg_Node);
if No (Result_Node) then
return Nil_Element;
else
return Node_To_Element_New (Node => Result_Node,
Starting_Element => Statement);
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Outer_Call => "Asis.Statements.Exit_Loop_Name");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Diagnosis => "Asis.Statements.Exit_Loop_Name");
end Exit_Loop_Name;
-----------------------------------------------------------------------------
function Exit_Condition (Statement : in Asis.Statement)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
Result_Node : Node_Id;
begin
Check_Validity (Statement, "Asis.Statements.Exit_Condition");
if not (Arg_Kind = An_Exit_Statement) then
Raise_ASIS_Inappropriate_Element
("Asis.Statements.Exit_Loop_Name");
end if;
Arg_Node := Node (Statement);
Result_Node := Condition (Arg_Node);
if No (Result_Node) then
return Nil_Element;
else
return Node_To_Element_New (Node => Result_Node,
Starting_Element => Statement);
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Outer_Call => "Asis.Statements.Exit_Condition");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Diagnosis => "Asis.Statements.Exit_Condition");
end Exit_Condition;
------------------------------------------------------------------------------
function Corresponding_Loop_Exited
(Statement : in Asis.Statement)
return Asis.Statement
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
Res_Loop : Node_Id;
Loop_Name : Node_Id;
begin
Check_Validity (Statement,
"Asis.Statements.Corresponding_Loop_Exited");
if not (Arg_Kind = An_Exit_Statement) then
Raise_ASIS_Inappropriate_Element
("Asis.Statements.Corresponding_Loop_Exited");
end if;
-- this query can never cross compilation unit boundaries
Arg_Node := Node (Statement);
-- we hope, that the nodes for exist statements are never rewritten
Loop_Name := Sinfo.Name (Arg_Node);
if Present (Loop_Name) then
-- we simply jump to the result loop:
Loop_Name := Parent (Entity (Loop_Name));
-- here we are in the implicit declaration of the loop name
Res_Loop := Label_Construct (Loop_Name);
else
-- here we have to traverse the tree up to the furst enclosing
-- loop statement
Res_Loop := Parent (Arg_Node);
while Nkind (Res_Loop) /= N_Loop_Statement loop
Res_Loop := Parent (Res_Loop);
end loop;
end if;
return Node_To_Element_New (Node => Res_Loop,
Starting_Element => Statement);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Outer_Call => "Asis.Statements.Corresponding_Loop_Exited");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Diagnosis => "Asis.Statements.Corresponding_Loop_Exited");
end Corresponding_Loop_Exited;
------------------------------------------------------------------------------
function Return_Expression (Statement : in Asis.Statement)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
Result_Node : Node_Id;
begin
Check_Validity (Statement,
"Asis.Statements.Return_Expression");
if not (Arg_Kind = A_Return_Statement) then
Raise_ASIS_Inappropriate_Element
("Asis.Statements.Return_Expression");
end if;
Arg_Node := Node (Statement);
Result_Node := Sinfo.Expression (Arg_Node);
if No (Result_Node) then
return Nil_Element;
else
return Node_To_Element_New (Node => Result_Node,
Starting_Element => Statement);
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Outer_Call => "Asis.Statements.Return_Expression");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Diagnosis => "Asis.Statements.Return_Expression");
end Return_Expression;
-----------------------------------------------------------------------------
function Goto_Label (Statement : in Asis.Statement)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
begin
Check_Validity (Statement, "Asis.Statements.Goto_Label");
if not (Arg_Kind = A_Goto_Statement) then
Raise_ASIS_Inappropriate_Element
("Asis.Statements.Goto_Label");
end if;
Arg_Node := Node (Statement);
return Node_To_Element_New (Node => Sinfo.Name (Arg_Node),
Starting_Element => Statement);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Outer_Call => "Asis.Statements.Goto_Label");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Diagnosis => "Asis.Statements.Goto_Label");
end Goto_Label;
------------------------------------------------------------------------------
function Corresponding_Destination_Statement
(Statement : in Asis.Statement)
return Asis.Statement
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
Res_Label : Node_Id;
Res_Stmt : Node_Id;
begin
Check_Validity (Statement,
"Asis.Statements.Corresponding_Destination_Statement");
if not (Arg_Kind = A_Goto_Statement) then
Raise_ASIS_Inappropriate_Element
("Asis.Statements.Corresponding_Destination_Statement");
end if;
-- this semantiic query can never cross compilation units
-- boundaries
Arg_Node := Node (Statement);
-- we hope, that the nodes for goto statements
-- are never rewritten
Res_Label := Parent (Entity (Sinfo.Name (Arg_Node)));
-- this is N_Implicit_Label_Declaration node representing the
-- implicit declaration of the destination label
Res_Stmt := Label_Construct (Res_Label);
while not (Nkind (Res_Stmt) in N_Statement or else
Nkind (Res_Stmt) = N_Procedure_Call_Statement)
loop
Res_Stmt := Next (Res_Stmt);
end loop;
-- if we are in the tree corresponding to a succussful compiler
-- run, we shall for sure find a statement after any label!
return Node_To_Element_New (Node => Res_Stmt,
Starting_Element => Statement);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Outer_Call =>
"Asis.Statements.Corresponding_Destination_Statement");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Diagnosis =>
"Asis.Statements.Corresponding_Destination_Statement");
end Corresponding_Destination_Statement;
------------------------------------------------------------------------------
function Called_Name (Statement : in Asis.Statement)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
-- local variables needed for processing calls to 'Output, 'Read
-- and 'Write:
Result_Kind : Internal_Element_Kinds := Not_An_Element;
Result_Node : Node_Id;
begin
Check_Validity (Statement, "Asis.Statements.Called_Name");
if not (Arg_Kind = An_Entry_Call_Statement or else
Arg_Kind = A_Procedure_Call_Statement)
then
Raise_ASIS_Inappropriate_Element
("Asis.Statements.Called_Name");
end if;
Arg_Node := Node (Statement);
if Nkind (Arg_Node) = N_Attribute_Reference then
-- calls like T'Output (...); T'Read (...) and T'Write (...)
-- should be processed separately, and the result should
-- be built on the same node as argument
Result_Kind := Subprogram_Attribute_Kind (Arg_Node);
Result_Node := Arg_Node;
else
Result_Node := Sinfo.Name (Arg_Node);
end if;
return Node_To_Element_New (
Starting_Element => Statement,
Node => Result_Node,
Internal_Kind => Result_Kind);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Outer_Call => "Asis.Statements.Called_Name");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Diagnosis => "Asis.Statements.Called_Name");
end Called_Name;
-----------------------------------------------------------------------------
function Corresponding_Called_Entity
(Statement : in Asis.Statement)
return Asis.Declaration
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
begin
Check_Validity (Statement,
"Asis.Statements.Corresponding_Called_Entity");
if not (Arg_Kind = An_Entry_Call_Statement or else
Arg_Kind = A_Procedure_Call_Statement)
then
Raise_ASIS_Inappropriate_Element (Diagnosis =>
"Asis.Statements.Corresponding_Called_Entity");
end if;
return Get_Corr_Called_Entity (Statement);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Outer_Call => "Asis.Statements.Corresponding_Called_Entity");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Diagnosis => "Asis.Statements.Corresponding_Called_Entity");
end Corresponding_Called_Entity;
------------------------------------------------------------------------------
function Call_Statement_Parameters
(Statement : in Asis.Statement;
Normalized : in Boolean := False)
return Asis.Association_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
Res_Spec_Case : Special_Cases := Not_A_Special_Case;
Res_Node_List : List_Id;
begin
Check_Validity (Statement, "Asis.Statements.Call_Statement_Parameters");
Arg_Node := Node (Statement);
if (not (Arg_Kind = An_Entry_Call_Statement or else
Arg_Kind = A_Procedure_Call_Statement))
or else
(Normalized and then Nkind (Arg_Node) = N_Attribute_Reference)
then
Raise_ASIS_Inappropriate_Element
("Asis.Statements.Call_Statement_Parameters");
end if;
Arg_Node := Node (Statement);
if Normalized then
Res_Spec_Case := Is_Normalized;
end if;
if Nkind (Arg_Node) = N_Attribute_Reference then
-- call to 'Output, 'Read or 'Write
Res_Node_List := Sinfo.Expressions (Arg_Node);
else
Res_Node_List := Parameter_Associations (Arg_Node);
end if;
return N_To_E_List_Without_Pragmas (
List => Res_Node_List,
Internal_Kind => A_Parameter_Association,
Special_Case => Res_Spec_Case,
In_Unit => Encl_Unit (Statement));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Bool_Par => Normalized,
Outer_Call => "Asis.Statements.Call_Statement_Parameters");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Bool_Par => Normalized,
Diagnosis => "Asis.Statements.Call_Statement_Parameters");
end Call_Statement_Parameters;
-----------------------------------------------------------------------------
function Accept_Entry_Index (Statement : in Asis.Statement)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
Result_Node : Node_Id;
begin
Check_Validity (Statement, "Asis.Statements.Accept_Entry_Index");
if not (Arg_Kind = An_Accept_Statement) then
Raise_ASIS_Inappropriate_Element
("Asis.Statements.Accept_Entry_Index");
end if;
Arg_Node := Node (Statement);
Result_Node := Entry_Index (Arg_Node);
if No (Result_Node) then
return Nil_Element;
else
return Node_To_Element_New (Node => Result_Node,
Starting_Element => Statement);
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Outer_Call => "Asis.Statements.Accept_Entry_Index");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Diagnosis => "Asis.Statements.Accept_Entry_Index");
end Accept_Entry_Index;
-----------------------------------------------------------------------------
function Accept_Entry_Direct_Name (Statement : in Asis.Statement)
return Asis.Name
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
begin
Check_Validity (Statement, "Asis.Statements.Accept_Entry_Direct_Name");
if not (Arg_Kind = An_Accept_Statement) then
Raise_ASIS_Inappropriate_Element
("Asis.Statements.Accept_Entry_Direct_Name");
end if;
Arg_Node := Node (Statement);
return Node_To_Element_New (
Node => Entry_Direct_Name (Arg_Node),
Internal_Kind => An_Identifier,
Starting_Element => Statement);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Outer_Call => "Asis.Statements.Accept_Entry_Direct_Name");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Diagnosis => "Asis.Statements.Accept_Entry_Direct_Name");
end Accept_Entry_Direct_Name;
-----------------------------------------------------------------------------
function Accept_Parameters
(Statement : in Asis.Statement)
return Asis.Parameter_Specification_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
begin
Check_Validity (Statement, "Asis.Statements.Accept_Parameters");
if not (Arg_Kind = An_Accept_Statement) then
Raise_ASIS_Inappropriate_Element
("Asis.Statements.Accept_Parameters");
end if;
Arg_Node := Node (Statement);
return N_To_E_List_New
(List => Parameter_Specifications (Arg_Node),
Starting_Element => Statement,
Internal_Kind => A_Parameter_Specification);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Outer_Call => "Asis.Statements.Accept_Parameters");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Diagnosis => "Asis.Statements.Accept_Parameters");
end Accept_Parameters;
-----------------------------------------------------------------------------
function Accept_Body_Statements
(Statement : in Asis.Statement;
Include_Pragmas : in Boolean := False)
return Asis.Statement_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
begin
Check_Validity (Statement, "Asis.Statements.Accept_Body_Statements");
if not (Arg_Kind = An_Accept_Statement) then
Raise_ASIS_Inappropriate_Element
("Asis.Statements.Accept_Body_Statements");
end if;
Arg_Node := Node (Statement);
return Statements_Node_To_Element_List (
Statements_Seq => Handled_Statement_Sequence (Arg_Node),
Include_Pragmas => Include_Pragmas,
Starting_Element => Statement);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Bool_Par => Include_Pragmas,
Outer_Call => "Asis.Statements.Accept_Body_Statements");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Bool_Par => Include_Pragmas,
Diagnosis => "Asis.Statements.Accept_Body_Statements");
end Accept_Body_Statements;
-----------------------------------------------------------------------------
function Accept_Body_Exception_Handlers
(Statement : in Asis.Statement;
Include_Pragmas : in Boolean := False)
return Asis.Exception_Handler_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
St_Seq_Node : Node_Id;
begin
Check_Validity (Statement,
"Asis.Statements.Accept_Body_Exception_Handlers");
if not (Arg_Kind = An_Accept_Statement) then
Raise_ASIS_Inappropriate_Element
("Asis.Statements.Accept_Body_Exception_Handlers");
end if;
Arg_Node := Node (Statement);
St_Seq_Node := Handled_Statement_Sequence (Arg_Node);
if No (St_Seq_Node) then
-- empty body of an accept statement
return Nil_Element_List;
elsif Include_Pragmas then
return N_To_E_List_With_Pragmas
(List => Exception_Handlers (St_Seq_Node),
In_Unit => Encl_Unit (Statement));
else
return N_To_E_List_Without_Pragmas
(List => Exception_Handlers (St_Seq_Node),
In_Unit => Encl_Unit (Statement));
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Bool_Par => Include_Pragmas,
Outer_Call => "Asis.Statements.Accept_Body_Exception_Handlers");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Bool_Par => Include_Pragmas,
Diagnosis => "Asis.Statements.Accept_Body_Exception_Handlers");
end Accept_Body_Exception_Handlers;
-----------------------------------------------------------------------------
function Corresponding_Entry (Statement : in Asis.Statement)
return Asis.Declaration
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
Res_Entry_Dcl : Node_Id;
begin
Check_Validity (Statement, "Asis.Statements.Corresponding_Entry");
if not (Arg_Kind = An_Accept_Statement) then
Raise_ASIS_Inappropriate_Element
("Asis.Statements.Corresponding_Entry");
end if;
Arg_Node := Node (Statement);
Res_Entry_Dcl := Parent (Entity (Entry_Direct_Name (Arg_Node)));
return Node_To_Element_New (Node => Res_Entry_Dcl,
Starting_Element => Statement);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Outer_Call => "Asis.Statements.Corresponding_Entry");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Diagnosis => "Asis.Statements.Corresponding_Entry");
end Corresponding_Entry;
-----------------------------------------------------------------------------
function Requeue_Entry_Name (Statement : in Asis.Statement)
return Asis.Name
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
begin
Check_Validity (Statement, "Asis.Statements.Requeue_Entry_Name");
if not (Arg_Kind = A_Requeue_Statement
or Arg_Kind = A_Requeue_Statement_With_Abort)
then
Raise_ASIS_Inappropriate_Element
("Asis.Statements.Requeue_Entry_Name");
end if;
Arg_Node := Node (Statement);
return Node_To_Element_New (Node => Sinfo.Name (Arg_Node),
Starting_Element => Statement);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Outer_Call => "Asis.Statements.Requeue_Entry_Name");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Diagnosis => "Asis.Statements.Requeue_Entry_Name");
end Requeue_Entry_Name;
-----------------------------------------------------------------------------
function Delay_Expression (Statement : in Asis.Statement)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
begin
Check_Validity (Statement, "Asis.Statements.Delay_Expression");
if not (Arg_Kind = A_Delay_Until_Statement
or Arg_Kind = A_Delay_Relative_Statement)
then
Raise_ASIS_Inappropriate_Element
("Asis.Statements.Delay_Expression");
end if;
Arg_Node := Node (Statement);
return Node_To_Element_New
(Node => Sinfo.Expression (Arg_Node),
Starting_Element => Statement);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Outer_Call => "Asis.Statements.Delay_Expression");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Diagnosis => "Asis.Statements.Delay_Expression");
end Delay_Expression;
-----------------------------------------------------------------------------
function Guard (Path : in Asis.Path) return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Path);
Arg_Node : Node_Id;
Result_Node : Node_Id;
begin
Check_Validity (Path, "Asis.Statements.Guard");
if not (Arg_Kind = A_Select_Path or else
Arg_Kind = An_Or_Path)
then
Raise_ASIS_Inappropriate_Element
("Asis.Statements.Guard");
end if;
if not (Nkind (Parent (R_Node (Path))) = N_Selective_Accept) then
return Nil_Element;
end if;
Arg_Node := Node (Path);
Result_Node := Condition (Arg_Node);
if No (Result_Node) then
return Nil_Element;
else
return Node_To_Element_New (Node => Result_Node,
Starting_Element => Path);
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Path,
Outer_Call => "Asis.Statements.Guard");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Path,
Diagnosis => "Asis.Statements.Guard");
end Guard;
-----------------------------------------------------------------------------
function Aborted_Tasks (Statement : in Asis.Statement)
return Asis.Expression_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
begin
Check_Validity (Statement, "Asis.Statements.Aborted_Tasks");
if not (Arg_Kind = An_Abort_Statement) then
Raise_ASIS_Inappropriate_Element
("Asis.Statements.Aborted_Tasks");
end if;
Arg_Node := Node (Statement);
return Node_To_Element_List (
List => Names (Arg_Node),
In_Unit => Encl_Unit (Statement));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Outer_Call => "Asis.Statements.Aborted_Tasks");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Diagnosis => "Asis.Statements.Aborted_Tasks");
end Aborted_Tasks;
-----------------------------------------------------------------------------
function Choice_Parameter_Specification
(Handler : in Asis.Exception_Handler)
return Asis.Declaration
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Handler);
Arg_Node : Node_Id;
Result_Node : Node_Id;
begin
Check_Validity (Handler,
"Asis.Statements.Choice_Parameter_Specification");
if not (Arg_Kind = An_Exception_Handler) then
Raise_ASIS_Inappropriate_Element
("Asis.Statements.Choice_Parameter_Specification");
end if;
Arg_Node := Node (Handler);
Result_Node := Choice_Parameter (Arg_Node);
if No (Result_Node) then
return Nil_Element;
else
return Node_To_Element_New (
Node => Result_Node,
Internal_Kind => A_Choice_Parameter_Specification,
Starting_Element => Handler);
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Handler,
Outer_Call => "Asis.Statements.Choice_Parameter_Specification");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Handler,
Diagnosis => "Asis.Statements.Choice_Parameter_Specification");
end Choice_Parameter_Specification;
-----------------------------------------------------------------------------
function Exception_Choices (Handler : in Asis.Exception_Handler)
return Asis.Element_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Handler);
Arg_Node : Node_Id;
begin
Check_Validity (Handler, "Asis.Statements.Exception_Choices");
if not (Arg_Kind = An_Exception_Handler) then
Raise_ASIS_Inappropriate_Element
("Asis.Statements.Exception_Choices");
end if;
Arg_Node := Node (Handler);
return Node_To_Element_List (
List => Exception_Choices (Arg_Node),
In_Unit => Encl_Unit (Handler));
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Handler,
Outer_Call => "Asis.Statements.Exception_Choices");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Handler,
Diagnosis => "Asis.Statements.Exception_Choices");
end Exception_Choices;
-----------------------------------------------------------------------------
function Handler_Statements
(Handler : in Asis.Exception_Handler;
Include_Pragmas : in Boolean := False)
return Asis.Statement_List
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Handler);
Arg_Node : Node_Id;
begin
Check_Validity (Handler, "Asis.Statements.Handler_Statements");
if not (Arg_Kind = An_Exception_Handler) then
Raise_ASIS_Inappropriate_Element
("Asis.Statements.Handler_Statements");
end if;
Arg_Node := Node (Handler);
if Include_Pragmas then
return Node_To_Element_List (
List => Sinfo.Statements (Arg_Node),
In_Unit => Encl_Unit (Handler));
else
return Node_To_Element_List (
List => Sinfo.Statements (Arg_Node),
In_Unit => Encl_Unit (Handler),
To_Be_Included => No_Pragma'Access);
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Handler,
Bool_Par => Include_Pragmas,
Outer_Call => "Asis.Statements.Handler_Statements");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Handler,
Bool_Par => Include_Pragmas,
Diagnosis => "Asis.Statements.Handler_Statements");
end Handler_Statements;
-----------------------------------------------------------------------------
function Raised_Exception (Statement : in Asis.Statement)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
Result_Node : Node_Id;
begin
Check_Validity (Statement, "Asis.Statements.Raised_Exception");
if not (Arg_Kind = A_Raise_Statement) then
Raise_ASIS_Inappropriate_Element
("Asis.Statements.Raised_Exception");
end if;
Arg_Node := Node (Statement);
Result_Node := Sinfo.Name (Arg_Node);
if No (Result_Node) then
return Nil_Element;
else
return Node_To_Element_New (
Node => Result_Node,
Starting_Element => Statement);
end if;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Outer_Call => "Asis.Statements.Raised_Exception");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Diagnosis => "Asis.Statements.Raised_Exception");
end Raised_Exception;
-----------------------------------------------------------------------------
function Qualified_Expression (Statement : in Asis.Statement)
return Asis.Expression
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Statement);
Arg_Node : Node_Id;
begin
Check_Validity (Statement, "Asis.Statements.Qualified_Expression");
if not (Arg_Kind = A_Code_Statement) then
Raise_ASIS_Inappropriate_Element
("Asis.Statements.Raised_Exception");
end if;
Arg_Node := Node (Statement);
return Node_To_Element_New (
Node => Sinfo.Expression (Arg_Node),
Internal_Kind => A_Qualified_Expression,
Starting_Element => Statement);
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Argument => Statement,
Outer_Call => "Asis.Statements.Qualified_Expression");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Statement,
Diagnosis => "Asis.Statements.Qualified_Expression");
end Qualified_Expression;
------------------------------------------------------------------------------
-------------------------
-- Is_Dispatching_Call --
-------------------------
function Is_Dispatching_Call (Call : in Asis.Element) return Boolean is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Call);
Arg_Node : Node_Id;
begin
if not (Arg_Kind = A_Function_Call or else
Arg_Kind = A_Procedure_Call_Statement)
then
return False;
end if;
Arg_Node := Node (Call);
if not (Nkind (Arg_Node) = N_Function_Call or else
Nkind (Arg_Node) = N_Procedure_Call_Statement)
then
-- this may be possible as a result of tree rewritting, but if we
-- have rewritting, we do not have a dispatching call, so:
return False;
else
return Present (Controlling_Argument (Arg_Node));
end if;
exception
when ASIS_Failed =>
Add_Call_Information (
Argument => Call,
Outer_Call => "Asis.Statements.Is_Dispatching_Call");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Call,
Diagnosis => "Asis.Statements.Is_Dispatching_Call");
end Is_Dispatching_Call;
--------------------------------------
-- Is_Call_On_Dispatching_Operation --
--------------------------------------
function Is_Call_On_Dispatching_Operation
(Call : in Asis.Element)
return Boolean
is
Arg_Kind : Internal_Element_Kinds := Int_Kind (Call);
Called_Entity : Asis.Element;
Owning_Type : Asis.Element;
Owning_Type_Kind : Internal_Element_Kinds;
begin
-- Just the first version, should be tested more carefully!
-- Is currently implemented as a secondary query based on
-- some queries from Asis.Extensions.
-- ??? !!!
-- Still depends on partially implemented queries from
-- Asis.Extensions
if not (Arg_Kind = A_Function_Call or else
Arg_Kind = A_Procedure_Call_Statement)
then
return False;
end if;
if Arg_Kind = A_Function_Call then
Called_Entity := Corresponding_Called_Function (Call);
else
Called_Entity := Corresponding_Called_Entity (Call);
end if;
if Is_Nil (Called_Entity) or else
(not Is_Primitive_Operation (Called_Entity))
then
return False;
end if;
Owning_Type := Primary_Owner (Called_Entity);
Owning_Type := Type_Declaration_View (Owning_Type);
Owning_Type_Kind := Int_Kind (Owning_Type);
return
(Owning_Type_Kind = A_Tagged_Private_Type_Definition or else
Owning_Type_Kind = A_Private_Extension_Definition or else
Owning_Type_Kind = A_Derived_Record_Extension_Definition or else
Owning_Type_Kind = A_Tagged_Record_Type_Definition);
exception
when ASIS_Failed =>
Add_Call_Information (
Argument => Call,
Outer_Call => "Asis.Statements.Is_Call_On_Dispatching_Operation");
raise;
when others =>
Raise_ASIS_Failed (
Argument => Call,
Diagnosis => "Asis.Statements.Is_Call_On_Dispatching_Operation");
end Is_Call_On_Dispatching_Operation;
end Asis.Statements