------------------------------------------------------------------------------ -- -- -- 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 () -- 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 ()" & 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 ()" 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 "<> "; 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 ("<>"); 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 ("<>"); 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 ("<>"); 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 ("<>"); 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 ("<>"); 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 ("<>"); 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 (""); -- << -- 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 ("<>"); 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 ("<>"); 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 ("<>"); 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 ("<>"); 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 ("<>"); 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 ("<>"); 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 ("<>"); 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 ("<>"); 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 ("<>"); 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 ("<>"); 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 ("<>"); 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 ("<>"); 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 ("<>"); 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 ("<>"); 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 ("<>"); 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 ("<>"); 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 ("<>"); 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 ("<>"); 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 ("<>"); 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 ("<>"); 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;