------------------------------------------------------------------------------
-- --
-- DISPLAY_SOURCE COMPONENTS --
-- --
-- I M A G E _ T R A V --
-- --
-- B o d y --
-- --
-- $Revision: 1.9 $
-- --
-- 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 --
-----------------------------------------------------------------
--
-- In that application, each element is displayed, so we have
-- always a detailed display of each element (which can have a
-- cost in performance, because we call Asis queries on every
-- element). In fact it would be possible to have a global
-- display of the elements whose sub-elements didn't undergo
-- any special treatment (in Pre-Source).
--
-- Changing that would imply to have a more complex structure
-- (in State parameter), probably with a stack. We would push
-- the elements in Pre_Image and pop them in Post_Image.
-- Moreover we would need to keep in memory for each pushed
-- element the list of the children already passed without any
-- special treatment (In order to be able to display them
-- separately if one of their siblings had a special treatment)
--
-- But in fact i prefered to keep something simple because the
-- gain in performance is not obvious.
--
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Text_IO;
with Asis.Text;
with Asis.Elements;
with Asis.Expressions;
with Global_Info; use Global_Info;
package body Image_Trav is
use Asis;
-- to make all the literals from Element classification hierarchy
-- directly visible
-- Increment_Source_Position and Decrement_Source_Position are used by
-- span operations "-" and "/". As you can imagine, those functions add
-- of substract one char to a position in the source (line, column).
-- It takes into account the length of the lines, so if you are at the
-- end of a line, the next position is the first character of the next
-- line, and if you are at the beginning of a line, the previous character
-- is the last character of the previous line.
-- Pre-condition : the incrementation is possible ..
-- (i.e we are not at the last character of the last line ...)
procedure Increment_Source_Position
(Line : in out Asis.Text.Line_Number;
Char : in out Asis.Text.Character_Position;
Element : Asis.Element);
procedure Increment_Source_Position
(Line : in out Asis.Text.Line_Number;
Char : in out Asis.Text.Character_Position;
Element : Asis.Element)
is
List : Asis.Text.Line_List :=
Asis.Text.Lines (Element, Line, Line);
begin
if List'Length /= 0 then
if Asis.Text.Length (List (List'First)) >= Char then
Char := Char + 1;
else
-- normaly that is ok, in that case ....
Line := Line + 1;
Char := 1;
end if;
end if;
exception
when others =>
Ada.Text_IO.Put_Line
("exception raised in Increment_Source_Position");
raise;
end Increment_Source_Position;
-- There is no condition here, if the position is the begining of the file,
-- then the position returned is the same.
procedure Decrement_Source_Position
(Line : in out Asis.Text.Line_Number;
Char : in out Asis.Text.Character_Position;
Element : Asis.Element);
procedure Decrement_Source_Position
(Line : in out Asis.Text.Line_Number;
Char : in out Asis.Text.Character_Position;
Element : Asis.Element)
is
begin
if Char /= 1 then
Char := Char - 1;
else
if Line /= 1 then
Line := Line - 1;
declare
List : Asis.Text.Line_List :=
Asis.Text.Lines (Element, Line, Line);
begin
if List'Length /= 0 then
Char := Asis.Text.Length (List (List'First));
end if;
end;
end if;
end if;
exception
when others =>
Ada.Text_IO.Put_Line
("exception raised in Decrement_Source_Position");
raise;
end Decrement_Source_Position;
-- Outputs the text corresponding to the given span and elements.
-- Modify State.Last_Printed_Span, when the given span is has been output
-- (ie when it's not a Nil_Span).
-- Output_span is the only function with Pre_Image that outputs text.
procedure Output_Span
(The_Span : Asis.Text.Span;
State : in out Info_Image;
Element : Asis.Element);
procedure Output_Span
(The_Span : Asis.Text.Span;
State : in out Info_Image;
Element : Asis.Element) is
-- Line_Im is here to handle the With_Comments thing.
-- (see Info_Image in image_trav.ads)
function Line_Im (Line : Asis.Text.Line) return String;
function Line_Im (Line : Asis.Text.Line) return String is -- ???
begin
if State.With_Comments then
return To_String (Asis.Text.Line_Image (Line)); -- ???
else
return To_String (Asis.Text.Non_Comment_Image (Line));
end if;
end Line_Im;
begin
-- if the span is nil, nothing to do.
if Asis.Text."=" (The_Span, Asis.Text.Nil_Span) then
return;
end if;
declare
-- we get the lines :
List : Asis.Text.Line_List := Asis.Text.Lines (Element, The_Span);
begin
-- and we print them one by one
for I in List'Range
loop
declare
Text : String := Line_Im (List (I));
begin
if I = List'First then
if List'Length = 1 then
Ada.Text_IO.Put (Text);
else
Ada.Text_IO.Put_Line (Text);
end if;
elsif I = List'Last then
Ada.Text_IO.Put (Text);
else
Ada.Text_IO.Put_Line (Text);
end if;
State.Horizontal_Position := Text'Length;
end;
end loop;
State.Last_Printed_Span := The_Span;
end;
exception
when others =>
Ada.Text_IO.Put_Line ("exception raised in Output_Span");
raise;
end Output_Span;
-- In Pre_Image you can do what you want in order to do your
-- particular application.
-- When you decide that an element will take care of its display on its
-- own, you just have to print the span :
-- Element_Span (Element) - Last_Printed_Span
-- which is the span between the last span the application has displayed
-- and the span corresponding to the element ...
-- and put State.Last_Printed_Span := Element_Span (Span);
procedure Pre_Image
(Element : in Asis.Element;
Control : in out Asis.Traverse_Control;
State : in out Info_Image) is
-- Definition of an operation between Spans ...
-- Like the standard minus, you put the higher argument as the
-- left parameter (higher for a span means that it denotes
-- a text window that is after ...)
-- The result is :
-- - The Span that is between the 2 spans given if they
-- are in the correct order.
-- - The Nil_Span if Right is higher than Left.
--
-- example :
--
-- -----
-- | |
-- -----
-- -----
-- | |
-- => | |
-- | |
-- -----
-- -----
-- | |
-- -----
function "-" (Left, Right : Asis.Text.Span) return Asis.Text.Span;
function "-" (Left, Right : Asis.Text.Span) return Asis.Text.Span is
Tmp : Asis.Text.Span;
begin
-- setting the first position
if Asis.Text."=" (Right, Asis.Text.Nil_Span) then
Tmp.First_Line := 1;
Tmp.First_Column := 1;
else
Tmp.First_Line := Right.Last_Line;
Tmp.First_Column := Right.Last_Column;
Increment_Source_Position
(Tmp.First_Line, Tmp.First_Column, Element);
end if;
-- setting the last position
Tmp.Last_Line := Left.First_Line;
Tmp.Last_Column := Left.First_Column;
Decrement_Source_Position
(Tmp.Last_Line, Tmp.Last_Column, Element);
-- before returning we check that the span is correct
if (Tmp.First_Line < Tmp.Last_Line) or
(Tmp.First_Line = Tmp.Last_Line and
Tmp.First_Column <= Tmp.Last_Column)
then
return Tmp;
else
return Asis.Text.Nil_Span;
end if;
exception
when others =>
Ada.Text_IO.Put_Line ("exception raised in ""-""");
raise;
end "-";
-- returns a string that helps to indent when you replace
-- something with something else that has several lines ...
function Indentation return String;
function Indentation return String is
Result : String (1 .. State.Horizontal_Position) := (others => ' ');
begin
return Result;
end Indentation;
-- the procedure Display_Before, updates the output so that
-- all the text before the first character of the image of
-- the current element is displayed.
procedure Display_Before;
procedure Display_Before is
begin
Output_Span
((Asis.Text.Element_Span (Element) - State.Last_Printed_Span),
State,
Element);
exception
when others =>
Ada.Text_IO.Put_Line ("exception raised in Display_Before");
raise;
end Display_Before;
-- the procedure Dont_Display make it so everything is like if
-- the current element had been displayed except the displaying
-- in itself ...
-- It's important to notice that it sets the control to
-- Abandon_Children
procedure Dont_Display;
procedure Dont_Display is
Elem_Span : Asis.Text.Span := Asis.Text.Element_Span (Element);
begin
State.Handled_In_Pre := True;
Control := Asis.Abandon_Children;
State.Last_Printed_Span := Elem_Span;
exception
when others =>
Ada.Text_IO.Put_Line ("exception raised in Dont_Display");
raise;
end Dont_Display;
-- the procedure Display_Now is like Dont_Display, but it displays the
-- element.
-- It's important to notice that it sets the control to
-- Abandon_Children
procedure Display_Now;
pragma Unreferenced (Display_Now);
procedure Display_Now is
Elem_Span : Asis.Text.Span := Asis.Text.Element_Span (Element);
begin
State.Handled_In_Pre := True;
Control := Asis.Abandon_Children;
Output_Span (Elem_Span, State, Element);
end Display_Now;
begin
-- In this function, the program tests if you've got the expected
-- element kind, and if so you can choose for instance :
-- - to display the element on your own (modify)
-- - not to display the element (skip it)
-- - comment it .. or whatever ...
--
-- Before that, you say that you want the text before the element
-- to be displayed by calling the Display_before procedure.
-- Then you can call the Dont_Display procedure that indicates
-- you don't want the element to be displayed in Post-Source.
-- This procedure sets State.Handled_In_Pre to True, and
-- Control to Asis.Abandon_Children, this way
-- the next called funtion is Post_Image of the same element which
-- uses the boolean Handled_In_Pre immediately ...
-- The example here is an application where we want to suppress
-- inline pragmas (that can be because we want to reduce exec size.
-- (I didn't check it does, it's just an example ... :))
-- there is also some operations on Unknown pragmas :
-- for example :
-- pragma Bonjour;
-- pragma Hello;
-- pragma Hello ("master");
-- pragma Hello (1);
-- pragma Hello (2.3E32);
-- pragma Hello ('U');
-- pragma Hello (A);
-- pragma Hello ('U', "Me");
-- pragma Hello ((1 => 2, others => 3));
-- pragma HeLlO;
--
-- becomes :
-- -- pragma Bonjour;
-- Ada.Text_IO.Put_Line ("Hello default !");
-- Ada.Text_IO.Put_Line -- I wanted to show that we can pass a line
-- ("Hello "master" !");
-- Ada.Text_IO.Put_Line -- I wanted to show that we can pass a line
-- ("Hello 1 !");
-- Ada.Text_IO.Put_Line -- I wanted to show that we can pass a line
-- ("Hello 2.3E32 !");
-- Ada.Text_IO.Put_Line ("Hello 'U' !");
-- Ada.Text_IO.Put_Line ("Hello A !");
-- Ada.Text_IO.Put_Line
-- ("I can't say hello to more than one parameter at once.");
-- Ada.Text_IO.Put_Line ("I don't say hello to such parameter");
-- -- pragma HeLlO;
-- the pragma 'Pre-Compilation' works only if we are in mode
-- Image_And_Example, if not, the source is displayed as is.
if The_Mode /= Image_And_Example then
return;
end if;
case Asis.Elements.Element_Kind (Element) is
when A_Pragma =>
case Asis.Elements.Pragma_Kind (Element) is
when An_Inline_Pragma =>
Display_Before;
Dont_Display;
-- we display nothing because we want to suppress them ...
when An_Unknown_Pragma =>
Display_Before;
-- We check that we have the correct pragma
-- if we want to be case unsensitive, we need
-- to make an unsensitive case test.
if To_String (Asis.Elements.Pragma_Name_Image (Element)) =
String'("Hello")
then
Dont_Display; -- to say that we'll do by ourselves
declare
-- we get the parameter list
Param : Asis.Association_List :=
Asis.Elements.Pragma_Argument_Associations (Element);
Expr : Asis.Element;
begin
if Param'Length = 0 then
-- if no parameter, then we do the default
Ada.Text_IO.Put
("Ada.Text_IO.Put_Line (""Hello default !"");");
elsif Param'Length = 1 then
-- if there is one parameter, we get its value
-- (named parameter form could be handled getting
-- the Formal_Parameter of the association)
Expr := Asis.Expressions.Actual_Parameter
(Param (Param'First));
-- depending on the kind of expression we do
-- different things
case Asis.Elements.Expression_Kind (Expr) is
when An_Identifier |
An_Operator_Symbol |
A_Character_Literal |
An_Enumeration_Literal =>
Ada.Text_IO.Put
("Ada.Text_IO.Put_Line (""Hello " &
To_String
(Asis.Expressions.Name_Image (Expr)) &
" !"");");
when An_Integer_Literal |
A_Real_Literal |
A_String_Literal =>
Ada.Text_IO.Put_Line
("Ada.Text_IO.Put_Line "&
"-- I wanted to show that "&
"we can pass a line");
Ada.Text_IO.Put
(Indentation &
" (""Hello " & To_String
(Asis.Expressions.Value_Image (Expr)) &
" !"");");
when others =>
-- Some expression kinds are very
-- complicated we handle here only simple
-- expressions
Ada.Text_IO.Put
("Ada.Text_IO.Put_Line "&
"(""I don't say hello "&
"to such parameter"");");
end case;
else
-- if there is more than one parameter,
-- it is an error
Ada.Text_IO.Put
("Ada.Text_IO.Put_Line "&
"(""I can't say hello to more than one "&
"parameter at once."");");
end if;
end;
else
-- When it is an unknown unknown pragma
-- (when it is different from "Hello")
-- we comment it ...
-- notice that there is no Dont_Display here
Ada.Text_IO.Put ("-- ");
end if;
when others =>
null;
end case;
when others =>
null;
end case;
end Pre_Image;
-----------------------------------------
-- Post_Image has a simple function : --
-- it displays elements from the last --
-- span to the end of the element. --
-----------------------------------------
procedure Post_Image
(Element : in Asis.Element;
Control : in out Asis.Traverse_Control;
State : in out Info_Image) is
pragma Unreferenced (Control);
-- Definition of an operation between Spans ...
-- Like the standard minus, you put the higher argument as the
-- left parameter (higher for a span means that it denotes
-- a text window that is after ...)
-- The result is :
-- - The union of the Left span and of the span corresponding
-- to the space between the 2 spans if they
-- are in the correct order.
-- - The Nil_Span if Right is higher than Left.
--
-- example :
--
-- -----
-- | |
-- -----
-- -----
-- | |
-- => | |
-- | |
-- ----- | |
-- | | | |
-- ----- -----
function "/" (Left, Right : Asis.Text.Span) return Asis.Text.Span;
function "/" (Left, Right : Asis.Text.Span) return Asis.Text.Span is
Tmp : Asis.Text.Span;
begin
-- setting the first position
if Asis.Text."=" (Right, Asis.Text.Nil_Span) then
Tmp.First_Line := 1;
Tmp.First_Column := 1;
else
Tmp.First_Line := Right.Last_Line;
Tmp.First_Column := Right.Last_Column;
Increment_Source_Position
(Tmp.First_Line, Tmp.First_Column, Element);
end if;
-- setting the last position
Tmp.Last_Line := Left.Last_Line;
Tmp.Last_Column := Left.Last_Column;
-- before returning we check that the span is correct
if (Tmp.First_Line < Tmp.Last_Line) or
(Tmp.First_Line = Tmp.Last_Line and
Tmp.First_Column <= Tmp.Last_Column)
then
return Tmp;
else
return Asis.Text.Nil_Span;
end if;
end "/";
Tmp_Span : Asis.Text.Span := Asis.Text.Nil_Span;
begin
-- if the element has already been displayed in Pre_Image
if State.Handled_In_Pre then
State.Handled_In_Pre := False;
return;
end if;
if State.Finishing_Traversal then
-- we use this value for terminate to say that we must display
-- everything now ....
Tmp_Span := Asis.Text.Compilation_Span (Element) /
State.Last_Printed_Span;
else
Tmp_Span := Asis.Text.Element_Span (Element) /
State.Last_Printed_Span;
end if;
Output_Span (Tmp_Span, State, Element);
end Post_Image;
procedure Initiate_Image
(Element : in Asis.Element;
Control : in out Asis.Traverse_Control;
State : in out Info_Image) is
begin
pragma Unreferenced (Control);
State.An_Element := Element;
exception
when others =>
Ada.Text_IO.Put_Line ("exception raised in Initiate_Image");
raise;
end Initiate_Image;
procedure Terminate_Image
(Control : in out Asis.Traverse_Control;
State : in out Info_Image) is
begin
State.Finishing_Traversal := True;
Post_Image (State.An_Element, Control, State);
exception
when others =>
Ada.Text_IO.Put_Line ("exception raised in Terminate_Image");
raise;
end Terminate_Image;
end Image_Trav;
syntax highlighted by Code2HTML, v. 0.9.1