------------------------------------------------------------------------------
-- --
-- DISPLAY_SOURCE COMPONENTS --
-- --
-- S O U R C E _ T R A V --
-- --
-- B o d y --
-- --
-- Copyright (c) 1995-2002, Free Software Foundation, Inc. --
-- --
-- Display_Source 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. Display_Source 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 GNAT; see file COPYING. If --
-- not, write to the Free Software Foundation, 59 Temple Place Suite 330, --
-- Boston, MA 02111-1307, USA. --
-- --
-- Display_Source is distributed as a part of the ASIS implementation for --
-- GNAT (ASIS-for-GNAT). --
-- --
-- The original version of Display_Source has been developed by --
-- Jean-Charles Marteau and Serge Reboul, ENSIMAG High School Graduates --
-- (Computer sciences) Grenoble, France in Sema Group Grenoble, France. --
-- --
-- Display_Source is now maintained by Ada Core Technologies Inc --
-- (http://www.gnat.com). --
------------------------------------------------------------------------------
-----------------------------------------------------------------
-- This package is part of the ASIS application display_source --
-----------------------------------------------------------------
with Ada;
with Ada.Text_IO;
with Ada.Characters.Handling; use Ada.Characters.Handling; -- ???
with Asis;
with Asis.Compilation_Units;
with Asis.Clauses;
with Asis.Declarations;
with Asis.Definitions;
with Asis.Elements;
with Asis.Expressions;
with Asis.Statements;
package body Source_Trav is
use Asis;
-- to make all the literals from Element classification hierarchy
-- directly visible
-----------------------
-- Local subprograms --
-----------------------
-- some basic tool procedures ...
function First_Element (List : Asis.Element_List) return Asis.Element;
function Is_Here (Element : Asis.Element) return Boolean;
function Count (List : Asis.Element_List) return Natural;
function First_Element (List : Asis.Element_List) return Asis.Element is
begin
return (List (List'First));
end First_Element;
function Is_Here (Element : Asis.Element) return Boolean is
begin
return (Asis.Elements.Element_Kind (Element) /= Not_An_Element);
end Is_Here;
function Count (List : Asis.Element_List) return Natural is
begin
return List'Length;
end Count;
function Is_Private_Unit (Unit : Asis.Declaration) return Boolean;
-- This function checks if Unit is declaration of a private library
-- unit (if it is, the keyword "private" should be sent in the
-- output of Display sourse.
-- !!!
-- Note, that it would make sense to merge this function with
-- sending the "private" string in the output stream
function Unit_Body_Beginning
(Unit : Asis.Declaration;
U_Kind : Asis.Declaration_Kinds)
return String;
-- forms and returns the starting part of the subprogram body declaration
-- it may be
-- "procedure "
-- or
-- "separate (<parent_unit_name>)
-- procedure "
--
-- The second parameter indicates whether "procedure" or "function" keyword
-- should be outputted.
-- This is the fix for outputting the
-- subunit having pragmas in context clause, the original code
-- outputting "separate (<parent unit name>)" & ASCII.CR is commented
-- out in Initiate_Source below
---------------------
-- Is_Private_Unit --
---------------------
function Is_Private_Unit (Unit : Asis.Declaration) return Boolean is
U_Kind : Asis.Declaration_Kinds :=
Asis.Elements.Declaration_Kind (Unit);
Encl_CU : Asis.Compilation_Unit :=
Asis.Elements.Enclosing_Compilation_Unit (Unit);
begin
return
(U_Kind = A_Package_Declaration or else
U_Kind = A_Procedure_Declaration or else
U_Kind = A_Function_Declaration or else
U_Kind = A_Generic_Procedure_Declaration or else
U_Kind = A_Generic_Function_Declaration or else
U_Kind = A_Generic_Package_Declaration) and then
Asis.Elements.Is_Equal
(Unit, Asis.Elements.Unit_Declaration (Encl_CU)) and then
Asis.Compilation_Units.Unit_Class (Encl_CU) = A_Private_Declaration;
end Is_Private_Unit;
--------------------------
-- Unit_Body_Beginning --
--------------------------
function Unit_Body_Beginning
(Unit : Asis.Declaration;
U_Kind : Asis.Declaration_Kinds)
return String
is
Encl_CU : Asis.Compilation_Unit :=
Asis.Elements.Enclosing_Compilation_Unit (Unit);
function Parent_Prefix (Full_Name : String) return String;
-- returns the name of the parent body from a full expanded Ada name
-- of a subunit
function Starting_Keyword
(U_Kind : Asis.Declaration_Kinds)
return String;
-- returns "procedure " or "function ", depending on U_Kind
-- ???!!! THE CODE IS VERY FAR FROM BEING GOOD
function Parent_Prefix (Full_Name : String) return String is
Index : Integer;
begin
if Full_Name = "" then
return "";
-- just in case
end if;
Index := Full_Name'Last;
for I in reverse Full_Name'Range loop
if Full_Name (I) = '.' then
Index := I - 1;
exit;
end if;
end loop;
return Full_Name (Full_Name'First .. Index);
end Parent_Prefix;
function Starting_Keyword (U_Kind : Asis.Declaration_Kinds) return String
is
begin
if U_Kind = A_Procedure_Body_Declaration then
return "procedure ";
elsif U_Kind = A_Package_Body_Declaration then
return "package body ";
elsif U_Kind = A_Task_Body_Declaration then
return "task body ";
elsif U_Kind = A_Protected_Body_Declaration then
return "protected body ";
elsif U_Kind = A_Function_Body_Declaration then
return "function ";
end if;
-- just to avoid GNAT warnings
return "";
end Starting_Keyword;
begin
if (Asis.Elements.Is_Equal
(Unit, Asis.Elements.Unit_Declaration (Encl_CU)))
and then
(Asis.Compilation_Units.Unit_Class (Encl_CU) = A_Separate_Body)
then
-- outputting the "separate (<parent unit name>)"
return "separate (" &
Parent_Prefix (To_String
(Asis.Compilation_Units.Unit_Full_Name (Encl_CU))) &
")" &
ASCII.CR &
Starting_Keyword (U_Kind);
else
return Starting_Keyword (U_Kind);
end if;
end Unit_Body_Beginning;
--------------------------------------------
-- --
-- Here is the pre procedure to provide --
-- to Traverse_Element to make a source --
-- display. --
-- --
--------------------------------------------
----------------------------------------------------------------
-- --
-- Pre_Source user's guide : --
-- --
-- In this function, you'll use 3 procedures : --
-- - Send (String) that will send immediatly the --
-- string passed in argument. --
-- - Push [(String, [ List_Kind, [Number of elements]])] --
-- which means : when you have passed Number of elements --
-- elements, print the String ... The List_Kind says if --
-- the program needs to print paranthesis or separator, --
-- (see the array Separator). --
-- - Indent [ (Number_Of_Space) ] , when you use this --
-- procedure after a Push, it means that you want the --
-- corresponding element(s) to have one more indentation --
-- unit. --
-- - Count (Asis.Element_List), He he, this a very basic --
-- function that returns the number of elements in a list --
-- - Is_Here (Asis.Element), another basic one that --
-- returns a boolean True : Element is realy An_Element --
-- False : Element is Not_An_Element --
-- --
-- Of course you can still use any Asis function needed, for --
-- instance to determine the number of element in a list. --
-- --
----------------------------------------------------------------
procedure Pre_Source
(Element : in Asis.Element;
Control : in out Asis.Traverse_Control;
State : in out Info_Source) is
---------------------------------------
-- --
-- Some tool procedures to make cool --
-- display of the sources. --
-- --
---------------------------------------
-------------------------------------------------------------------
-- Commit is called just before exiting of Pre_Source, if you look
-- well you'll see that the Push procedure pushes them on a temporary
-- stack (Tmp_Stack), that allows programmer to write his pushes in the
-- logical (lexical) order. Then, the commit pours the Tmp_Stack into
-- the main stack (Lexical_Stack) which reverses the order of the
-- elements.
procedure Commit;
procedure Commit is
Lex : Lexical_Node;
begin
while not Node_Stack.Is_Empty (State.Tmp_Stack) loop
Node_Stack.Pop (State.Tmp_Stack, Lex);
Node_Stack.Push (State.Lexical_Stack, Lex);
end loop;
exception
when others =>
Ada.Text_IO.Put_Line (" Exception raised in Commit");
raise;
end Commit;
-------------------------------------------------------------------
-- Indent is to be called just after having Pushed an element on the
-- lexical stack. It specifies that you want to see more spaces
-- Ada.Text_IO.Put in begining of line for the last
-- lexical node you pushed. (The parameter is optional)
procedure Indent
(Number_Of_Space : Positive := State.Default_Indentation_Element);
procedure Indent
(Number_Of_Space : Positive := State.Default_Indentation_Element)
is
Lex : A_Lexical_Node := Node_Stack.Upper (State.Tmp_Stack);
begin
Lex.Indentation := State.Current_Indentation_Reference;
Lex.Indentation_Reference :=
Lex.Indentation_Reference + Number_Of_Space;
exception
when others =>
Ada.Text_IO.Put_Line (" Exception raised in Indent");
raise;
end Indent;
-------------------------------------------------------------------
-- No_Space is used in the same way as Indent, after a Push, it says
-- that there must be no space after the last element of the list.
-- It is used by things like A.B.C A'First and so on ....
procedure No_Space;
procedure No_Space is
Lex : A_Lexical_Node := Node_Stack.Upper (State.Tmp_Stack);
begin
if Lex = null then
return;
else
Lex.No_Space := True;
end if;
exception
when others =>
Ada.Text_IO.Put_Line (" Exception raised in No_Space");
raise;
end No_Space;
-------------------------------------------------------------------
-- indicates that it is a return_list if the first line number of
-- the first element of the list is the same as the last line
-- number of the last element of the list.
-- We use it to deal with long list .... This way we display them
-- the same way than in the original source ...
procedure Check_If_Return_Separator (List : Asis.Element_List);
procedure Check_If_Return_Separator (List : Asis.Element_List) is
pragma Unreferenced (List);
Lex : A_Lexical_Node := Node_Stack.Upper (State.Tmp_Stack);
begin
if Lex = null then
return;
else
-- Lex.Return_List :=
-- Asis.Text.First_Line_Number (List (List'First)) /=
-- Asis.Text.Last_Line_Number (List (List'Last));
Lex.Return_List := False;
end if;
exception
when others =>
Ada.Text_IO.Put_Line (" Exception raised in Return_Separator");
raise;
end Check_If_Return_Separator;
-------------------------------------------------------------------
-- This function is not designed to be used a lot ...
-- In fact it is used only in A_Function_Call to deal with
-- Infixed operators ...
procedure Infix;
procedure Infix is
Lex : A_Lexical_Node := Node_Stack.Upper (State.Tmp_Stack);
begin
if Lex = null then
return;
else
Lex.Infixed_Operator := True;
end if;
exception
when others =>
Ada.Text_IO.Put_Line (" Exception raised in Infix");
raise;
end Infix;
-------------------------------------------------------------------
-- This function is only used in An_Operator_Symbol to know what to do,
-- i.e if the operator is to be sent or pushed and if the quotes have
-- to be Ada.Text_IO.Put or not ...
function Is_Infix return Boolean;
function Is_Infix return Boolean is
Lex : A_Lexical_Node := Node_Stack.Upper (State.Lexical_Stack);
begin
if Lex = null then
return False;
else
return Lex.Infixed_Operator;
end if;
exception
when others =>
Ada.Text_IO.Put_Line (" Exception raised in Is_Infix");
raise;
end Is_Infix;
-------------------------------------------------------------------
-- Push is to be used in the main procedure Pre_Source to push elements
-- in the stack to say what to do. These elements are poped by the
-- Pass_Element function.
procedure Push
(A_lexem : String := "";
A_List_Kind : List_Kinds := Not_In_A_List;
A_Number_Of_Elements : Natural := 1);
procedure Push (A_lexem : String := "";
A_List_Kind : List_Kinds := Not_In_A_List;
A_Number_Of_Elements : Natural := 1) is
Tmp_Lex : Lexical_Node :=
(Lexem => new String' (A_lexem),
List_Kind => A_List_Kind,
Number_Of_Elements => A_Number_Of_Elements,
-- The following are the default components
First_Passed => False,
Indentation => State.Current_Indentation_Reference,
Indentation_Reference => State.Current_Indentation_Reference,
No_Space => False,
Return_List => False,
Infixed_Operator => False);
begin
Node_Stack.Push (State.Tmp_Stack, Tmp_Lex);
exception
when others =>
Ada.Text_IO.Put_Line (" Exception raised in Push");
raise;
end Push;
-------------------------------------------------------------------
-- Send is the text outAda.Text_IO.Put procedure
-- The paramater Parametre_Indentation should not be set
-- when used in procedure Pre_Source ...
procedure Send
(Text : String;
Indentation_Parameter : Integer :=
State.Current_Indentation_Reference;
No_Space : Boolean := False);
procedure Send
(Text : String;
Indentation_Parameter : Integer :=
State.Current_Indentation_Reference;
No_Space : Boolean := False) is
Last : Natural := Text'First; -- it is the index of last CR found
begin
-- We don't print a final space, we'll do it after if it is
-- allowed by the no_space parameter.
if Text'Length = 0 then
return;
-- we need this for the fix for separate bodies
end if;
if Text'Last - Text'First + 1 > 0 and then
Text (Text'Last) = ' '
then
Send
(Text (Text'First .. Text'Last - 1),
Indentation_Parameter,
No_Space);
State.Last_Char_Was_Space := True;
return;
end if;
if State.Last_Char_Was_Space then
if not No_Space then
Ada.Text_IO.Put (" ");
State.Horizontal_Position := State.Horizontal_Position + 1;
end if;
State.Last_Char_Was_Space := False;
end if;
-- Sends the text on the standard outAda.Text_IO.Put
-- When a ASCII.CR is found it is replaced by a
-- Ada.Text_IO.Put_Line (which is in fact ASCII.CR & ASCII.LF),
-- moreover the indentation is added
for Index in Text'Range loop
if Text (Index) = ASCII.CR then
-- Let's print the indentation
if State.Last_Char_Was_Return then
for Space in 1 .. Indentation_Parameter loop
Ada.Text_IO.Put (" ");
end loop;
State.Horizontal_Position := State.Horizontal_Position +
Indentation_Parameter;
-- no need to reset Last_Char_Was_Return to false ...
end if;
Ada.Text_IO.Put_Line (Text (Last .. Index - 1));
Last := Index + 1;
State.Last_Char_Was_Return := True;
State.Horizontal_Position := 0;
State.Vertical_Position := State.Vertical_Position + 1;
end if;
end loop;
if Last in Text'Range then
-- Let's print the indentation
if State.Last_Char_Was_Return then
for Space in 1 .. Indentation_Parameter loop
Ada.Text_IO.Put (" ");
end loop;
State.Horizontal_Position := State.Horizontal_Position +
Indentation_Parameter;
State.Last_Char_Was_Return := False;
end if;
Ada.Text_IO.Put (Text (Last .. Text'Last));
State.Horizontal_Position := State.Horizontal_Position +
Text'Last - Last + 1;
if State.Horizontal_Position > State.Max_Line_Length then
Ada.Text_IO.New_Line;
State.Last_Char_Was_Return := True;
State.Horizontal_Position := 0;
State.Vertical_Position := State.Vertical_Position + 1;
end if;
end if;
exception
when others =>
Ada.Text_IO.Put_Line (" Exception raised in Send");
raise;
end Send;
-------------------------------------------------------------------
procedure Pass_Element;
procedure Pass_Element_1;
-- Pass_Element is called each time we process an element, it counts
-- them and displays the lexem when needed
procedure Pass_Element is
-- Processes any element of the stack with a
-- number of elements equal to zero and
-- decreases of one the first non null it finds.
-- Eventualy sets First_Passed to False and sends
-- the corresponding separator if needed ...
Up : A_Lexical_Node := Node_Stack.Upper (State.Lexical_Stack);
Trash : Lexical_Node;
begin
-- In that mode, it's not possible to handle the comments :
-- for example what difference could be done between those
-- situations :
--
-- procedure Hello -- comment
-- is begin .....
--
-- procedure Hello is
-- -- comment
-- begin
-- ...
--
if Up = null then
-- This happens when the stack is empty
return;
end if;
State.Current_Indentation_Reference := Up.Indentation_Reference;
-- If there is NO element in the list :
-- First_Passed = True and there is no point in printing
-- the separator (no remaining element)
-- First_Passed = False and there is no point in printing
-- an opening parenthesis (no element in list)
if Up.List_Kind = Is_Comma_Range_List and
Up.First_Passed
then
Send ("range <> ");
end if;
if Up.Number_Of_Elements /= 0 then
if Up.First_Passed and
Up.List_Kind /= Not_In_A_List
then
-- Let's print the separator because there is an element after
if Up.Return_List then
Send (Separator (Up.List_Kind).all & ASCII.CR);
else
Send (Separator (Up.List_Kind).all & " ");
end if;
elsif Up.List_Kind in Parenthesized_List then
-- Let's print the opening parenthesis
Send ("(");
Up.Indentation_Reference := State.Horizontal_Position + 1;
end if;
-- Now we'll see if we have to print a closing parenthesis
elsif Up.First_Passed and
Up.List_Kind in Parenthesized_List
then
-- Let's print the opening parenthesis
Send (") ");
end if;
-- OK then now we are sure we have passed the first one ...
Up.First_Passed := True;
-- Now, let's see if we have to print the after string ...
if Up.Number_Of_Elements = 0 then
-- If so we print the lexem that was designed for that purpose.
if Up.Lexem.all /= "" then
Send (Up.Lexem.all,
Up.Indentation,
Up.No_Space);
end if;
-- And we get rid of it
Node_Stack.Pop (State.Lexical_Stack, Trash);
-- Beware !! after that Up is not available !!
-- (in fact it is but only bad guys would use it ..)
Up := null;
-- as the counter was 0, we pass another one ...
Pass_Element_1;
else
Up.Number_Of_Elements := Up.Number_Of_Elements - 1;
end if;
exception
when others =>
Ada.Text_IO.Put_Line (" Exception raised in Pass_Element");
raise;
end Pass_Element;
procedure Pass_Element_1 is
begin
Pass_Element;
end Pass_Element_1;
-- The following procedures are 'user defined' they are here only
-- to make things simplier ....
function Function_Call_Operator return String;
function Function_Call_Operator return String is
Op : String := To_String (Asis.Expressions.Name_Image (Element));
begin
return Op (Op'First + 1 .. Op'Last - 1) & " ";
end Function_Call_Operator;
-- Helps displaying labels before statements ..
-- Element should be a Statement ..
-- if not, an Inapropriate_Element is raised
procedure Send_Label (Text : String);
procedure Send_Label (Text : String) is
Nb_Labels : Natural := Count (Asis.Statements.Label_Names (Element));
begin
if Nb_Labels > 0 then
Send ("<< ");
for Index in 2 .. Nb_Labels loop
Push (">>" & ASCII.CR & "<< ");
end loop;
Push (">>" & ASCII.CR & Text);
else
Send (Text);
end if;
end Send_Label;
-- Element is a global variable here .. :)
-- use the parameter Text when you need to insert a 'tagged' keyword
-- in the trait string.
function Trait_String
(Text : String := "")
return String;
function Trait_String (Text : String := "")
return String is
begin
case Asis.Elements.Trait_Kind (Element) is
when Not_A_Trait =>
-- return "<<Node Not_A_Trait>> ";
return ""; -- because i'm fed up with the component bug ...
when An_Ordinary_Trait =>
return Text;
when An_Aliased_Trait =>
return "aliased ";
when An_Access_Definition_Trait =>
return "access ";
when A_Reverse_Trait =>
return "reverse ";
when A_Private_Trait =>
return Text & "private ";
when A_Limited_Trait =>
return Text & "limited ";
when A_Limited_Private_Trait =>
return Text & "limited private ";
when An_Abstract_Trait =>
return "abstract " & Text;
when An_Abstract_Private_Trait =>
return "abstract " & Text & "private ";
when An_Abstract_Limited_Trait =>
return "abstract " & Text & "limited ";
when An_Abstract_Limited_Private_Trait =>
return "abstract " & Text & "limited private ";
end case;
end Trait_String;
-- to keep the size of some lists
L, M, N : Integer := 0;
begin
Pass_Element;
if State.Finishing_Traversal then
return;
end if;
case Asis.Elements.Element_Kind (Element) is
when Not_An_Element =>
null;
when A_Pragma =>
case Asis.Elements.Pragma_Kind (Element) is
when Not_A_Pragma =>
Ada.Text_IO.Put ("<<Node Not_A_Pragma>>");
when others =>
Send
("pragma " &
To_String (Asis.Elements.Pragma_Name_Image (Element)) &
" ");
L := Count (Asis.Elements.Pragma_Argument_Associations
(Element));
Push (";" & ASCII.CR,
Is_Comma_List,
L);
end case;
when A_Defining_Name =>
case Asis.Elements.Defining_Name_Kind (Element) is
when Not_A_Defining_Name =>
Ada.Text_IO.Put ("<<Node Not_A_Defining_Name>>");
when A_Defining_Identifier |
A_Defining_Character_Literal |
A_Defining_Enumeration_Literal =>
Send
(To_String (Asis.Declarations.Defining_Name_Image
(Element))
& " ");
when A_Defining_Operator_Symbol =>
Send
(To_String (Asis.Declarations.Defining_Name_Image
(Element))
& " ");
when A_Defining_Expanded_Name =>
Send
(To_String (Asis.Declarations.Defining_Name_Image
(Element))
& " ");
-- don't process the prefix and selector ...
Control := Asis.Abandon_Children;
end case;
when A_Declaration =>
case Asis.Elements.Declaration_Kind (Element) is
when Not_A_Declaration =>
-- An unexpected element
Ada.Text_IO.Put ("<<Node Not_A_Declaration>>");
when An_Ordinary_Type_Declaration => -- 3.2.1
Send ("type ");
if Is_Here (Asis.Declarations.Discriminant_Part
(Element))
then
Push;
end if;
Push ("is ");
Push (";" & ASCII.CR);
when A_Task_Type_Declaration => -- 3.2.1
Send ("task type ");
if Is_Here (Asis.Declarations.Discriminant_Part
(Element))
then
Push;
end if;
if Is_Here (Asis.Declarations.Type_Declaration_View
(Element))
then
Push ("is" & ASCII.CR);
Push (To_String (Asis.Declarations.Defining_Name_Image
(First_Element (Asis.Declarations.Names
(Element)))) &
";" & ASCII.CR); -- There is at least the name
else
Push (";" & ASCII.CR); -- There is at least the name
end if;
when A_Protected_Type_Declaration => -- 3.2.1
Send ("protected type ");
if Is_Here (Asis.Declarations.Discriminant_Part
(Element))
then
Push;
end if;
Push ("is" & ASCII.CR);
Push (To_String (Asis.Declarations.Defining_Name_Image
(First_Element (Asis.Declarations.Names (Element)))) &
";" & ASCII.CR);
when An_Incomplete_Type_Declaration => -- 3.2.1
Send ("type ");
if Is_Here (Asis.Declarations.Discriminant_Part
(Element))
then
Push;
end if;
Push (";" & ASCII.CR);
when A_Private_Type_Declaration =>
-- 3.2.1 -> Trait_Kinds
Send ("type ");
if Is_Here (Asis.Declarations.Discriminant_Part
(Element))
then
Push;
end if;
Push ("is "); -- The trait is writen after ....
Push (";" & ASCII.CR);
when A_Private_Extension_Declaration =>
-- 3.2.1 -> Trait_Kinds
Send ("type ");
if Is_Here (Asis.Declarations.Discriminant_Part
(Element))
then
Push;
end if;
case Asis.Elements.Trait_Kind (Element) is
when An_Abstract_Trait |
An_Abstract_Private_Trait |
An_Abstract_Limited_Trait |
An_Abstract_Limited_Private_Trait =>
Push ("is abstract new ");
when others =>
Push ("is new ");
end case;
Push (";" & ASCII.CR);
when A_Subtype_Declaration => -- 3.2.2
Send ("subtype ");
Push ("is ");
Push (";" & ASCII.CR);
when A_Variable_Declaration =>
-- 3.3.1 -> Trait_Kinds
Push (": " & Trait_String,
Is_Comma_No_Parenthesis_List,
Count (Asis.Declarations.Names (Element)));
if Is_Here (Asis.Declarations.Initialization_Expression
(Element))
then
Push (":= ");
end if;
Push (";" & ASCII.CR);
when A_Constant_Declaration =>
-- 3.3.1 -> Trait_Kinds
Push (": " & Trait_String & "constant ",
Is_Comma_No_Parenthesis_List,
Count (Asis.Declarations.Names (Element)));
if Is_Here (Asis.Declarations.Initialization_Expression
(Element))
then
Push (":= ");
end if;
Push (";" & ASCII.CR);
when A_Deferred_Constant_Declaration =>
-- 3.3.1 -> Trait_Kinds
Push (": " & Trait_String & "constant ",
Is_Comma_No_Parenthesis_List,
Count (Asis.Declarations.Names (Element)));
Push (";" & ASCII.CR);
when A_Single_Task_Declaration => -- 3.3.1
Send ("task ");
if Is_Here (Asis.Declarations.Object_Declaration_View
(Element))
then
Push ("is" & ASCII.CR);
Push
(To_String (Asis.Declarations.Defining_Name_Image
(First_Element (Asis.Declarations.Names (Element)))) &
";" & ASCII.CR);
else
Push (";" & ASCII.CR);
end if;
when A_Single_Protected_Declaration => -- 3.3.1
Send ("protected ");
Push ("is" & ASCII.CR);
Indent;
Push (To_String (Asis.Declarations.Defining_Name_Image
(First_Element (Asis.Declarations.Names (Element))))
& ";" & ASCII.CR);
when An_Integer_Number_Declaration => -- 3.3.2
Push (": constant := ",
Is_Comma_No_Parenthesis_List,
Count (Asis.Declarations.Names (Element)));
Push (";" & ASCII.CR);
when A_Real_Number_Declaration => -- 3.3.2
Push (": constant := ",
Is_Comma_No_Parenthesis_List,
Count (Asis.Declarations.Names (Element)));
Push (";" & ASCII.CR);
when An_Enumeration_Literal_Specification => -- 3.5.1
Push;
when A_Discriminant_Specification =>
-- 3.7 -> Trait_Kinds
Push (": " & Trait_String,
Is_Comma_No_Parenthesis_List,
Count (Asis.Declarations.Names (Element)));
if Is_Here (Asis.Declarations.Initialization_Expression
(Element))
then
Push (":= ");
end if;
Push;
when A_Component_Declaration => -- 3.8
Push (": ",
Is_Comma_No_Parenthesis_List,
Count (Asis.Declarations.Names (Element)));
if Is_Here (Asis.Declarations.Initialization_Expression
(Element))
then
Push (":= ");
end if;
Push (";" & ASCII.CR);
when A_Loop_Parameter_Specification =>
-- 5.5 -> Trait_Kinds
Push ("in " & Trait_String);
Push;
when A_Procedure_Declaration =>
-- 6.1 -> Trait_Kinds
if Is_Private_Unit (Element) then
Send ("private ");
end if;
Send ("procedure ");
Push;
case Asis.Elements.Trait_Kind (Element) is
when Not_A_Trait =>
Ada.Text_IO.Put
("<<Node Not_A_Trait in A_Procedure_Declaration>>");
when An_Abstract_Trait =>
Push
("is abstract;" & ASCII.CR,
Is_Semi_Colon_List,
Count (Asis.Declarations.Parameter_Profile
(Element)));
when others =>
Push
(";" & ASCII.CR,
Is_Semi_Colon_List,
Count (Asis.Declarations.Parameter_Profile
(Element)));
end case;
when A_Function_Declaration =>
-- 6.1 -> Trait_Kinds
if Is_Private_Unit (Element) then
Send ("private ");
end if;
Send ("function ");
Push ("");
Push ("return ",
Is_Semi_Colon_List,
Count (Asis.Declarations.Parameter_Profile (Element)));
case Asis.Elements.Trait_Kind (Element) is
when Not_A_Trait =>
Ada.Text_IO.Put
("<<Node Not_A_Trait in A_Procedure_Declaration>>");
when An_Abstract_Trait =>
Push ("is abstract;" & ASCII.CR);
when others =>
Push (";" & ASCII.CR);
end case;
when A_Parameter_Specification =>
-- 6.1 -> Trait_Kinds
case Asis.Elements.Mode_Kind (Element) is
when Not_A_Mode =>
Push ("<<Not_A_Mode !!!>>");
when A_Default_In_Mode =>
-- it is the only mode that can be access...
Push (": " & Trait_String,
Is_Comma_No_Parenthesis_List,
Count (Asis.Declarations.Names (Element)));
when An_In_Mode =>
Push (": in ",
Is_Comma_No_Parenthesis_List,
Count (Asis.Declarations.Names (Element)));
when An_Out_Mode =>
Push (": out ",
Is_Comma_No_Parenthesis_List,
Count (Asis.Declarations.Names (Element)));
when An_In_Out_Mode =>
Push (": in out ",
Is_Comma_No_Parenthesis_List,
Count (Asis.Declarations.Names (Element)));
end case;
if (Is_Here (Asis.Declarations.Initialization_Expression
(Element)))
then
Push (":= ");
end if;
Push;
when A_Procedure_Body_Declaration => -- 6.3
Send
(Unit_Body_Beginning
(Element,
A_Procedure_Body_Declaration));
-- Send ("procedure ");
Push ("");
Push ("is" & ASCII.CR,
Is_Semi_Colon_List,
Count (Asis.Declarations.Parameter_Profile (Element)));
Indent;
Push ("begin" & ASCII.CR,
Not_In_A_List,
Count
(Asis.Declarations.Body_Declarative_Items
(Element, True)));
Indent;
L := Count (Asis.Declarations.Body_Statements
(Element, True));
M := Count (Asis.Declarations.Body_Exception_Handlers
(Element, True));
-- Is_Name_Repeated is not implemented???
if M = 0 then
Push
("end " &
To_String (Asis.Declarations.Defining_Name_Image
(First_Element (Asis.Declarations.Names (Element)))) &
";" & ASCII.CR,
Not_In_A_List,
L);
else
Push ("exception" & ASCII.CR,
Not_In_A_List,
L);
Indent;
Push
("end " &
To_String (Asis.Declarations.Defining_Name_Image
(First_Element (Asis.Declarations.Names (Element)))) &
";" & ASCII.CR,
Not_In_A_List,
M);
end if;
Indent;
when A_Function_Body_Declaration => -- 6.3
Send (Unit_Body_Beginning
(Element, A_Function_Body_Declaration));
-- Send ("function ");
Push ("");
Push ("return ",
Is_Semi_Colon_List,
Count (Asis.Declarations.Parameter_Profile (Element)));
Push ("is" & ASCII.CR);
Indent;
Push ("begin" & ASCII.CR,
Not_In_A_List,
Count (Asis.Declarations.Body_Declarative_Items
(Element, True)));
Indent;
L := Count (Asis.Declarations.Body_Statements
(Element, True));
M := Count (Asis.Declarations.Body_Exception_Handlers
(Element, True));
-- Is_Name_Repeated is not implemented???
if M = 0 then
Push
("end " &
To_String (Asis.Declarations.Defining_Name_Image
(First_Element (Asis.Declarations.Names (Element)))) &
";" & ASCII.CR,
Not_In_A_List,
L);
else
Push ("exception" & ASCII.CR,
Not_In_A_List,
L);
Indent;
Push
("end " &
To_String (Asis.Declarations.Defining_Name_Image
(First_Element (Asis.Declarations.Names (Element)))) &
";" & ASCII.CR,
Not_In_A_List,
M);
end if;
Indent;
when A_Package_Declaration => -- 7.1
if Is_Private_Unit (Element) then
Send ("private ");
end if;
Send ("package ");
Push ("is" & ASCII.CR);
L := Count
(Asis.Declarations.Visible_Part_Declarative_Items
(Element, True));
if Asis.Declarations.Is_Private_Present (Element) then
Push ("private" & ASCII.CR,
Not_In_A_List,
L);
Indent;
Push
("end " &
To_String (Asis.Declarations.Defining_Name_Image
(First_Element (Asis.Declarations.Names (Element)))) &
";" & ASCII.CR,
Not_In_A_List,
Count
(Asis.Declarations.Private_Part_Declarative_Items
(Element, True)));
else
Push
("end " &
To_String (Asis.Declarations.Defining_Name_Image
(First_Element (Asis.Declarations.Names (Element)))) &
";" & ASCII.CR,
Not_In_A_List,
L);
end if;
Indent;
when A_Package_Body_Declaration => -- 7.2
Send (Unit_Body_Beginning
(Element,
A_Package_Body_Declaration));
-- Send ("package body ");
L := Count (Asis.Declarations.Body_Declarative_Items
(Element, True));
M := Count (Asis.Declarations.Body_Statements
(Element, True));
N := Count (Asis.Declarations.Body_Exception_Handlers
(Element, True));
declare
End_String : String := "end " &
To_String (Asis.Declarations.Defining_Name_Image
(First_Element (Asis.Declarations.Names (Element)))) &
";" & ASCII.CR;
begin
if L = 0 then
if M = 0 then
-- then N = 0 too
Push ("is" & ASCII.CR & ASCII.CR & End_String);
else
Push ("is" & ASCII.CR & "begin" & ASCII.CR);
if N = 0 then
Push (End_String, Not_In_A_List, M);
Indent;
else
Push ("exception" & ASCII.CR, Not_In_A_List, M);
Indent;
Push (End_String, Not_In_A_List, N);
Indent;
end if;
end if;
else
Push ("is" & ASCII.CR);
if M = 0 then
Push (End_String, Not_In_A_List, L);
Indent;
else
Push ("begin" & ASCII.CR, Not_In_A_List, L);
Indent;
if N = 0 then
Push (End_String, Not_In_A_List, M);
Indent;
else
Push ("exception" & ASCII.CR, Not_In_A_List, M);
Indent;
Push (End_String, Not_In_A_List, N);
Indent;
end if;
end if;
end if;
end;
when An_Object_Renaming_Declaration => -- 8.5.1
Push (": ");
Push ("renames ");
Push (";" & ASCII.CR);
when An_Exception_Renaming_Declaration => -- 8.5.2
Push (": exception renames ");
Push (";" & ASCII.CR);
when A_Package_Renaming_Declaration => -- 8.5.3
Send ("package ");
Push ("renames ");
Push (";" & ASCII.CR);
when A_Procedure_Renaming_Declaration => -- 8.5.4
Send ("procedure ");
Push;
Push ("renames ",
Is_Semi_Colon_List,
Count (Asis.Declarations.Parameter_Profile (Element)));
Push (";" & ASCII.CR);
when A_Function_Renaming_Declaration => -- 8.5.4
Send ("function ");
Push;
Push ("return ",
Is_Semi_Colon_List,
Count (Asis.Declarations.Parameter_Profile (Element)));
Push ("renames ");
Push (";" & ASCII.CR);
when A_Generic_Package_Renaming_Declaration => -- 8.5.5
Send ("generic package ");
Push ("renames ");
Push (";" & ASCII.CR);
when A_Generic_Procedure_Renaming_Declaration => -- 8.5.5
Send ("generic procedure ");
Push ("renames ");
Push (";" & ASCII.CR);
when A_Generic_Function_Renaming_Declaration => -- 8.5.5
Send ("generic function ");
Push ("renames ");
Push (";" & ASCII.CR);
when A_Task_Body_Declaration => -- 9.1
Send (Unit_Body_Beginning
(Element, A_Task_Body_Declaration));
-- Send ("task body ");
Push ("is" & ASCII.CR);
Push
("begin" & ASCII.CR,
Not_In_A_List,
Count (Asis.Declarations.Body_Declarative_Items
(Element, True)));
Indent;
L := Count (Asis.Declarations.Body_Statements
(Element, True));
M := Count (Asis.Declarations.Body_Exception_Handlers
(Element, True));
-- Is_Name_Repeated is not implemented???
if M = 0 then
Push
("end " &
To_String (Asis.Declarations.Defining_Name_Image
(First_Element (Asis.Declarations.Names (Element))))
& ";" & ASCII.CR,
Not_In_A_List,
L);
else
Push ("exception" & ASCII.CR,
Not_In_A_List,
L);
Indent;
Push
("end " &
To_String (Asis.Declarations.Defining_Name_Image
(First_Element (Asis.Declarations.Names (Element)))) &
";" & ASCII.CR,
Not_In_A_List,
M);
end if;
Indent;
when A_Protected_Body_Declaration => -- 9.4
Send (Unit_Body_Beginning
(Element, A_Protected_Body_Declaration));
-- Send ("protected body ");
Push ("is" & ASCII.CR);
Push
("end " &
To_String (Asis.Declarations.Defining_Name_Image
(First_Element (Asis.Declarations.Names (Element)))) &
";" & ASCII.CR,
Not_In_A_List,
Count (Asis.Declarations.Protected_Operation_Items
(Element, True)));
Indent;
when An_Entry_Declaration => -- 9.5.2
Send ("entry ");
L := Count (Asis.Declarations.Parameter_Profile (Element));
if L /= 0 then
Push;
if Is_Here (Asis.Declarations.Entry_Family_Definition
(Element))
then
Push ("", Is_Comma_List);
-- we say comma list in order to have the parenthesis
end if;
Push (";" & ASCII.CR,
Is_Semi_Colon_List, L);
else
if Is_Here (Asis.Declarations.Entry_Family_Definition
(Element))
then
Push;
Push (";" & ASCII.CR, Is_Comma_List);
-- we say comma list in order to have the parenthesis
else
Push (";" & ASCII.CR);
end if;
end if;
when An_Entry_Body_Declaration => -- 9.5.2
Send ("entry ");
if Is_Here (Asis.Declarations.Entry_Index_Specification
(Element))
then
Push;
Push ("", Is_Comma_List);
else
Push;
end if;
Push ("when ",
Is_Semi_Colon_List,
Count (Asis.Declarations.Parameter_Profile (Element)));
Push ("is" & ASCII.CR);
Push ("begin" & ASCII.CR,
Not_In_A_List,
Count (Asis.Declarations.Body_Declarative_Items
(Element, True)));
Push (""); -- <<<RYBIN
Indent;
L := Count (Asis.Declarations.Body_Statements (Element));
M := Count (Asis.Declarations.Body_Exception_Handlers
(Element));
if M = 0 then
Push
("end " &
To_String (Asis.Declarations.Defining_Name_Image
(First_Element (Asis.Declarations.Names (Element)))) &
";" & ASCII.CR,
Not_In_A_List,
L);
Indent;
else
Push ("exception" & ASCII.CR,
Not_In_A_List,
L);
Indent;
Push
("end " &
To_String (Asis.Declarations.Defining_Name_Image
(First_Element (Asis.Declarations.Names (Element)))) &
";" & ASCII.CR,
Not_In_A_List,
M);
Indent;
end if;
when An_Entry_Index_Specification => -- 9.5.2
Send ("for ");
Push ("in ");
Push;
when A_Procedure_Body_Stub => -- 10.1.3
Send ("procedure ");
Push;
Push
("is separate;" & ASCII.CR,
Is_Semi_Colon_List,
Count (Asis.Declarations.Parameter_Profile (Element)));
when A_Function_Body_Stub => -- 10.1.3
Send ("function ");
Push ("");
Push ("return ",
Is_Semi_Colon_List,
Count (Asis.Declarations.Parameter_Profile (Element)));
Push ("is separate;" & ASCII.CR);
when A_Package_Body_Stub => -- 10.1.3
Send ("package body ");
Push ("is separate;" & ASCII.CR);
when A_Task_Body_Stub => -- 10.1.3
Send ("task body ");
Push ("is separate;" & ASCII.CR);
when A_Protected_Body_Stub => -- 10.1.3
Send ("protected body ");
Push ("is separate;" & ASCII.CR);
when An_Exception_Declaration => -- 11.1
Push (": exception;" & ASCII.CR,
Is_Comma_No_Parenthesis_List,
Count (Asis.Declarations.Names (Element)));
when A_Choice_Parameter_Specification => -- 11.2
Push (": "); -- in exception handler ...
when A_Generic_Procedure_Declaration => -- 12.1
if Is_Private_Unit (Element) then
Send ("private" & ASCII.CR);
end if;
Send ("generic" & ASCII.CR);
Push ("procedure ",
Not_In_A_List,
Count (Asis.Declarations.Generic_Formal_Part
(Element, True)));
Indent;
Push;
Push
(";" & ASCII.CR,
Is_Semi_Colon_List,
Count (Asis.Declarations.Parameter_Profile (Element)));
when A_Generic_Function_Declaration => -- 12.1
if Is_Private_Unit (Element) then
Send ("private" & ASCII.CR);
end if;
Send ("generic" & ASCII.CR);
Push
("function ",
Not_In_A_List,
Count (Asis.Declarations.Generic_Formal_Part
(Element, True)));
Indent;
Push;
Push ("return ",
Is_Semi_Colon_List,
Count (Asis.Declarations.Parameter_Profile
(Element)));
Push (";" & ASCII.CR);
when A_Generic_Package_Declaration => -- 12.1
if Is_Private_Unit (Element) then
Send ("private" & ASCII.CR);
end if;
Send ("generic" & ASCII.CR);
Push ("package ",
Not_In_A_List,
Count (Asis.Declarations.Generic_Formal_Part
(Element, True)));
Indent;
Push ("is" & ASCII.CR);
L := Count (Asis.Declarations.Visible_Part_Declarative_Items
(Element, True));
if Asis.Declarations.Is_Private_Present (Element) then
Push ("private" & ASCII.CR,
Not_In_A_List,
L);
Indent;
Push
("end " &
To_String (Asis.Declarations.Defining_Name_Image
(First_Element (Asis.Declarations.Names (Element)))) &
";" & ASCII.CR,
Not_In_A_List,
Count (Asis.Declarations.Private_Part_Declarative_Items
(Element, True)));
else
Push ("end " &
To_String (Asis.Declarations.Defining_Name_Image
(First_Element (Asis.Declarations.Names (Element)))) &
";" & ASCII.CR,
Not_In_A_List,
L);
end if;
Indent;
when A_Package_Instantiation => -- 12.3
Send ("package ");
Push ("is new ");
Push;
Push (";" & ASCII.CR,
Is_Comma_List,
Count (Asis.Declarations.Generic_Actual_Part
(Element, False)));
when A_Procedure_Instantiation => -- 12.3
Send ("procedure ");
Push ("is new ");
Push;
Push (";" & ASCII.CR,
Is_Comma_List,
Count (Asis.Declarations.Generic_Actual_Part
(Element, False)));
when A_Function_Instantiation => -- 12.3
Send ("function ");
Push ("is new ");
Push;
Push (";" & ASCII.CR,
Is_Comma_List,
Count (Asis.Declarations.Generic_Actual_Part
(Element, False)));
when A_Formal_Object_Declaration =>
-- 12.4 -> Mode_Kinds
case Asis.Elements.Mode_Kind (Element) is
when Not_A_Mode =>
Push ("<<Not_A_Mode !!!>>");
when A_Default_In_Mode =>
-- it is the only mode that can be access...
Push (": " & Trait_String,
Is_Comma_No_Parenthesis_List,
Count (Asis.Declarations.Names (Element)));
when An_In_Mode =>
Push (": in ",
Is_Comma_No_Parenthesis_List,
Count (Asis.Declarations.Names (Element)));
when An_Out_Mode =>
Push (": out ",
Is_Comma_No_Parenthesis_List,
Count (Asis.Declarations.Names (Element)));
when An_In_Out_Mode =>
Push (": in out ",
Is_Comma_No_Parenthesis_List,
Count (Asis.Declarations.Names (Element)));
end case;
if (Is_Here (Asis.Declarations.Initialization_Expression
(Element))) then
Push (":= ");
Push (";" & ASCII.CR);
else
Push (";" & ASCII.CR);
end if;
when A_Formal_Type_Declaration => -- 12.5
Send ("type ");
if Is_Here (Asis.Declarations.Discriminant_Part
(Element))
then
Push;
end if;
Push ("is ");
Push (";" & ASCII.CR);
when A_Formal_Procedure_Declaration =>
-- 12.6 -> Default_Kinds
Send ("with procedure ");
Push;
case (Asis.Elements.Default_Kind (Element)) is
when Not_A_Default =>
Ada.Text_IO.Put ("<<Node Not_A_Default>>");
when A_Name_Default =>
Push
("is ",
Is_Semi_Colon_List,
Count (Asis.Declarations.Parameter_Profile
(Element)));
Push (";" & ASCII.CR);
when A_Box_Default =>
Push
("is <>;" & ASCII.CR,
Is_Semi_Colon_List,
Count (Asis.Declarations.Parameter_Profile
(Element)));
when A_Nil_Default =>
Push (";" & ASCII.CR,
Is_Semi_Colon_List,
Count (Asis.Declarations.Parameter_Profile
(Element)));
end case;
when A_Formal_Function_Declaration =>
-- 12.6 -> Default_Kinds
Send ("with function ");
Push;
Push ("return ",
Is_Semi_Colon_List,
Count (Asis.Declarations.Parameter_Profile (Element)));
case (Asis.Elements.Default_Kind (Element)) is
when Not_A_Default =>
Ada.Text_IO.Put ("<<Node Not_A_Default>>");
when A_Name_Default =>
Push ("is ");
Push (";" & ASCII.CR);
when A_Box_Default =>
Push ("is <>;" & ASCII.CR);
when A_Nil_Default =>
Push (";" & ASCII.CR);
end case;
when A_Formal_Package_Declaration => -- 12.7
Send ("with package ");
Push ("is new ");
Push;
Push
(";" & ASCII.CR,
Is_Comma_List,
Count (Asis.Declarations.Generic_Actual_Part
(Element, False)));
when A_Formal_Package_Declaration_With_Box => -- 12.7
Send ("with package ");
Push ("is new ");
Push ("(<>);" & ASCII.CR);
end case;
when A_Definition =>
case Asis.Elements.Definition_Kind (Element) is
when Not_A_Definition =>
-- An unexpected element
Ada.Text_IO.Put ("<<Node Not_A_Definition>>");
when A_Type_Definition =>
-- 3.2.1 -> Type_Kinds
case Asis.Elements.Type_Kind (Element) is
when Not_A_Type_Definition =>
Ada.Text_IO.Put ("<<Node Not_A_Type_Definition>>");
when A_Derived_Type_Definition =>
Send ("new ");
Push;
when A_Derived_Record_Extension_Definition =>
Send (Trait_String & "new ");
if Asis.Elements.Definition_Kind (
Asis.Definitions.Record_Definition (Element)) =
A_Null_Record_Definition then
Push ("with ");
Push;
else
Push ("with record" & ASCII.CR);
Push ("end record ");
Indent;
end if;
when An_Enumeration_Type_Definition =>
Push
("",
Is_Comma_List,
Count
(Asis.Definitions.Enumeration_Literal_Declarations
(Element)));
Check_If_Return_Separator
(Asis.Definitions.Enumeration_Literal_Declarations
(Element));
when A_Signed_Integer_Type_Definition =>
Send ("range ");
Push;
when A_Modular_Type_Definition =>
Send ("mod ");
Push;
when A_Root_Type_Definition =>
Ada.Text_IO.Put ("<<Node A_Root_Type_Definition>>");
when A_Floating_Point_Definition =>
Send ("digits ");
if Is_Here (Asis.Definitions.Real_Range_Constraint
(Element))
then
Push ("range ");
Push;
else
Push;
end if;
when An_Ordinary_Fixed_Point_Definition =>
Send ("delta ");
Push ("range ");
Push;
when A_Decimal_Fixed_Point_Definition =>
Send ("delta ");
Push ("digits ");
if Is_Here (Asis.Definitions.Real_Range_Constraint
(Element))
then
Push ("range ");
Push;
else
Push;
end if;
when An_Unconstrained_Array_Definition =>
Send ("array ");
Push
("of ",
Is_Comma_Range_List,
Count (Asis.Definitions.Index_Subtype_Definitions
(Element)));
Push;
when A_Constrained_Array_Definition =>
Send ("array ");
Push
("of ",
Is_Comma_List,
Count
(Asis.Definitions.Discrete_Subtype_Definitions
(Element)));
Push;
when A_Record_Type_Definition =>
if Asis.Elements.Definition_Kind (
Asis.Definitions.Record_Definition (Element)) =
A_Null_Record_Definition then
Send (Trait_String);
Push;
else
Send (Trait_String & "record" & ASCII.CR);
Push ("end record ");
Indent;
end if;
when A_Tagged_Record_Type_Definition =>
if Asis.Elements.Definition_Kind
(Asis.Definitions.Record_Definition (Element)) =
A_Null_Record_Definition
then
Send (Trait_String ("tagged "));
Push;
else
Send
(Trait_String ("tagged ") & "record" & ASCII.CR);
Push ("end record ");
Indent;
end if;
when An_Access_Type_Definition =>
case Asis.Elements.Access_Type_Kind (Element) is
when Not_An_Access_Type_Definition =>
Ada.Text_IO.Put
("<<Node Not_An_Access_Type_Definition>>");
when A_Pool_Specific_Access_To_Variable =>
Send ("access ");
Push;
when An_Access_To_Constant =>
Send ("access constant ");
Push;
when An_Access_To_Variable =>
Send ("access all ");
Push;
when An_Access_To_Procedure =>
Send ("access procedure ");
Push
("",
Is_Semi_Colon_List,
Count
(Asis.Definitions.
Access_To_Subprogram_Parameter_Profile
(Element)));
when An_Access_To_Protected_Procedure =>
Send ("access protected procedure ");
Push
("",
Is_Semi_Colon_List,
Count (Asis.Definitions.
Access_To_Subprogram_Parameter_Profile
(Element)));
when An_Access_To_Function =>
Send ("access function ");
Push
("return ",
Is_Semi_Colon_List,
Count (Asis.Definitions.
Access_To_Subprogram_Parameter_Profile
(Element)));
Push;
when An_Access_To_Protected_Function =>
Send ("access protected function ");
Push
("return ",
Is_Semi_Colon_List,
Count (Asis.Definitions.
Access_To_Subprogram_Parameter_Profile
(Element)));
Push;
end case;
end case;
when A_Subtype_Indication => -- 3.2.2
declare
M : Asis.Element :=
Asis.Definitions.Subtype_Constraint (Element);
begin
if Is_Here (M) then
case Asis.Elements.Constraint_Kind (M) is
when A_Range_Attribute_Reference |
A_Simple_Expression_Range =>
Push ("range ");
Push;
when others =>
Push;
Push;
end case;
else
Push;
end if;
end;
when A_Constraint =>
-- 3.2.2 -> Constraint_Kinds
case Asis.Elements.Constraint_Kind (Element) is
when Not_A_Constraint =>
Ada.Text_IO.Put ("<<Node Not_A_Constraint>>");
when A_Range_Attribute_Reference =>
-- Send ("range ");
-- No range to Ada.Text_IO.Put ...
Push;
when A_Simple_Expression_Range =>
-- Send ("range ");
-- Ada.Text_IO.Put a range here might fail...
Push (".. ");
Push;
when A_Digits_Constraint =>
Send ("digits ");
if (Asis.Elements.Constraint_Kind
(Asis.Definitions.Real_Range_Constraint
(Element))
/=
Not_A_Constraint)
then
Push ("range ");
Push;
else
Push;
end if;
when A_Delta_Constraint =>
Send ("delta ");
if (Asis.Elements.Constraint_Kind
(Asis.Definitions.Real_Range_Constraint
(Element))
/=
Not_A_Constraint)
then
Push ("range ");
Push;
else
Push;
end if;
when An_Index_Constraint =>
Push
("",
Is_Comma_List,
Count (Asis.Definitions.Discrete_Ranges
(Element)));
when A_Discriminant_Constraint =>
Push
("",
Is_Comma_List,
Count (Asis.Definitions.Discriminant_Associations
(Element, False)));
end case;
when A_Component_Definition =>
-- 3.6 -> Trait_Kinds
Send (Trait_String);
Push;
when A_Discrete_Subtype_Definition |
A_Discrete_Range =>
-- 3.6 -> Discrete_Range_Kinds
-- 3.6.1 -> Discrete_Range_Kinds
case Asis.Elements.Discrete_Range_Kind (Element) is
when Not_A_Discrete_Range =>
Ada.Text_IO.Put ("<<Node Not_A_Discrete_Range>>");
when A_Discrete_Subtype_Indication =>
declare
C : Asis.Element :=
Asis.Definitions.Subtype_Constraint (Element);
begin
if Is_Here (C) then
case Asis.Elements.Constraint_Kind (C) is
when A_Range_Attribute_Reference |
A_Simple_Expression_Range =>
Push ("range ");
when others =>
Push;
end case;
end if;
Push;
end;
when A_Discrete_Range_Attribute_Reference =>
Push;
when A_Discrete_Simple_Expression_Range =>
Push (".. ");
Push;
end case;
when An_Unknown_Discriminant_Part => -- 3.7
Send ("(<>) ");
when A_Known_Discriminant_Part => -- 3.7
Push ("",
Is_Semi_Colon_List,
Count (Asis.Definitions.Discriminants (Element)));
when A_Record_Definition => -- 3.8
Push ("",
Not_In_A_List,
Count (Asis.Definitions.Record_Components (Element)));
when A_Null_Record_Definition => -- 3.8
Send ("null record ");
when A_Null_Component => -- 3.8
Send ("null;" & ASCII.CR);
when A_Variant_Part => -- 3.8
Send ("case ");
Push ("is" & ASCII.CR);
Push ("end case;" & ASCII.CR,
Not_In_A_List,
Count (Asis.Definitions.Variants (Element, True)));
Indent;
when A_Variant => -- 3.8
Send ("when ");
Push ("=>" & ASCII.CR,
Is_Vertical_Line_List,
Count (Asis.Definitions.Variant_Choices (Element)));
Push
("",
Not_In_A_List,
Count (Asis.Definitions.Record_Components
(Element, True)));
Indent;
when An_Others_Choice =>
-- 3.8.1, 4.3.1, 4.3.3, 11.2
Send ("others ");
when A_Private_Type_Definition =>
-- 7.3 -> Trait_Kinds
Send (Trait_String);
when A_Tagged_Private_Type_Definition =>
-- 7.3 -> Trait_Kinds
Send (Trait_String ("tagged "));
when A_Private_Extension_Definition =>
-- 7.3 -> Trait_Kinds
Push ("with private ");
when A_Task_Definition | -- 9.1
A_Protected_Definition => -- 9.4
L := Count (Asis.Definitions.Private_Part_Items
(Element, True));
if L /= 0 then
Push
("private" & ASCII.CR,
Not_In_A_List,
Count (Asis.Definitions.Visible_Part_Items
(Element, True)));
Indent;
Push ("end ",
Not_In_A_List,
L);
Indent;
else
Push
("end ",
Not_In_A_List,
Count (Asis.Definitions.Visible_Part_Items
(Element, True)));
Indent;
end if;
when A_Formal_Type_Definition =>
-- 12.5 -> Formal_Type_Kinds
case Asis.Elements.Formal_Type_Kind (Element) is
when Not_A_Formal_Type_Definition =>
Ada.Text_IO.Put
("<<Node Not_A_Formal_Type_Definition>>");
when A_Formal_Private_Type_Definition =>
Send (Trait_String);
when A_Formal_Tagged_Private_Type_Definition =>
Send (Trait_String ("tagged "));
when A_Formal_Discrete_Type_Definition =>
Send ("(<>) ");
when A_Formal_Signed_Integer_Type_Definition =>
Send ("range <> ");
when A_Formal_Modular_Type_Definition =>
Send ("mod <> ");
when A_Formal_Floating_Point_Definition =>
Send ("digits <> ");
when A_Formal_Ordinary_Fixed_Point_Definition =>
Send ("delta <> ");
when A_Formal_Decimal_Fixed_Point_Definition =>
Send ("delta <> digits <> ");
when A_Formal_Derived_Type_Definition =>
case Asis.Elements.Trait_Kind (Element) is
when An_Abstract_Private_Trait =>
Send ("abstract new ");
Push ("with private ");
when An_Abstract_Trait =>
Send ("abstract new ");
Push;
when A_Private_Trait =>
Send ("new ");
Push ("with private ");
when others =>
Send ("new ");
Push;
end case;
when A_Formal_Unconstrained_Array_Definition =>
Send ("array ");
Push
("of ",
Is_Comma_Range_List,
Count (Asis.Definitions.Index_Subtype_Definitions
(Element)));
Push;
when A_Formal_Constrained_Array_Definition =>
Send ("array ");
Push
("of ",
Is_Comma_List,
Count (Asis.Definitions.
Discrete_Subtype_Definitions (Element)));
Push;
when A_Formal_Access_Type_Definition =>
case Asis.Elements.Access_Type_Kind (Element) is
when Not_An_Access_Type_Definition =>
Ada.Text_IO.Put
("<<Node Not_An_Access_Type_Definition>>");
when A_Pool_Specific_Access_To_Variable =>
Send ("access ");
Push;
when An_Access_To_Constant =>
Send ("access constant ");
Push;
when An_Access_To_Variable =>
Send ("access all ");
Push;
when An_Access_To_Procedure =>
Send ("access procedure ");
Push
("",
Is_Semi_Colon_List,
Count (Asis.Definitions.
Access_To_Subprogram_Parameter_Profile
(Element)));
when An_Access_To_Protected_Procedure =>
Send ("access protected procedure ");
Push
("",
Is_Semi_Colon_List,
Count (Asis.Definitions.
Access_To_Subprogram_Parameter_Profile
(Element)));
when An_Access_To_Function =>
Send ("access function ");
Push
("return ",
Is_Semi_Colon_List,
Count (Asis.Definitions.
Access_To_Subprogram_Parameter_Profile
(Element)));
Push;
when An_Access_To_Protected_Function =>
Send ("access protected function ");
Push
("return ",
Is_Semi_Colon_List,
Count (Asis.Definitions.
Access_To_Subprogram_Parameter_Profile
(Element)));
Push;
end case;
end case;
end case;
when An_Expression =>
case Asis.Elements.Expression_Kind (Element) is
when Not_An_Expression =>
-- An unexpected element
Ada.Text_IO.Put ("<<Node Not_An_Expression>>");
when An_Integer_Literal | -- 2.4
A_Real_Literal | -- 2.4.1
A_String_Literal => -- 2.6
Send
(To_String
(Asis.Expressions.Value_Image (Element)) & " ");
when An_Identifier |
A_Character_Literal |
An_Enumeration_Literal =>
Send
(To_String
(Asis.Expressions.Name_Image (Element)) & " ");
when An_Operator_Symbol =>
if Is_Infix then
case Asis.Elements.Operator_Kind (Element) is
when Not_An_Operator =>
Ada.Text_IO.Put ("<<Node Not_An_Operator>>");
when A_Unary_Plus_Operator |
A_Unary_Minus_Operator =>
Send (Function_Call_Operator);
when An_Abs_Operator |
A_Not_Operator =>
Send (Function_Call_Operator & " ");
when others =>
Push (Function_Call_Operator & " ");
end case;
else
Send (To_String (Asis.Expressions.Name_Image (Element)) &
" ");
end if;
when An_Explicit_Dereference => -- 4.1
Push (".all ");
No_Space;
when A_Function_Call => -- 4.1
-- If it is an operator, we print it here, so the element
-- Operator won't have to do it.
if Asis.Expressions.Is_Prefix_Call (Element) then
Push;
Push
("",
Is_Comma_List,
Count (Asis.Expressions.Function_Call_Parameters
(Element)));
else
case Asis.Elements.Operator_Kind
(Asis.Expressions.Prefix (Element)) is
when Not_An_Operator =>
Ada.Text_IO.Put ("<<Node Not_An_Operator>>");
when An_And_Operator |
An_Or_Operator |
An_Xor_Operator |
An_Equal_Operator |
A_Not_Equal_Operator |
A_Less_Than_Operator |
A_Less_Than_Or_Equal_Operator |
A_Greater_Than_Operator |
A_Greater_Than_Or_Equal_Operator |
A_Plus_Operator |
A_Minus_Operator |
An_Exponentiate_Operator |
A_Multiply_Operator |
A_Divide_Operator |
A_Mod_Operator |
A_Concatenate_Operator |
A_Rem_Operator =>
Push;
Infix;
Push;
when A_Unary_Plus_Operator |
A_Unary_Minus_Operator |
An_Abs_Operator |
A_Not_Operator =>
Push;
Infix;
Push;
end case;
end if;
when An_Indexed_Component => -- 4.1.1
Push;
Push ("",
Is_Comma_List,
Count (Asis.Expressions.Index_Expressions (Element)));
when A_Slice => -- 4.1.2
Push ("(");
Push (") ");
when A_Selected_Component => -- 4.1.3
Push (".");
No_Space;
Push;
when An_Attribute_Reference =>
-- 4.1.4 -> Attribute_Kinds
case Asis.Elements.Attribute_Kind (Element) is
when Not_An_Attribute =>
Ada.Text_IO.Put ("<<Node Not_An_Attribute>>");
when A_First_Attribute |
A_Last_Attribute |
A_Length_Attribute |
A_Range_Attribute |
An_Implementation_Defined_Attribute |
An_Unknown_Attribute =>
Push ("'");
No_Space;
Push;
Push
("",
Is_Comma_List,
Count
(Asis.Expressions.
Attribute_Designator_Expressions (Element)));
when others =>
Push ("'");
No_Space;
Push;
end case;
when A_Record_Aggregate => -- 4.3
if Count (Asis.Expressions.Record_Component_Associations
(Element, False)) = 0
then
Send ("(null record)");
else
Push
("",
Is_Comma_List,
Count (Asis.Expressions.Record_Component_Associations
(Element, False)));
end if;
when An_Extension_Aggregate => -- 4.3
if Count (Asis.Expressions.Record_Component_Associations
(Element, False)) = 0
then
Send ("(");
Push ("with null record)");
else
Send ("(");
Push ("with ");
Push
(")",
Is_Comma_No_Parenthesis_List,
Count (Asis.Expressions.Record_Component_Associations
(Element, False)));
end if;
when A_Positional_Array_Aggregate |
A_Named_Array_Aggregate =>
-- 4.3 -- corrected in ASIS-GNAT
-- 4.3 -- corrected in ASIS-GNAT
Push
("",
Is_Comma_List,
Count (Asis.Expressions.Array_Component_Associations
(Element)));
when An_And_Then_Short_Circuit => -- 4.4
Push ("and then ");
Push;
when An_Or_Else_Short_Circuit => -- 4.4
Push ("or else ");
Push;
when An_In_Range_Membership_Test => -- 4.4
Push ("in ");
Push;
when A_Not_In_Range_Membership_Test => -- 4.4
Push ("not in ");
Push;
when An_In_Type_Membership_Test => -- 4.4
Push ("in ");
Push;
when A_Not_In_Type_Membership_Test => -- 4.4
Push ("not in ");
Push;
when A_Null_Literal => -- 4.4
Send ("null ");
when A_Parenthesized_Expression => -- 4.4
Send ("(");
Push (") ");
when A_Type_Conversion => -- 4.6
Push ("(");
Push (") ");
when A_Qualified_Expression => -- 4.7
Push ("'");
No_Space;
Push;
when An_Allocation_From_Subtype => -- 4.8
Send ("new ");
Push;
when An_Allocation_From_Qualified_Expression => -- 4.8
Send ("new ");
Push;
end case;
when An_Association =>
case Asis.Elements.Association_Kind (Element) is
when Not_An_Association =>
-- An unexpected element
Ada.Text_IO.Put ("<<Node Not_An_Association>>");
when A_Discriminant_Association => -- 3.7.1
L := Count (Asis.Expressions.Discriminant_Selector_Names
(Element));
if L /= 0 then
Push ("=> ",
Is_Vertical_Line_List,
L);
end if;
Push;
when A_Record_Component_Association => -- 4.3.1
L := Count (Asis.Expressions.Record_Component_Choices
(Element));
if L /= 0 then
Push ("=> ",
Is_Vertical_Line_List,
L);
end if;
Push;
when An_Array_Component_Association => -- 4.3.3
L := Count (Asis.Expressions.Array_Component_Choices
(Element));
if L /= 0 then
Push ("=> ",
Is_Vertical_Line_List,
L);
end if;
Push;
when A_Parameter_Association | -- 6.4
A_Pragma_Argument_Association | -- 2.8
A_Generic_Association => -- 12.3
if Is_Here (Asis.Expressions.Formal_Parameter
(Element))
then
Push ("=> ");
end if;
Push;
end case;
when A_Statement =>
case Asis.Elements.Statement_Kind (Element) is
when Not_A_Statement =>
-- An unexpected element
Ada.Text_IO.Put ("<<Node Not_A_Statement>>");
when A_Null_Statement => -- 5.1
Send_Label ("null;" & ASCII.CR);
when An_Assignment_Statement => -- 5.2
Send_Label ("");
Push (":= ");
Push (";" & ASCII.CR);
when An_If_Statement => -- 5.3
Send_Label ("");
Push ("end if;" & ASCII.CR,
Not_In_A_List,
Count (Asis.Statements.Statement_Paths (Element)));
when A_Case_Statement => -- 5.4
Send_Label ("case ");
Push ("is" & ASCII.CR);
Push ("end case;" & ASCII.CR,
Not_In_A_List,
Count (Asis.Statements.Statement_Paths (Element)));
Indent;
when A_Loop_Statement => -- 5.55
if Is_Here (Asis.Statements.Statement_Identifier
(Element))
then
Send_Label ("");
Push (":" & ASCII.CR & "loop" & ASCII.CR);
No_Space;
Push
("end loop " &
To_String (Asis.Declarations.Defining_Name_Image
(Asis.Statements.Statement_Identifier (Element))) &
";" & ASCII.CR,
Not_In_A_List,
Count (Asis.Statements.Loop_Statements
(Element, True)));
Indent;
else
Send_Label ("loop" & ASCII.CR);
Push
("end loop;" & ASCII.CR,
Not_In_A_List,
Count (Asis.Statements.Loop_Statements
(Element, True)));
Indent;
end if;
when A_While_Loop_Statement => -- 5.5
if Is_Here (Asis.Statements.Statement_Identifier
(Element))
then
Send_Label ("");
Push (":" & ASCII.CR & "while ");
No_Space;
Push ("loop" & ASCII.CR);
Push
("end loop " &
To_String (Asis.Declarations.Defining_Name_Image
(Asis.Statements.Statement_Identifier (Element))) &
";" & ASCII.CR,
Not_In_A_List,
Count (Asis.Statements.Loop_Statements
(Element, True)));
Indent;
else
Send_Label ("while ");
Push ("loop" & ASCII.CR);
Push
("end loop;" & ASCII.CR,
Not_In_A_List,
Count (Asis.Statements.Loop_Statements
(Element, True)));
Indent;
end if;
when A_For_Loop_Statement => -- 5.5
if Is_Here (Asis.Statements.Statement_Identifier
(Element))
then
Send_Label ("");
Push (":" & ASCII.CR & "for ");
No_Space;
Push ("loop" & ASCII.CR);
Push
("end loop " &
To_String (Asis.Declarations.Defining_Name_Image
(Asis.Statements.Statement_Identifier (Element))) &
";" & ASCII.CR,
Not_In_A_List,
Count (Asis.Statements.Loop_Statements
(Element, True)));
Indent;
else
Send_Label ("for ");
Push ("loop" & ASCII.CR);
Push
("end loop;" & ASCII.CR,
Not_In_A_List,
Count (Asis.Statements.Loop_Statements
(Element, True)));
Indent;
end if;
when A_Block_Statement => -- 5.6
if Is_Here (Asis.Statements.Statement_Identifier
(Element))
then
Send_Label ("");
if Asis.Statements.Is_Declare_Block (Element) then
Push (":" & ASCII.CR & "declare" & ASCII.CR);
No_Space;
Push
("begin" & ASCII.CR,
Not_In_A_List,
Count (Asis.Statements.Block_Declarative_Items
(Element, True)));
Indent;
else
Push (":" & ASCII.CR & "begin" & ASCII.CR);
No_Space;
end if;
else
if Asis.Statements.Is_Declare_Block (Element) then
Send_Label ("declare" & ASCII.CR);
Push
("begin" & ASCII.CR,
Not_In_A_List,
Count (Asis.Statements.Block_Declarative_Items
(Element, True)));
Indent;
else
Send_Label ("begin" & ASCII.CR);
end if;
end if;
if (Count (Asis.Statements.Block_Exception_Handlers
(Element, True)) /= 0)
then
Push
("exception" & ASCII.CR,
Not_In_A_List,
Count (Asis.Statements.Block_Statements
(Element, True)));
Indent;
if (Is_Here (Asis.Statements.Statement_Identifier
(Element)))
then
Push
("end "
& To_String
(Asis.Declarations.Defining_Name_Image (
Asis.Statements.Statement_Identifier
(Element)))
& ";" & ASCII.CR,
Not_In_A_List,
Count (Asis.Statements.Block_Exception_Handlers
(Element, True)));
else
Push
("end;" & ASCII.CR,
Not_In_A_List,
Count (Asis.Statements.Block_Exception_Handlers
(Element, True)));
end if;
Indent;
else
if (Is_Here (Asis.Statements.Statement_Identifier
(Element)))
then
Push
("end "
& To_String
(Asis.Declarations.Defining_Name_Image (
Asis.Statements.Statement_Identifier
(Element)))
& ";" & ASCII.CR,
Not_In_A_List,
Count (Asis.Statements.Block_Statements
(Element, True)));
else
Push
("end;" & ASCII.CR,
Not_In_A_List,
Count (Asis.Statements.Block_Statements
(Element, True)));
end if;
Indent;
end if;
when An_Exit_Statement => -- 5.7
if Is_Here (Asis.Statements.Exit_Loop_Name
(Element))
then
Send_Label ("exit ");
if Is_Here (Asis.Statements.Exit_Condition
(Element))
then
Push ("when ");
end if;
Push (";" & ASCII.CR);
else
if Is_Here (Asis.Statements.Exit_Condition
(Element))
then
Send_Label ("exit when ");
Push (";" & ASCII.CR);
else
Send_Label ("exit;" & ASCII.CR);
end if;
end if;
when A_Goto_Statement => -- 5.8
Send_Label ("goto ");
Push (";" & ASCII.CR);
when A_Procedure_Call_Statement | -- 6.4
An_Entry_Call_Statement => -- 9.5.3
Send_Label ("");
Push;
Push
(";" & ASCII.CR,
Is_Comma_List,
Count (Asis.Statements.Call_Statement_Parameters
(Element, False)));
when A_Return_Statement => -- 6.5
if Is_Here (Asis.Statements.Return_Expression
(Element))
then
Send_Label ("return ");
Push (";" & ASCII.CR);
else
Send_Label ("return;" & ASCII.CR);
end if;
when An_Accept_Statement => -- 9.5.2
Send_Label ("accept ");
if Is_Here (Asis.Statements.Accept_Entry_Index
(Element))
then
Push ("(");
Push (") ");
else
Push;
end if;
L := Count (Asis.Statements.Accept_Body_Statements
(Element, True));
M := Count (Asis.Statements.Accept_Body_Exception_Handlers
(Element, True));
if L = 0 then
-- if L = 0 then M = 0 too ..
Push
(";" & ASCII.CR,
Is_Semi_Colon_List,
-- Is_Comma_List,
Count (Asis.Statements.Accept_Parameters (Element)));
else
Push
("do" & ASCII.CR,
Is_Semi_Colon_List,
-- Is_Comma_List,
Count (Asis.Statements.Accept_Parameters (Element)));
if M = 0 then
Push
("end " &
To_String (Asis.Expressions.Name_Image
(Asis.Statements.Accept_Entry_Direct_Name
(Element))) &
";" & ASCII.CR,
Not_In_A_List,
L);
Indent;
else
Push ("exception" & ASCII.CR,
Not_In_A_List,
L);
Indent;
Push
("end " &
-- Asis.Declarations.Defining_Name_Image
To_String (Asis.Expressions.Name_Image
(Asis.Statements.Accept_Entry_Direct_Name
(Element))) &
";" & ASCII.CR,
Not_In_A_List,
M);
Indent;
end if;
end if;
when A_Requeue_Statement => -- 9.5.4
Send_Label ("requeue ");
Push (";" & ASCII.CR);
when A_Requeue_Statement_With_Abort => -- 9.5.4
Send_Label ("requeue ");
Push ("with abort;" & ASCII.CR);
when A_Delay_Until_Statement => -- 9.6
Send_Label ("delay until ");
Push (";" & ASCII.CR);
when A_Delay_Relative_Statement => -- 9.6
Send_Label ("delay ");
Push (";" & ASCII.CR);
when A_Terminate_Alternative_Statement => -- 9.7.1
Send_Label ("terminate;" & ASCII.CR);
when A_Selective_Accept_Statement | -- 9.7.2
A_Conditional_Entry_Call_Statement => -- 9.7.3
Send_Label ("select" & ASCII.CR);
Push ("end select;" & ASCII.CR,
Not_In_A_List,
Count (Asis.Statements.Statement_Paths (Element)));
Indent;
when A_Timed_Entry_Call_Statement | -- 9.7.3
An_Asynchronous_Select_Statement => -- 9.7.4
Send_Label ("select" & ASCII.CR);
Push;
Push ("end select;" & ASCII.CR);
when An_Abort_Statement => -- 9.8
Send_Label ("abort ");
Push (";" & ASCII.CR,
Is_Comma_No_Parenthesis_List,
Count (Asis.Statements.Aborted_Tasks (Element)));
when A_Raise_Statement => -- 11.3
if Is_Here (Asis.Statements.Raised_Exception
(Element))
then
Send_Label ("raise ");
Push (";" & ASCII.CR);
else
Send_Label ("raise;" & ASCII.CR);
end if;
when A_Code_Statement => -- 13.8
Push (";" & ASCII.CR);
end case;
when A_Path =>
case Asis.Elements.Path_Kind (Element) is
when Not_A_Path => -- An unexpected element
Ada.Text_IO.Put ("<<Node Not_A_Path>>");
when An_If_Path => -- 5.3:
Send ("if ");
Push (ASCII.CR & "then" & ASCII.CR);
Push
("",
Not_In_A_List,
Count (Asis.Statements.Sequence_Of_Statements
(Element, True)));
Indent;
when An_Elsif_Path => -- 5.3:
Send ("elsif ");
Push (ASCII.CR & "then" & ASCII.CR);
Push
("",
Not_In_A_List,
Count (Asis.Statements.Sequence_Of_Statements
(Element, True)));
Indent;
when An_Else_Path => -- 5.3, 9.7.1, 9.7.3:
Send ("else" & ASCII.CR);
Push
("",
Not_In_A_List,
Count (Asis.Statements.Sequence_Of_Statements
(Element, True)));
Indent;
when A_Case_Path => -- 5.4:
Send ("when ");
Push
("=>" & ASCII.CR,
Is_Vertical_Line_List,
Count (Asis.Statements.Case_Statement_Alternative_Choices
(Element)));
Indent (5);
Check_If_Return_Separator
(Asis.Statements.Case_Statement_Alternative_Choices
(Element));
Push
("",
Not_In_A_List,
Count (Asis.Statements.Sequence_Of_Statements
(Element, True)));
Indent;
when A_Select_Path => -- 9.7.1:
if Is_Here (Asis.Statements.Guard (Element)) then
Send ("when ");
Push ("=>" & ASCII.CR);
-- Push;
-- Indent;
end if;
Push
("",
Not_In_A_List,
Count (Asis.Statements.Sequence_Of_Statements
(Element, True)));
Indent;
when An_Or_Path => -- 9.7.1:
Send ("or" & ASCII.CR);
if Is_Here (Asis.Statements.Guard (Element)) then
Send ("when ");
Push ("=>" & ASCII.CR);
end if;
Push
("",
Not_In_A_List,
Count (Asis.Statements.Sequence_Of_Statements
(Element, True)));
Indent;
when A_Then_Abort_Path => -- 9.7.4
Send ("then abort" & ASCII.CR);
Push
("",
Not_In_A_List,
Count (Asis.Statements.Sequence_Of_Statements
(Element, True)));
Indent;
end case;
when A_Clause =>
case Asis.Elements.Clause_Kind (Element) is
when Not_A_Clause => -- An unexpected element
Ada.Text_IO.Put ("<<Node Not_A_Clause>>");
when A_Use_Package_Clause => -- 8.4
Send ("use ");
Push (";" & ASCII.CR,
Is_Comma_No_Parenthesis_List,
Count (Asis.Clauses.Clause_Names (Element)));
when A_Use_Type_Clause => -- 8.4
Send ("use type ");
Push (";" & ASCII.CR,
Is_Comma_No_Parenthesis_List,
Count (Asis.Clauses.Clause_Names (Element)));
when A_With_Clause => -- 10.1.2
Send ("with ");
Push
(";" & ASCII.CR,
Is_Comma_No_Parenthesis_List,
Count (Asis.Clauses.Clause_Names (Element)));
when A_Representation_Clause =>
-- 13.1 -> Representation_Clause_Kinds
case Asis.Elements.Representation_Clause_Kind (Element) is
when Not_A_Representation_Clause =>
-- An unexpected element
Ada.Text_IO.Put
("<<Node Not_A_Representation_Clause>>");
when An_Attribute_Definition_Clause => -- 13.3
Send ("for ");
Push ("use ");
Push (";" & ASCII.CR);
when An_Enumeration_Representation_Clause => -- 13.4
Send ("for ");
Push ("use ");
Push (";" & ASCII.CR);
when A_Record_Representation_Clause => -- 13.5.1
Send ("for ");
Push ("use record" & ASCII.CR);
Push
("end record;" & ASCII.CR,
Not_In_A_List,
Count (Asis.Clauses.Component_Clauses
(Element, True)));
Indent;
when An_At_Clause => -- J.7
Send ("for ");
Push ("use at ");
Push (";" & ASCII.CR);
end case;
when A_Component_Clause => -- 13.5.1
Push ("at ");
Push ("range ");
Push (";" & ASCII.CR);
end case;
when An_Exception_Handler =>
Send ("when ");
if Is_Here (Asis.Statements.Choice_Parameter_Specification
(Element))
then
Push;
end if;
Push ("=>" & ASCII.CR,
Is_Vertical_Line_List,
Count (Asis.Statements.Exception_Choices (Element)));
Push ("",
Not_In_A_List,
Count (Asis.Statements.Handler_Statements (Element, True)));
Indent;
end case;
-- pours the Tmp_Stack in the Lexical_Stack
-- and reverses the order of the pushed elements.
Commit;
end Pre_Source;
-- 3 procedures that must be in the package.
procedure Initiate_Source
(Unit : in Asis.Compilation_Unit;
Name : in String;
Control : in out Asis.Traverse_Control;
State : in out Info_Source) is
begin
pragma Unreferenced (Unit);
pragma Unreferenced (Name);
pragma Unreferenced (Control);
pragma Unreferenced (State);
-- case Asis.Compilation_Units.Unit_Kind (Unit) is
-- when A_Procedure_Body_Subunit |
-- A_Function_Body_Subunit |
-- A_Package_Body_Subunit |
-- A_Task_Body_Subunit |
-- A_Protected_Body_Subunit
-- =>
-- declare
-- I : Natural := 0;
-- begin
-- for Index in Name'First .. Name'Last - 4
-- loop
-- if Name (Index) = '.'
-- then
-- I := Index;
-- end if;
-- end loop;
-- if I = 0
-- then
-- Ada.Text_IO.Put_Line ("Subunit has no complex name.");
-- return;
-- else
--
-- Ada.Text_IO.New_Line;
-- Ada.Text_IO.Put_line ("separate (" &
-- Name (Name'First .. I - 1) &
-- ")");
-- end if;
-- end;
-- when others =>
-- null;
-- end case;
null;
-- !!???? REQUIRES REVISING
end Initiate_Source;
procedure Terminate_Source
(Control : in out Asis.Traverse_Control;
State : in out Info_Source) is
begin
State.Finishing_Traversal := True;
-- normaly there remain only one node on stack ....
while not Node_Stack.Is_Empty (State.Lexical_Stack)
loop
Pre_Source (Asis.Nil_Element, Control, State);
end loop;
end Terminate_Source;
procedure Post_Source
(Element : in Asis.Element;
Control : in out Asis.Traverse_Control;
State : in out Info_Source) is
begin
pragma Unreferenced (Element);
pragma Unreferenced (Control);
pragma Unreferenced (State);
null;
end Post_Source;
end Source_Trav;
syntax highlighted by Code2HTML, v. 0.9.1