----------------------------------------------------------------------
--  Framework.Language.Scanner - Package body                       --
--                                                                  --
--  This software  is (c) The European Organisation  for the Safety --
--  of Air  Navigation (EUROCONTROL) and Adalog  2004-2005. The Ada --
--  Controller  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.  This  unit 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 distributed  with this program; 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 the units  of this program, or if 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.                              --
--                                                                  --
--  This  software 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.                                                        --
----------------------------------------------------------------------

with   -- Standard Ada units
  Ada.Characters.Handling,
  Ada.Strings.Wide_Fixed,
  Ada.Wide_Text_IO;

with -- Application specific units
  Utilities;
package body Framework.Language.Scanner is
   use Ada.Wide_Text_IO;

   ------------------------------------------------------------------
   -- Internal utilities                                           --
   ------------------------------------------------------------------

   -- Invariants:
   -- The_Token is the current token
   -- Cur_Char is the next character to process, undefined if
   --   At_Eol is true meaning that the current character is the
   --   end of line.
   -- To get a more natural behaviour in interactive mode, Next_Token
   -- just marks the token as delayed, actual scanning of token will take
   -- place at the first call to Current_Token.

   The_Token     : Token;
   Token_Delayed : Boolean := True;
   String_Token  : Boolean;

   Origin_Is_String : Boolean := False;
   Cur_Char         : Wide_Character;
   At_Eol           : Boolean;
   Source_String    : Ada.Strings.Wide_Unbounded.Unbounded_Wide_String;
   Source_Last      : Natural;

   Current_File   : Ada.Strings.Wide_Unbounded.Unbounded_Wide_String;
   Current_Line   : Asis.Text.Line_Number;
   Current_Column : Asis.Text.Character_Position;
   Current_Prompt : Ada.Strings.Wide_Unbounded.Unbounded_Wide_String;
   Prompt_Active  : Boolean := False;

   ------------------
   -- Syntax_Error --
   ------------------

   procedure Syntax_Error (Message : Wide_String; Position : Location) is
      use Utilities;
   begin
      Error (Image (Position)
               & ": "
               & Message);
   end Syntax_Error;

   ---------------
   -- Next_Char --
   ---------------

   --  Buffer size is arbitrary, make it big enough for (almost) all
   --  input lines to fit in. Note that the size of input lines is NOT
   --  limited by the buffer size, it is just a matter of optimization
   Buffer   : Wide_String (1..200);
   Buf_Inx  : Natural := 1;
   Buf_Last : Natural := 0;

   procedure Next_Char is
      use Ada.Strings.Wide_Unbounded, Ada.Strings.Wide_Fixed;
   begin
      if Buf_Inx = Buf_Last and Buf_Last = Buffer'Last then
         -- Buffer was too short, read next part
         -- (may read an empty string, but it's OK)
         if Origin_Is_String then
            Buf_Last := Integer'Min (Buffer'Length, Length (Source_String) - Source_Last);
            Buffer (1 .. Buf_Last) := Slice (Source_String, Source_Last + 1, Source_Last + Buf_Last);
            Source_Last := Source_Last + Buf_Last;
         else
            Get_Line (Current_Input, Buffer, Buf_Last);
         end if;
         Buf_Inx        := 1;
         Current_Column := Current_Column + 1;

      elsif At_Eol then
         if Origin_Is_String then
            -- if From_String, End of Line => End Of File
            raise End_Error;
         else
            if Current_Prompt /= Null_Unbounded_Wide_String then
               if Prompt_Active then
                  Put (Current_Error, To_Wide_String (Current_Prompt) & ": ");
               else
                  Put (Current_Error, Length (Current_Prompt) * '.' & ": ");
               end if;
            end if;

            Get_Line (Current_Input, Buffer, Buf_Last);
            Buf_Inx        := 1;
            Current_Line   := Current_Line + 1;
            Current_Column := 1;
         end if;

      else
         Buf_Inx        := Buf_Inx + 1;
         Current_Column := Current_Column + 1;
      end if;

      if Buf_Inx > Buf_Last then
         -- Includes case of empty line
         At_Eol := True;
         return;
      end if;

      At_Eol        := False;
      Prompt_Active := False;
      Cur_Char      := Buffer (Buf_Inx);
   end Next_Char;

   ---------------------
   -- Look_Ahead_Char --
   ---------------------

   function Look_Ahead_Char return Wide_Character is
   begin
       if Buf_Inx = Buf_Last and Buf_Last = Buffer'Last then
          -- Buffer was too short, read next part
          -- (may read an empty string, but it's OK)
          -- Keep current char in buffer to maintain invariant
          Buffer (1) := Cur_Char;
          if Origin_Is_String then
             Buf_Last := Integer'Min (Buffer'Size, Length (Source_String) - Source_Last) - 1;
             Buffer (2 .. Buf_Last) := Slice (Source_String, Source_Last + 1, Source_Last + Buf_Last);
             Source_Last := Source_Last + Buf_Last;
          else
             Get_Line (Current_Input, Buffer (2 .. Buffer'Last), Buf_Last);
          end if;
          Buf_Inx := 1;
       end if;

       if Buf_Inx = Buffer'Last then
          -- End of line, pretend there is an extra space
          return ' ';
       else
          return Buffer (Buf_Inx + 1);
       end if;
   end Look_Ahead_Char;


   -----------------------
   -- Actual_Next_Token --
   -----------------------

   -- The following declaration ensures that we get an error if we add a Character_Token
   -- and forget to modify the following elements.
   Char_Tokens : constant Wide_String (Token_Kind'Pos (Character_Token_Kind'First) ..
                                       Token_Kind'Pos (Character_Token_Kind'Last))
     := "{}()<>':;,.";
   Char_Token_Values : array (Char_Tokens'Range) of Token
     := ((Kind => Left_Bracket,      Position => Null_Location),
         (Kind => Right_Bracket,     Position => Null_Location),
         (Kind => Left_Parenthesis,  Position => Null_Location),
         (Kind => Right_Parenthesis, Position => Null_Location),
         (Kind => Left_Angle,        Position => Null_Location),
         (Kind => Right_Angle,       Position => Null_Location),
         (Kind => Tick,              Position => Null_Location),
         (Kind => Colon,             Position => Null_Location),
         (Kind => Semi_Colon,        Position => Null_Location),
         (Kind => Comma,             Position => Null_Location),
         (Kind => Period,            Position => Null_Location));

   procedure Actual_Next_Token (Force_String : Boolean := False) is
      use Ada.Strings.Wide_Fixed, Ada.Characters.Handling;
      use Utilities;

      Value        : Integer;
      First_Line   : Asis.Text.Line_Number;
      First_Column : Asis.Text.Character_Position;

      procedure Get_Name (Extended : Boolean) is
         Quoted : constant Boolean := Cur_Char = '"';
      begin
         if Quoted then
            The_Token := (Kind     => Name,
                          Position => (Current_File, First_Line, First_Column),
                          Length   => 0,
                          Text     => (others => ' '),
                          Key      => Not_A_Key);
         else
            The_Token := (Kind     => Name,
                          Position => (Current_File, First_Line, First_Column),
                          Length   => 1,
                          Text     => (1 => Cur_Char, others => ' '),
                          Key      => Not_A_Key);
         end if;
         Next_Char;

         loop
            if Quoted then
               if At_Eol then
                  Syntax_Error ("Unterminated quoted string", The_Token.Position);
               end if;
               if Cur_Char = '"' then
                  Next_Char;
                  exit when At_Eol or Cur_Char /= '"';
               end if;
            else
               exit when At_Eol;

               if Extended then
                  exit when Cur_Char = ';';
               else
                  exit when Cur_Char <= ' ';
                  exit when not Is_letter (To_Character (Cur_Char))
                    and not Is_Digit (To_Character (Cur_Char))
                    and Cur_Char /= '_';
               end if;
            end if;

            if The_Token.Length = The_Token.Text'Last then
               Syntax_Error ("Identifier too long", The_Token.Position);
               return;
            end if;
            The_Token.Length := The_Token.Length + 1;
            The_Token.Text (The_Token.Length) := Cur_Char;
            Next_Char;
         end loop;
      end Get_Name;

   begin
      Token_Delayed := False;

      if The_Token.Kind = EoF then
         -- EoF found => stay there
         return;
      end if;

      loop
         if At_EoL then
            -- Skip empty lines
            Next_Char;
         elsif Cur_Char = '#' or else (Cur_Char = '-' and then Look_Ahead_Char = '-') then
            -- Skip comment
            while not At_Eol loop
               Next_char;
            end loop;
         elsif Cur_Char > ' ' then
            exit;
         else
            Next_Char;
         end if;
      end loop;

      -- Here we have read a non-blank character
      First_Line   := Current_Line;
      First_Column := Current_Column;

      if Force_String then
         Get_Name (Extended => True);

      else
         case Cur_Char is
            when '{' | '}' | '(' | ')' | '<' | '>' | ''' | ':' | ';' | ',' | '.' =>
               The_Token := Char_Token_Values (Index (Char_Tokens, Cur_Char & ""));
               The_Token.Position := (Current_File, First_Line, First_Column);
               Next_Char;

            when '0' .. '9' =>
               Value := Wide_Character'Pos (Cur_Char) - Wide_Character'Pos ('0');
               loop
                  Next_Char;
                  exit when At_Eol;
                  if Cur_Char = '_' then
                     Next_Char;
                     if Cur_Char = '_' then
                        Syntax_Error ("Consecutive underscores not allowed in numbers", The_Token.Position);
                     elsif Cur_Char not in '0'..'9' then
                        Syntax_Error ("Trailing underscores not allowed in numbers", The_Token.Position);
                     end if;
                  end if;
                  if Cur_Char in '0' .. '9' then
                     Value := Value*10 + Wide_Character'Pos (Cur_Char) - Wide_Character'Pos ('0');
                  elsif Is_Letter (To_Character (Cur_Char)) then
                     Syntax_Error ("Letter not allowed in numbers", The_Token.Position);
                  else
                     -- Must be a separator here
                     exit;
                  end if;
               end loop;
               The_Token := (Kind     => Integer_Value,
                             Position => (Current_File, First_Line, First_Column),
                             Value    => Value);

            when '"' | 'a'..'z' | 'A'..'Z' | '_' => -- We allow '_' because of "_anonymous_"
               Get_Name (Extended => False);

               -- Check for keywords
               declare
                  To_Check : constant Wide_String
                    := "KEY_" & To_Upper (The_Token.Text (1..The_Token.Length));
               begin
                  for Key in Key_Kind'First .. Key_Kind'Pred (Not_A_Key) loop
                     if To_Check = Key_Kind'Wide_Image (Key) then
                        The_Token.Key := Key;
                        exit;
                     end if;
                  end loop;
               end;

            when others =>
               Syntax_Error ("Unexpected character: " & Cur_Char,
                             (Current_File, Current_Line, Current_Column));
         end case;
      end if;
   exception
      when End_Error =>
         The_Token := (Kind => EoF,
                       Position => (Current_File, Current_Line, Current_Column));
   end Actual_Next_Token;

   ------------------------------------------------------------------
   -- Exported subprograms                                         --
   ------------------------------------------------------------------

   -------------------
   -- Current_Token --
   -------------------

   function Current_Token return Token is
   begin
      if Token_Delayed then
         Actual_Next_Token (String_Token);
      end if;
      return The_Token;
   end Current_Token;

   ----------------
   -- Next_Token --
   ----------------

   procedure Next_Token (Force_String : Boolean := False) is
   begin
      Token_Delayed := True;
      String_Token  := Force_String;
   end Next_Token;

   ----------------
   -- Set_Prompt --
   ----------------

   procedure Set_Prompt (Prompt : Wide_String) is
   begin
      Current_Prompt := To_Unbounded_Wide_String (Prompt);
      Prompt_Active  := True;
   end Set_Prompt;

   ---------------------
   -- Activate_Prompt --
   ---------------------

   procedure Activate_Prompt is
   begin
      Prompt_Active := True;
   end Activate_Prompt;

   ----------------
   -- Start_Scan --
   ----------------

   procedure Start_Scan (From_String : boolean; Source : Wide_String) is
      use Ada.Strings.Wide_Unbounded;
   begin
      Origin_Is_String := From_String;
      Current_Line     := 1;
      Current_Column   := 0;

      if Origin_Is_String then
         Source_String := To_Unbounded_Wide_String (Source);
         Current_File  := Null_Unbounded_Wide_String;

         Buf_Last := Integer'Min (Buffer'Length, Length (Source_String));
         Buffer (1 .. Buf_Last) := Slice (Source_String, 1, Buf_Last);
         Source_Last := Buf_Last;

      else
         Current_File := To_Unbounded_Wide_String (Source);
         if Current_Prompt /= Null_Unbounded_Wide_String then
            Put (Current_Error, To_Wide_String (Current_Prompt) & ": ");
         end if;

         -- Get a non-empty line:
         loop
            Get_Line (Current_Input, Buffer, Buf_Last);
            exit when Buf_Last >= 1;
            Current_Line := Current_Line + 1;
         end loop;
      end if;

      Buf_Inx       := 1;
      Cur_Char      := Buffer (Buf_Inx);
      At_Eol        := False;
      Prompt_Active := False;
      The_Token     := (Kind => Semi_Colon, Position => The_Token.Position); -- Make sure it is not EoF

   exception
      when End_Error =>
         The_Token := (Kind     => EoF,
                       Position => (Current_File, Current_Line, Current_Column));
  end Start_Scan;

   -----------
   -- Image --
   -----------

   function Image (T : Token) return Wide_String is
   begin
      case T.Kind is
         when Name =>
            return T.Text (1 .. T.Length);
         when Integer_Value =>
            declare
               Image : constant Wide_String := Integer'Wide_Image (T.Value);
            begin
               return Image (2 .. Image'Length);
            end;
         when Character_Token_Kind =>
            return (1 => Char_Tokens (Character_Token_Kind'Pos (T.Kind)));
         when EoF =>
            Utilities.Failure ("Token image for EoF");
      end case;
   end Image;

   ----------------
   -- Save_State --
   ----------------

   procedure Save_State (State : out Scanner_State) is
   begin
      State := (The_Token,
                Token_Delayed,
                Origin_Is_String,
                Cur_Char,
                At_Eol,
                Source_String,
                Source_Last,
                Current_File,
                Current_Line,
                Current_Column,
                Current_Prompt,
                Prompt_Active);
   end Save_State;

   -------------------
   -- Restore_State --
   -------------------

   procedure Restore_State (State : in  Scanner_State) is
   begin
      The_Token        := State.The_Token;
      Token_Delayed    := State.Token_Delayed;
      Origin_Is_String := State.Origin_Is_String;
      Cur_Char         := State.Cur_Char;
      At_Eol           := State.At_Eol;
      Source_String    := State.Source_String;
      Source_Last      := State.Source_Last;
      Current_File     := State.Current_File;
      Current_Line     := State.Current_Line;
      Current_Column   := State.Current_Column;
      Current_Prompt   := State.Current_Prompt;
      Prompt_Active    := State.Prompt_Active;
   end Restore_State;

   ---------------
   -- Is_String --
   ---------------

   function Is_String (T : Token; Value : Wide_String) return Boolean is
      use Utilities;
   begin
      if T.Kind /= Name then
         return False;
      end if;

      return To_Upper (T.Text (1 .. T.Length)) = Value;
   end Is_String;

end Framework.Language.Scanner;

