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