parsers-multiline_source.adb

--                                                                    --
--  package                         Copyright (c)  Dmitry A. Kazakov  --
--     Parsers.Multiline_Source                    Luebeck            --
--  Implementation                                 Winter, 2004       --
--                                                                    --
--                                Last revision :  13:13 14 Sep 2019  --
--                                                                    --
--  This  library  is  free software; you can redistribute it and/or  --
--  modify it under the terms of the GNU General Public  License  as  --
--  published by the Free Software Foundation; either version  2  of  --
--  the License, or (at your option) any later version. This library  --
--  is distributed in the hope that it will be useful,  but  WITHOUT  --
--  ANY   WARRANTY;   without   even   the   implied   warranty   of  --
--  MERCHANTABILITY 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 along with  --
--  this library; if not, write to  the  Free  Software  Foundation,  --
--  Inc., 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.       --
--____________________________________________________________________--

with Ada.IO_Exceptions;      use Ada.IO_Exceptions;
with Strings_Edit.Integers;  use Strings_Edit.Integers;

package body Parsers.Multiline_Source is

   Initial_Size : constant Integer := 512;

   function "<" (Left, Right : Position) return Boolean is
   begin
      return
      (  Left.Line < Right.Line
      or else
         (  Left.Line = Right.Line
         and then
            Left.Column < Right.Column
      )  );
   end "<";

   procedure Finalize (Code : in out Source) is
   begin
      Free (Code.Buffer);
   end Finalize;

   function End_Of (Code : Source'Class) return Boolean is
   begin
      return Code.Buffer = null;
   end End_Of;

   function Get_Line (Code : Source'Class) return String is
   begin
      if Code.Buffer = null then
         raise End_Error;
      else
         return Code.Buffer (1..Code.Length);
      end if;
   end Get_Line;

   procedure Get_Line
             (  Code    : Source'Class;
                Line    : out Line_Ptr;
                Pointer : out Integer;
                Last    : out Integer
             )  is
   begin
      if Code.Buffer = null then
         raise End_Error;
      else
         Line    := Code.Buffer.all'Unchecked_Access;
         Pointer := Code.Pointer;
         Last    := Code.Length;
      end if;
   end Get_Line;

   function Get_Backup_Pointer (Code : Source'Class) return Integer is
   begin
      return Code.Last;
   end Get_Backup_Pointer;

   function Get_Location
            (  Message : String;
               Prefix  : String := "at "
            )  return Location is
      Pointer : Integer  := Message'Last;
      Result  : Location := ((0, 0), (0, 0));
   begin
      loop -- An occurence of Prefix
         loop -- Searching backwards Message for Prefix
            if Pointer < Message'First + Prefix'Length - 1 then
               return Result;
            end if;
            exit when
               Message (Pointer - Prefix'Length + 1..Pointer) = Prefix;
            Pointer := Pointer - 1;
         end loop;
         Pointer := Pointer + 1;
            -- After the prefix
         begin
            Get (Message, Pointer, Integer (Result.First.Line));
            Result.Next.Line := Result.First.Line;
            if (  Pointer >= Message'Last
               or else
                  Message (Pointer) /= ':'
               )
            then
               return Result;
            end if;
               -- Line:
            Pointer := Pointer + 1;
            begin
               Get (Message, Pointer, Result.First.Column, First => 1);
            exception
               when others =>
                  return Result;
            end;
               -- Line:Column
            Result.Next.Column := Result.First.Column;
            if (  Pointer + 1 >= Message'Last
               or else
                  Message (Pointer..Pointer + 1) /= ".."
               )
            then
               return Result;
            end if;
            Pointer := Pointer + 2;
               -- Line:Column..
            begin
               Get (Message, Pointer, Integer (Result.Next.Line));
            exception
               when others =>
                  return Result;
            end;
               -- Line:Column..Line
            if (  Pointer >= Message'Last
               or else
                  Message (Pointer) /= ':'
               )
            then
               Result.Next.Column := Integer (Result.Next.Line);
               Result.Next.Line   := Result.First.Line;
               return Result;
            end if;
            Pointer := Pointer + 1;
               -- Line:Column..Line:
            begin
               Get (Message, Pointer, Result.Next.Column);
                  -- Line:Column..Line:Column
               return Result;
            exception
               when others =>
                  Result.Next.Column := Integer (Result.Next.Line);
                  Result.Next.Line   := Result.First.Line;
                  return Result;
            end;
         exception
            when others =>
               return Result;
         end;
      end loop;
   end Get_Location;

   function Get_Pointer (Code : Source'Class) return Integer is
   begin
      return Code.Pointer;
   end Get_Pointer;

   function Image (Link : Location) return String is
   begin
      if Link.First = Link.Next then
         return
         (  Image (Integer (Link.First.Line))
         &  ":"
         &  Image (Link.First.Column)
         );
      elsif Link.First.Line = Link.Next.Line then
         return
         (  Image (Integer (Link.First.Line))
         &  ":"
         &  Image (Link.First.Column)
         &  ".."
         &  Image (Link.Next.Column - 1)
         );
      else
         return
         (  Image (Integer (Link.First.Line))
         &  ":"
         &  Image (Link.First.Column)
         &  ".."
         &  Image (Integer (Link.Next.Line))
         &  ":"
         &  Image (Link.Next.Column - 1)
         );
      end if;
   end Image;

   procedure Initialize (Code : in out Source) is
   begin
      Code.Buffer := new String (1..Initial_Size);
      Next_Line (Code);
   exception
      when Storage_Error =>
         raise;
      when others =>
         null;
   end Initialize;

   function Link (Code : Source'Class) return Location is
   begin
      return ((Code.Line, Code.Last), (Code.Line, Code.Pointer));
   end Link;

   function "&" (Left, Right : Location) return Location is
      Result : Location;
   begin
      if Left.First < Right.First then
         Result.First := Left.First;
      else
         Result.First := Right.First;
      end if;
      if Left.Next < Right.Next then
         Result.Next := Right.Next;
      else
         Result.Next := Left.Next;
      end if;
      return Result;
   end "&";

   procedure Next_Line (Code : in out Source'Class) is
   begin
      Code.Pointer := 1;
      Code.Last := 1;
      Get_Line (Code);
      Code.Line := Code.Line + 1;
   exception
      when End_Error =>
         Free (Code.Buffer);
         raise;
   end Next_Line;

   procedure Reset_Pointer (Code : in out Source'Class) is
   begin
      Code.Pointer := Code.Last;
   end Reset_Pointer;

   procedure Set_Pointer
             (  Code    : in out Source'Class;
                Pointer : Integer
             )  is
   begin
      if Code.Buffer = null then
         if Pointer /= 1 then
            raise Ada.IO_Exceptions.Layout_Error;
         end if;
      else
         if Pointer not in Code.Last..Code.Length + 1 then
            raise Ada.IO_Exceptions.Layout_Error;
         end if;
      end if;
      Code.Last    := Code.Pointer;
      Code.Pointer := Pointer;
   end Set_Pointer;

   procedure Skip (Code : in out Source'Class; Link : Location) is
   begin
      if Code.Line > Link.First.Line then
         raise Ada.IO_Exceptions.Layout_Error;
      end if;
      while Code.Line < Link.First.Line loop
         Next_Line (Code);
      end loop;
      Set_Pointer (Code, Link.First.Column);
      while Code.Line < Link.Next.Line loop
         Next_Line (Code);
      end loop;
      Set_Pointer (Code, Link.Next.Column);
   end Skip;

end Parsers.Multiline_Source;