File : asis-text.adb
------------------------------------------------------------------------------
-- --
-- ASIS-for-GNAT IMPLEMENTATION COMPONENTS --
-- --
-- A S I S . T E X T --
-- --
-- B o d y --
-- --
-- Copyright (c) 1995-1999, Free Software Foundation, Inc. --
-- --
-- ASIS-for-GNAT is free software; you can redistribute it and/or modify it --
-- under terms of the GNU General Public License as published by the Free --
-- Software Foundation; either version 2, or (at your option) any later --
-- version. ASIS-for-GNAT is distributed in the hope that it will be use- --
-- ful, but WITHOUT ANY WARRANTY; without even the implied warranty of MER- --
-- CHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General --
-- Public License for more details. You should have received a copy of the --
-- GNU General Public License distributed with ASIS-for-GNAT; see file --
-- COPYING. If not, write to the Free Software Foundation, 59 Temple Place --
-- - Suite 330, Boston, MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- ASIS-for-GNAT was originally developed by the ASIS-for-GNAT team at the --
-- Software Engineering Laboratory of the Swiss Federal Institute of --
-- Technology (LGL-EPFL) in Lausanne, Switzerland, in cooperation with the --
-- Scientific Research Computer Center of Moscow State University (SRCC --
-- MSU), Russia, with funding partially provided by grants from the Swiss --
-- National Science Foundation and the Swiss Academy of Engineering --
-- Sciences. ASIS-for-GNAT is now maintained by Ada Core Technologies Inc --
-- (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Asis; use Asis;
with Asis.Elements; use Asis.Elements;
with Asis.Exceptions; use Asis.Exceptions;
with Asis.Errors; use Asis.Errors;
with Asis.Set_Get; use Asis.Set_Get;
with Asis.Text.Set_Get; use Asis.Text.Set_Get;
with A4G.A_Debug; use A4G.A_Debug;
with A4G.A_Types; use A4G.A_Types;
with A4G.Int_Knds; use A4G.Int_Knds;
with A4G.Vcheck; use A4G.Vcheck;
with A4G.Contt.UT; use A4G.Contt.UT;
with A4G.Span_Beginning; use A4G.Span_Beginning;
with A4G.Span_End; use A4G.Span_End;
with A4G.A_Sinput; use A4G.A_Sinput;
with Types; use Types;
with Sinput; use Sinput;
with Output; use Output;
package body Asis.Text is
-------------------
-- Comment_Image --
-------------------
function Comment_Image
(The_Line : in Asis.Text.Line)
return Wide_String
is
begin
Check_Validity (The_Line, "Asis.Text.Comment_Image");
if The_Line.Length = 0 then
-- just a small optimization
return "";
end if;
declare
The_Line_Image : Wide_String := Line_Image (The_Line);
Comment_Pos : Natural :=
Comment_Beginning (To_String (The_Line_Image));
begin
if Comment_Pos = 0 then
-- no comment in this string
return "";
else
-- we have to pad the beginning (that is, non-comment part)
-- of the line image by white spaces, making difference between
-- HT and other symbols:
for I in The_Line_Image'First .. Comment_Pos - 1 loop
if To_Character (The_Line_Image (I)) /= ASCII.HT then
The_Line_Image (I) := ' ';
end if;
end loop;
return The_Line_Image;
end if;
end;
exception
when ASIS_Inappropriate_Line =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Outer_Call => "Asis.Text.Comment_Image");
raise;
when others =>
Raise_ASIS_Failed (
Diagnosis => "Asis.Text.Comment_Image");
end Comment_Image;
----------------------
-- Compilation_Span --
----------------------
function Compilation_Span
(Element : in Asis.Element)
return Asis.Text.Span
is
Result_Span : Asis.Text.Span := Asis.Text.Nil_Span;
S_P : Source_Ptr;
SFI : Source_File_Index;
begin
Check_Validity (Element, "Asis.Text.Compilation_Span");
-- In case of GNAT compilations are source files, so there is no need
-- to compute Result_Span.First_Line and Result_Span.First_Column -
-- the correct values are (1, 1) , and they come from Nil_Span
S_P := Get_Location (Element);
-- this makes all the rest "tree-swapping-safe"
SFI := Get_Source_File_Index (S_P);
Result_Span.Last_Line := Character_Position (Num_Source_Lines (SFI));
Result_Span.Last_Column := Character_Position
(Source_Last (SFI) - Line_Start (Source_Last (SFI)));
return Result_Span;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Outer_Call => "Asis.Text.Compilation_Span");
raise;
when others =>
Raise_ASIS_Failed (Diagnosis => "Asis.Text.Compilation_Span");
end Compilation_Span;
---------------------------
-- Compilation_Unit_Span --
---------------------------
function Compilation_Unit_Span
(Element : in Asis.Element)
return Asis.Text.Span
is
Result_Span : Asis.Text.Span;
CU : Asis.Compilation_Unit;
First_El : Asis.Element;
Unit : Asis.Element;
First_Span : Asis.Text.Span;
Last_Span : Asis.Text.Span;
begin
Check_Validity (Element, "Asis.Text.Compilation_Unit_Span");
CU := Enclosing_Compilation_Unit (Element);
Unit := Unit_Declaration (CU);
declare
Cont_Cl_Elms : Asis.Context_Clause_List :=
Context_Clause_Elements (Compilation_Unit => CU,
Include_Pragmas => True);
begin
if Is_Nil (Cont_Cl_Elms) then
First_El := Unit;
else
First_El := Cont_Cl_Elms (Cont_Cl_Elms'First);
end if;
end;
First_Span := Element_Span (First_El);
Last_Span := Element_Span (Unit);
Result_Span.First_Line := First_Span.First_Line;
Result_Span.First_Column := First_Span.First_Column;
Result_Span.Last_Line := Last_Span.Last_Line;
Result_Span.Last_Column := Last_Span.Last_Column;
return Result_Span;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Outer_Call => "Asis.Text.Compilation_Unit_Span");
raise;
when others =>
Raise_ASIS_Failed (
Diagnosis => "Asis.Text.Compilation_Unit_Span");
end Compilation_Unit_Span;
-----------------
-- Debug_Image --
-----------------
function Debug_Image
(The_Line : in Asis.Text.Line)
return Wide_String
is
LT : String renames ASIS_Line_Terminator;
S : Source_Ptr := Line_Location (The_Line);
-- this makes the rest "tree-swapping-safe"
begin
return To_Wide_String (LT
& "Debug image for Asis.Text.Line:"
& LT
& " Absolute (relative) location in source file : "
& Source_Ptr'Image (S)
& " ("
& Source_Ptr'Image (The_Line.Rel_Sloc)
& ')'
& LT
& " Line: "
& Logical_Line_Number'Image (Get_Line_Number (S))
& " Column: "
& Source_Ptr'Image (A_Get_Column_Number (S))
& LT
& " Number of characters in line: "
& Asis.Text.Character_Position'Image (Line_Length (The_Line))
& LT
& LT);
end Debug_Image;
---------------------
-- Delimiter_Image --
---------------------
function Delimiter_Image return Wide_String is
begin
return Asis_Wide_Line_Terminator;
end Delimiter_Image;
-------------------
-- Element_Image --
-------------------
function Element_Image
(Element : in Asis.Element)
return Wide_String
is
begin
Check_Validity (Element, "Asis.Text.Element_Image");
if not Is_Text_Available (Element) then
return "";
end if;
declare
LList : Asis.Text.Line_List := Lines (Element);
-- we create the Element Image from Lines containing the Element
Spaces : Natural;
-- the number of characters in the first line of the Image, which
-- should be padded by white spaces
Numb : Natural;
-- here we collect the whole number of characters needed in the
-- string representing the result Element image
begin
Spaces := Natural (Element_Span (Element).First_Column) - 1;
Numb := Asis.ASIS_Natural (Spaces) +
Asis.ASIS_Natural (LList'Last - LList'First) *
Asis.ASIS_Natural (ASIS_Line_Terminator'Length);
for I in LList'First .. LList'Last loop
Numb := Numb + Natural (Line_Length (LList (I)));
end loop;
if Numb > Positive'Last then
Set_Error_Status (Status => Capacity_Error,
Diagnosis => "Asis.Text.Element_Image: "
& "too many characters");
raise ASIS_Failed;
end if;
declare
Result_String : String (1 .. Numb);
In_Str : Positive := 1;
Line_Loc : Source_Ptr;
begin
-- first, we have to pad the beginning of the image by
-- white spaces:
Line_Loc := Line_Location (LList (LList'First));
for S in Line_Start (Line_Loc) .. Line_Loc - 1 loop
if Get_Character (S) = ASCII.HT then
Result_String (In_Str) := ASCII.HT;
else
Result_String (In_Str) := ' ';
end if;
In_Str := In_Str + 1;
end loop;
-- and now - filling the rest of Result_String
-- by the "proper" Element Image
for Linee in LList'First .. LList'Last loop
Line_Loc := Line_Location (LList (Linee));
for Char_Num in 1 .. Line_Length (LList (Linee)) loop
Result_String (In_Str) := Get_Character (Line_Loc);
In_Str := In_Str + 1;
Line_Loc := Line_Loc + 1;
end loop;
if Linee /= LList'Last then
Result_String (
In_Str .. In_Str + ASIS_Line_Terminator'Length - 1) :=
ASIS_Line_Terminator;
In_Str := In_Str + ASIS_Line_Terminator'Length;
end if;
end loop;
return To_Wide_String (Result_String);
end;
end;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (Outer_Call => "Asis.Text.Element_Image");
raise;
when others =>
Raise_ASIS_Failed (Diagnosis => "Asis_Text.Element_Image");
end Element_Image;
------------------
-- Element_Span --
------------------
-- Element_Span is "tree-swapping-safe"!
function Element_Span (Element : in Asis.Element) return Asis.Text.Span is
Sp : Asis.Text.Span := Asis.Text.Nil_Span;
Span_Start : Source_Ptr;
Span_End : Source_Ptr;
begin
Check_Validity (Element, "Asis.Text.Element_Span");
if Debug_Flag_X or else Debug_Mode then
Write_Str ("*** Asis.Text.Element_Span ***");
Write_Eol;
Write_Str ("Element kind is ");
Write_Str (Internal_Element_Kinds'Image (Int_Kind (Element)));
Write_Eol;
end if;
if not Is_Text_Available (Element) then
if Debug_Flag_X or else Debug_Mode then
Write_Str ("!!! Text isn't available !!!");
Write_Eol;
end if;
return Sp;
end if;
-- Set_Image_Beginning is "tree-swapping-safe"
Span_Start := Set_Image_Beginning (Element);
Span_End := Set_Image_End (Element);
Sp := Source_Locations_To_Span (Span_Start, Span_End);
if Debug_Flag_X or else Debug_Mode then
Write_Str ("Returning Asis.Text.Span parameters:");
Write_Eol;
Write_Str (Debug_Image (Sp));
Write_Eol;
end if;
return Sp;
exception
when ASIS_Inappropriate_Element =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Outer_Call => "Asis.Text.Element_Span");
raise;
when others =>
Raise_ASIS_Failed (
Diagnosis => "Asis.Text.Element_Span");
end Element_Span;
-----------------------
-- First_Line_Number --
-----------------------
function First_Line_Number (Element : in Asis.Element) return Line_Number
is
Sp : Asis.Text.Span;
begin
Check_Validity (Element, "Asis.Text.First_Line_Number");
if Is_Text_Available (Element) then
Sp := Element_Span (Element);
return Sp.First_Line;
else
return 0;
end if;
end First_Line_Number;
--------------
-- Is_Equal --
--------------
function Is_Equal
(Left : in Asis.Text.Line;
Right : in Asis.Text.Line)
return Boolean
is
C_Left : Context_Id;
C_Right : Context_Id;
U_Left : Unit_Id;
U_Right : Unit_Id;
begin
Check_Validity (Left, "Asis.Text.Is_Equal");
Check_Validity (Right, "Asis.Text.Is_Equal");
-- Two lines which are Is_Equal may be obtained from different
-- Context, and they may be based on different trees. But to
-- be Is_Equal, they have to represent the same portion of the
-- source text from the same source file
if Left.Length /= Right.Length or else
Left.Rel_Sloc /= Right.Rel_Sloc
then
return False;
else
-- we use just the same approach as for comparing Elements
C_Left := Left.Enclosing_Context;
U_Left := Left.Enclosing_Unit;
C_Right := Right.Enclosing_Context;
U_Right := Right.Enclosing_Unit;
return Time_Stamp (C_Left, U_Left) = Time_Stamp (C_Right, U_Right);
end if;
exception
when ASIS_Inappropriate_Line =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Outer_Call => "Asis.Text.Is_Equal");
raise;
when others =>
Raise_ASIS_Failed (
Diagnosis => "Asis.Text.Is_Equal");
end Is_Equal;
------------------
-- Is_Identical --
------------------
function Is_Identical
(Left : in Asis.Text.Line;
Right : in Asis.Text.Line)
return Boolean
is
begin
Check_Validity (Left, "Asis.Text.Is_Identical");
Check_Validity (Right, "Asis.Text.Is_Identical");
return (Left.Length = Right.Length and then
Left.Rel_Sloc = Right.Rel_Sloc and then
Left.Enclosing_Context = Right.Enclosing_Context and then
Left.Enclosing_Unit = Right.Enclosing_Unit);
end Is_Identical;
------------
-- Is_Nil --
------------
function Is_Nil (Right : in Asis.Text.Line) return Boolean is
Result : Boolean;
begin
-- Here we have to simulate the predefined "=" operation for
-- Line as if it is called as 'Right + Nil_Line'
Result := Right.Sloc = No_Location and then
Right.Length = 0 and then
Right.Rel_Sloc = No_Location and then
Right.Enclosing_Unit = Nil_Unit and then
Right.Enclosing_Context = Non_Associated and then
Right.Enclosing_Tree = Nil_Tree and then
Right.Obtained = Nil_ASIS_OS_Time;
return Result;
end Is_Nil;
function Is_Nil (Right : in Asis.Text.Line_List) return Boolean is
begin
return Right'Length = 0;
end Is_Nil;
function Is_Nil (Right : in Asis.Text.Span) return Boolean is
begin
return (Right.Last_Line < Right.First_Line) or else
((Right.Last_Line = Right.First_Line) and then
(Right.Last_Column < Right.First_Column));
end Is_Nil;
-----------------------
-- Is_Text_Available --
-----------------------
function Is_Text_Available (Element : in Asis.Element) return Boolean is
El_Kind : Internal_Element_Kinds := Int_Kind (Element);
Spec_Case : Special_Cases := Special_Case (Element);
begin
Check_Validity (Element,
"Asis.Text.Is_Text_Available");
if El_Kind = Not_An_Element or else
Is_From_Implicit (Element) or else
Is_From_Instance (Element) or else
Spec_Case in Explicit_From_Standard .. Stand_Char_Literal
then
return False;
else
return True;
end if;
end Is_Text_Available;
----------------------
-- Last_Line_Number --
----------------------
function Last_Line_Number
(Element : in Asis.Element)
return Asis.Text.Line_Number
is
Sp : Asis.Text.Span;
begin
Check_Validity (Element, "Asis.Text.Last_Line_Number");
if Is_Text_Available (Element) then
Sp := Element_Span (Element);
return Sp.Last_Line;
else
return 0;
end if;
end Last_Line_Number;
------------
-- Length --
------------
function Length
(The_Line : in Asis.Text.Line)
return Asis.Text.Character_Position
is
begin
Check_Validity (The_Line, "Asis.Text.Length");
return Line_Length (The_Line);
end Length;
----------------
-- Line_Image --
----------------
function Line_Image (The_Line : in Asis.Text.Line) return Wide_String is
begin
Check_Validity (The_Line, "Asis.Text.Line_Image");
if Line_Length (The_Line) = 0 then
return "";
end if;
declare
S : Source_Ptr := Line_Location (The_Line);
Space_Len : Character_Position :=
Character_Position (S - Line_Start (S));
Result_Len : Character_Position :=
Space_Len + Line_Length (The_Line);
Result_String : String (1 .. Result_Len);
begin
-- first, padding the beginning of the image if needed:
S := Line_Start (S);
for I in 1 .. Space_Len loop
if Get_Character (S) = ASCII.HT then
Result_String (I) := ASCII.HT;
else
Result_String (I) := ' ';
end if;
S := S + 1;
end loop;
-- and now - filling in the "proper image" part:
for I in Space_Len + 1 .. Result_Len loop
Result_String (I) := Get_Character (S);
S := S + 1;
end loop;
return To_Wide_String (Result_String);
end;
exception
when ASIS_Inappropriate_Line =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Outer_Call => "Asis.Text.Line_Image");
raise;
when others =>
Raise_ASIS_Failed (
Diagnosis => "Asis.Text.Line_Image");
end Line_Image;
-----------
-- Lines --
-----------
function Lines (Element : in Asis.Element) return Asis.Text.Line_List is
begin
Check_Validity (Element, "Asis.Text.Lines (Element)");
if not Is_Text_Available (Element) then
return Nil_Line_List;
end if;
return Lines (Element, Element_Span (Element));
end Lines;
function Lines
(Element : in Asis.Element;
The_Span : in Asis.Text.Span)
return Asis.Text.Line_List
is
begin
Check_Validity (Element, "Asis.Text.Lines (Element, Span)");
if not Is_Text_Available (Element) then
return Nil_Line_List;
end if;
if Is_Nil (The_Span) or else
The_Span.Last_Line > Line_Number (Number_Of_Lines (Element))
then
Raise_ASIS_Inappropriate_Line_Number ("Lines (Element, Span)");
end if;
declare
LList : Asis.Text.Line_List :=
Lines (Element, The_Span.First_Line, The_Span.Last_Line);
-- this call to Lines is "tree-swapping-safe";
-- note also, that this call to Lines should not raise
-- any exception, because all the checks are already done
First_Line : Line_Number := LList'First;
Last_Line : Line_Number := LList'Last;
begin
-- and now we have to adjust the first and the last line in LList:
-- for the first line both the line location and the line length
-- should be adjusted, for the last line - the line length only;
-- the case when there is only one line is special:
if The_Span.First_Column > 1 then
Set_Line_Location
(L => LList (First_Line),
S => Line_Location (LList (First_Line)) +
Source_Ptr (The_Span.First_Column) - 1);
end if;
if First_Line = Last_Line then
-- Special case when there is only one line.
Set_Line_Length
(L => LList (First_Line),
N => The_Span.Last_Column - The_Span.First_Column + 1);
else
Set_Line_Length
(L => LList (First_Line),
N => Line_Length (LList (First_Line)) -
The_Span.First_Column + 1);
Set_Line_Length
(L => LList (Last_Line),
N => The_Span.Last_Column);
end if;
return LList;
end;
exception
when ASIS_Inappropriate_Element | ASIS_Inappropriate_Line_Number =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Outer_Call => "Asis.Text.Lines (Element, Asis.Text.Span)");
raise;
when others =>
Raise_ASIS_Failed (
Diagnosis => "Asis.Text.Lines (Element, Asis.Text.Span)");
end Lines;
function Lines
(Element : in Asis.Element;
First_Line : in Line_Number_Positive;
Last_Line : in Line_Number)
return Asis.Text.Line_List
is
Result_List : Line_List (First_Line .. Last_Line);
-- there is no harm to define result list here, because the
-- real work with it will be started when all the tests are passed.
begin
Check_Validity (Element,
"Asis.Text.Lines (Element, First_Line, Last_Line)");
if not Is_Text_Available (Element) then
return Nil_Line_List;
end if;
if First_Line = 0 or else
First_Line > Last_Line or else -- ???
Last_Line > Line_Number (Number_Of_Lines (Element))
then
Raise_ASIS_Inappropriate_Line_Number
("Asis.Text.Lines (Element, First_Line, Last_Line)");
end if;
-- if we are here, we have Result_List consisting of Nil_Lines,
-- and we know, that all the conditions for returning the
-- proper Line_List are met. So we have to make proper settings
-- for the fields of all the Lines from Result_List
Set_Lines (Result_List, Element);
-- this is "tree-swapping-safe"
return Result_List;
exception
when ASIS_Inappropriate_Element | ASIS_Inappropriate_Line_Number =>
raise;
when ASIS_Failed =>
Add_Call_Information (Outer_Call =>
"Asis.Text.Lines (Asis.Element, Asis.Text.Line_Numbers)");
raise;
when others =>
Raise_ASIS_Failed (Diagnosis =>
"Asis.Text.Lines (Asis.Element, Asis.Text.Line_Numbers)");
end Lines;
-----------------------
-- Non_Comment_Image --
-----------------------
function Non_Comment_Image
(The_Line : in Asis.Text.Line)
return Wide_String
is
begin
Check_Validity (The_Line, "Asis.Text.Non_Comment_Image");
if The_Line.Length = 0 then
-- just a small optimization
return "";
end if;
declare
The_Line_Image : Wide_String := Line_Image (The_Line);
Comment_Pos : Natural :=
Comment_Beginning (To_String (The_Line_Image));
begin
if Comment_Pos = 0 then
-- no comment in this Line
return The_Line_Image;
else
return The_Line_Image (The_Line_Image'First .. Comment_Pos - 1);
end if;
end;
exception
when ASIS_Inappropriate_Line =>
raise;
when ASIS_Failed =>
Add_Call_Information (
Outer_Call => "Asis.Text.Non_Comment_Image");
raise;
when others =>
Raise_ASIS_Failed (
Diagnosis => "Asis.Text.Non_Comment_Image");
end Non_Comment_Image;
end Asis.Text