------------------------------------------------------------------------------ -- -- -- DISPLAY_SOURCE COMPONENTS -- -- -- -- N O D 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.Characters.Handling; use Ada.Characters.Handling; with Text_IO; use Text_IO; with Asis.Elements; with Asis.Text; with Asis.Compilation_Units; with Asis.Declarations; with Asis.Expressions; with Global_Info; use Global_Info; package body Node_Trav is use Asis; -- to make all the literals from Element classification hierarchy -- directly visible ------------------------------------------- -- -- -- Here are the 2 procedures that are -- -- called in pre_procedure when we are -- -- in test_control mode. -- -- -- ------------------------------------------- procedure Pre_Test_Control (Element : in Asis.Element; Control : in out Asis.Traverse_Control; State : in out Info_Node) is begin pragma Unreferenced (State); case Asis.Elements.Element_Kind (Element) is when A_Statement => case Asis.Elements.Statement_Kind (Element) is when A_Return_Statement | A_While_Loop_Statement => -- to check if children are left too .. Control := Asis.Abandon_Siblings; when A_For_Loop_Statement => Control := Asis.Abandon_Children; when A_Raise_Statement => Control := Asis.Terminate_Immediately; when others => null; end case; when others => null; end case; if Asis."/=" (Control, Asis.Continue) then Put_Line ("Pre Control : " & Asis.Traverse_Control'Image (Control)); end if; end Pre_Test_Control; procedure Post_Test_Control (Element : in Asis.Element; Control : in out Asis.Traverse_Control; State : in out Info_Node) is begin pragma Unreferenced (State); case Asis.Elements.Element_Kind (Element) is when A_Statement => case Asis.Elements.Statement_Kind (Element) is when A_Return_Statement | A_While_Loop_Statement => Put_Line ("We shouldn't be in post A_Return_Statement "& "or A_While_Loop_Statement"); when A_For_Loop_Statement => Put_Line ("We shouldn't be in post A_For_Loop_Statement"); when A_Raise_Statement => Put_Line ("We shouldn't be in post A_Raise_Statement"); when others => null; end case; when A_Path => case Asis.Elements.Path_Kind (Element) is when An_Elsif_Path => Control := Asis.Abandon_Siblings; when An_Else_Path => Control := Asis.Abandon_Children; when A_Case_Path => Control := Asis.Terminate_Immediately; when others => null; end case; when others => null; end case; if Asis."/=" (Control, Asis.Continue) then Put_Line ("Post Control : " & Asis.Traverse_Control'Image (Control)); end if; end Post_Test_Control; -------------------------------------------- -- -- -- Here is the pre procedure to provide -- -- to Traverse_Element to make a node -- -- display. -- -- -- -------------------------------------------- procedure Pre_Procedure (Element : in Asis.Element; Control : in out Asis.Traverse_Control; State : in out Info_Node) is function Indentation return String; function Indentation return String is Res : String (1 .. 2 * State.Indentation) := (others => '-'); begin if Res'Length > 0 then Res (Res'Last) := '>'; end if; return Res; end Indentation; begin if The_Mode = Node_And_Lines then while Asis.Text.First_Line_Number (Element) > State.Last_Commented_Line loop State.Last_Commented_Line := State.Last_Commented_Line + 1; declare List : Asis.Text.Line_List := Asis.Text.Lines (Element, State.Last_Commented_Line, State.Last_Commented_Line); begin if List'Last - List'First + 1 > 0 then declare Comment : String := To_String (Asis.Text.Comment_Image (List (List'First))); begin if Comment'Length /= 0 then Put_Line (Comment); end if; end; end if; end; end loop; end if; Put_Line (Indentation & Element_Kinds'Image (Asis.Elements.Element_Kind (Element))); case Asis.Elements.Element_Kind (Element) is when A_Pragma => -- Asis.Elements Put_Line (Indentation & " " & Pragma_Kinds'Image (Asis.Elements.Pragma_Kind (Element)) & " ... " & To_String (Asis.Elements.Pragma_Name_Image (Element))); when A_Defining_Name => -- Asis.Declarations Put_Line (Indentation & " " & Defining_Name_Kinds'Image (Asis.Elements.Defining_Name_Kind (Element)) & " ... " & (To_String (Asis.Declarations.Defining_Name_Image (Element)))); case Asis.Elements.Defining_Name_Kind (Element) is when A_Defining_Operator_Symbol => Put_Line (Indentation & " " & Operator_Kinds'Image (Asis.Elements.Operator_Kind (Element))); when others => null; end case; when A_Declaration => -- Asis.Declarations Put_Line (Indentation & " " & Declaration_Kinds'Image (Asis.Elements.Declaration_Kind (Element))); case Asis.Elements.Declaration_Kind (Element) is when A_Private_Type_Declaration | A_Private_Extension_Declaration | A_Variable_Declaration | A_Constant_Declaration | A_Deferred_Constant_Declaration | A_Discriminant_Specification | A_Loop_Parameter_Specification | A_Procedure_Declaration | A_Function_Declaration | A_Parameter_Specification => Put_Line (Indentation & " " & Trait_Kinds'Image (Asis.Elements.Trait_Kind (Element))); when A_Formal_Function_Declaration | A_Formal_Procedure_Declaration => Put_Line (Indentation & " " & Subprogram_Default_Kinds'Image (Asis.Elements.Default_Kind (Element))); when others => null; end case; case Asis.Elements.Declaration_Kind (Element) is when A_Parameter_Specification | A_Formal_Object_Declaration => Put_Line (Indentation & " " & Mode_Kinds'Image (Asis.Elements.Mode_Kind (Element))); when others => null; end case; when A_Definition => -- Asis.Definitions Put_Line (Indentation & " " & Definition_Kinds'Image (Asis.Elements.Definition_Kind (Element))); case Asis.Elements.Definition_Kind (Element) is when A_Type_Definition => Put_Line (Indentation & " " & Type_Kinds'Image (Asis.Elements.Type_Kind (Element))); case Asis.Elements.Type_Kind (Element) is when An_Access_Type_Definition => Put_Line (Indentation & " " & Access_Type_Kinds'Image (Asis.Elements.Access_Type_Kind (Element))); when A_Derived_Type_Definition | A_Derived_Record_Extension_Definition | A_Record_Type_Definition | A_Tagged_Record_Type_Definition => Put_Line (Indentation & " " & Trait_Kinds'Image (Asis.Elements.Trait_Kind (Element))); when others => null; end case; when A_Constraint => Put_Line (Indentation & " " & Constraint_Kinds'Image (Asis.Elements.Constraint_Kind (Element))); when A_Formal_Type_Definition => Put_Line (Indentation & " " & Formal_Type_Kinds'Image (Asis.Elements.Formal_Type_Kind (Element))); case Asis.Elements.Formal_Type_Kind (Element) is when A_Formal_Access_Type_Definition => Put_Line (Indentation & " " & Access_Type_Kinds'Image (Asis.Elements.Access_Type_Kind (Element))); when A_Formal_Private_Type_Definition | A_Formal_Tagged_Private_Type_Definition | A_Formal_Derived_Type_Definition => Put_Line (Indentation & " " & Trait_Kinds'Image (Asis.Elements.Trait_Kind (Element))); when others => null; end case; when A_Discrete_Subtype_Definition | A_Discrete_Range => Put_Line (Indentation & " " & Discrete_Range_Kinds'Image (Asis.Elements.Discrete_Range_Kind (Element))); when A_Component_Definition | A_Private_Type_Definition | A_Tagged_Private_Type_Definition | A_Private_Extension_Definition => Put_Line (Indentation & " " & Trait_Kinds'Image (Asis.Elements.Trait_Kind (Element))); when others => null; end case; when An_Expression => -- Asis.Expressions case Asis.Elements.Expression_Kind (Element) is when An_Attribute_Reference => Put (Indentation & " " & Expression_Kinds'Image (Asis.Elements.Expression_Kind (Element))); Put_Line (" ... " & Attribute_Kinds'Image (Asis.Elements.Attribute_Kind (Element))); when An_Identifier | An_Operator_Symbol | A_Character_Literal | An_Enumeration_Literal => Put (Indentation & " " & Expression_Kinds'Image (Asis.Elements.Expression_Kind (Element))); Put_Line (" ... " & To_String (Asis.Expressions.Name_Image (Element))); when An_Integer_Literal | A_Real_Literal | A_String_Literal => Put (Indentation & " " & Expression_Kinds'Image (Asis.Elements.Expression_Kind (Element))); Put_Line (" ... " & To_String (Asis.Expressions.Value_Image (Element))); when A_Function_Call => Put (Indentation & " " & Expression_Kinds'Image (Asis.Elements.Expression_Kind (Element))); if Asis.Expressions.Is_Prefix_Call (Element) then Put_Line (" ... Prefixed"); else Put_Line (" ... Infixed"); end if; when others => Put_Line (Indentation & " " & Expression_Kinds'Image (Asis.Elements.Expression_Kind (Element))); end case; when An_Association => -- Asis.Expressions Put_Line (Indentation & " " & Association_Kinds'Image (Asis.Elements.Association_Kind (Element))); when A_Statement => -- Asis.Statements Put_Line (Indentation & " " & Statement_Kinds'Image (Asis.Elements.Statement_Kind (Element))); when A_Path => -- Asis.Statements Put_Line (Indentation & " " & Path_Kinds'Image (Asis.Elements.Path_Kind (Element))); when A_Clause => -- Asis.Clauses Put_Line (Indentation & " " & Clause_Kinds'Image (Asis.Elements.Clause_Kind (Element))); case Asis.Elements.Clause_Kind (Element) is when A_Representation_Clause => Put_Line (Indentation & " " & Representation_Clause_Kinds'Image (Asis.Elements.Representation_Clause_Kind (Element))); when others => null; end case; when others => null; end case; if The_Mode = Node_And_Lines then Put (Indentation & " From line" & Asis.Text.Line_Number'Image (Asis.Text.First_Line_Number (Element)) & " to line" & Asis.Text.Line_Number'Image (Asis.Text.Last_Line_Number (Element))); declare The_Span : Asis.Text.Span := Asis.Text.Element_Span (Element); begin Put (" Span : (" & Asis.Text.Line_Number'Image (The_Span.First_Line) & "," & Asis.Text.Character_Position'Image (The_Span.First_Column) & "), (" & Asis.Text.Line_Number'Image (The_Span.Last_Line) & "," & Asis.Text.Character_Position'Image (The_Span.Last_Column) & ")"); end; declare List : Asis.Text.Line_List := Asis.Text.Lines (Element); N : Natural := List'Last - List'First + 1; begin Put (" (" & Asis.Text.Line_Number'Image (N) & " lines of lengths"); for I in List'First .. List'Last loop Put ("," & Asis.Text.Character_Position'Image (Asis.Text.Length (List (I)))); end loop; Put_Line (")"); end; end if; if The_Mode = Test_Control then Pre_Test_Control (Element, Control, State); end if; State.Indentation := State.Indentation + 1; end Pre_Procedure; procedure Post_Procedure (Element : in Asis.Element; Control : in out Asis.Traverse_Control; State : in out Info_Node) is begin State.Indentation := State.Indentation - 1; if The_Mode = Test_Control then Post_Test_Control (Element, Control, State); end if; end Post_Procedure; procedure Initiate_Node (Unit : in Asis.Compilation_Unit; Control : in out Asis.Traverse_Control; State : in out Info_Node) is begin pragma Unreferenced (Control); Put_Line ("Unit Kind : " & Asis.Unit_Kinds'Image (Asis.Compilation_Units.Unit_Kind (Unit))); State.Indentation := 0; end Initiate_Node; procedure Terminate_Node (Control : in out Asis.Traverse_Control; State : in out Info_Node) is begin pragma Unreferenced (Control); pragma Unreferenced (State); null; end Terminate_Node; end Node_Trav;