------------------------------------------------------------------------------
--                                                                          --
--                 ASIS-for-GNAT IMPLEMENTATION COMPONENTS                  --
--                                                                          --
--                         A 4 G . A _ S I N P U T                          --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--                            $Revision: 1.18 $
--                                                                          --
--            Copyright (c) 1995-2001, 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.Set_Get;            use Asis.Set_Get;

with Atree;                   use Atree;
with Types;                   use Types;
with Sinfo;                   use Sinfo;
with Sinput;                  use Sinput;

package body A4G.A_Sinput is

   use ASCII;
   --  Make control characters visible

   -----------------------
   -- Local subprograms --
   -----------------------

   procedure Skip_Comment (P : in out Source_Ptr);
   --  When P is set on the first '-' of a comment, this procedure resets
   --  the value of P to the first character of the group of control
   --  characters signifying the end of line containing the comment
   --  initially indicated by P.
   --
   --  This procedure should not be used for the last comment in the
   --  group of comments following a compilation unit in a compilation.

   procedure Skip_String (P : in out Source_Ptr);
   --  When P set on the first quoter of a string literal (it may be '"' or
   --  '%', this procedure resets the value of P to the first character
   --  after the literal.

   -------------------------
   -- A_Get_Column_Number --
   -------------------------

   function A_Get_Column_Number (P : Source_Ptr) return Source_Ptr is
   begin
      return P - Line_Start (P) + 1;
   end A_Get_Column_Number;

   -----------------------
   -- Comment_Beginning --
   -----------------------

   function Comment_Beginning (Line_Image : String) return Natural is
      Line_Image_Start : Natural := Line_Image'First;
      Line_Image_End   : Natural := Line_Image'Last;
      Scanner_Pos      : Natural;
      String_Delimiter : Standard.Character;
   begin
      Scanner_Pos := Line_Image_Start - 1;

      Scan_The_Line : while Scanner_Pos < Line_Image_End loop

         Scanner_Pos := Scanner_Pos + 1;

         case Line_Image (Scanner_Pos) is

            when '"' | '%' =>

               if not ((Scanner_Pos - 1) >= Line_Image_Start and then
                       Line_Image (Scanner_Pos - 1) = '''
                     and then
                       (Scanner_Pos + 1) <= Line_Image_End and then
                       Line_Image (Scanner_Pos + 1) = ''')
               then
                  --  We have to awoid considering character literals '"'
                  --  '%' as string brackets

                  String_Delimiter := Line_Image (Scanner_Pos);

                  Skip_String_Literal : loop
                     Scanner_Pos := Scanner_Pos + 1;

                     if Line_Image (Scanner_Pos) = String_Delimiter then

                        --  we are in a legal Ada source, therefore:
                        if Scanner_Pos < Line_Image'Last and then
                           Line_Image (Scanner_Pos + 1) = String_Delimiter
                        then
                           --  Delimiter as character inside the literal.
                           Scanner_Pos := Scanner_Pos + 1;
                        else
                           --  End of the literal.
                           exit Skip_String_Literal;
                        end if;

                     end if;

                  end loop Skip_String_Literal;

               end if;

            when '-' =>

               if    (Scanner_Pos < Line_Image'Last) and then
                     (Line_Image (Scanner_Pos + 1) = '-')
               then
                  return Scanner_Pos;
               end if;

            when others =>
               null;

         end case;

      end loop Scan_The_Line;

      --  There wasn't any comment if we reach this point.
      return 0;
   end Comment_Beginning;


   --------------------
   -- Exp_Name_Image --
   --------------------

   function Exp_Name_Image (Name : Node_Id) return String is
      Prefix_Node   : Node_Id;
      Selector_Node : Node_Id;
   begin
      if Nkind (Name) = N_Identifier or else
         Nkind (Name) = N_Defining_Identifier
      then
         return Identifier_Image (Name);
      end if;

      if Nkind (Name) = N_Defining_Program_Unit_Name then
         Prefix_Node   := Sinfo.Name (Name);
         Selector_Node := Defining_Identifier (Name);
      else
         --  Nkind (Name) = N_Expanded_Name
         Prefix_Node   := Prefix (Name);
         Selector_Node := Selector_Name (Name);
      end if;

      return   Exp_Name_Image (Prefix_Node)
             & '.'
             & Identifier_Image (Selector_Node);
   end Exp_Name_Image;

   -------------------
   -- Get_Character --
   -------------------

   function Get_Character (P : Source_Ptr) return Character is
      Sindex : constant Source_File_Index := Get_Source_File_Index (P);
      Src    : constant Source_Buffer_Ptr := Source_Text (Sindex);
   begin
      return Src (P);
   end Get_Character;

   ------------------
   -- Get_Location --
   ------------------

   function Get_Location (E : Asis.Element) return Source_Ptr is
   begin
      return Sloc (Node (E));
   end Get_Location;

   -------------------------
   -- Get_Num_Literal_End --
   -------------------------

   function Get_Num_Literal_End (P : Source_Ptr) return Source_Ptr is
      Sindex : constant Source_File_Index := Get_Source_File_Index (P);
      Src    : constant Source_Buffer_Ptr := Source_Text (Sindex);
      S      : Source_Ptr;
      B_Char : Character;
   begin
      --  Src (P) is the leading digit of a numeric literal
      S := P + 1;
      loop
         if Is_Hexadecimal_Digit (Src (S)) or else Src (S) = '_' then
            S := S + 1;
         elsif Src (S) = '#' or else Src (S) = ':' then
            --  based literal: 16#E#E1 or 016#offf#
            --  J.2 (3): "The number sign characters (#) of a based_literal
            --  can be replaced by colons (:) provided that the replacement
            --  is done for both occurrences.
            B_Char := Src (S);
            --  and now - looking for trailing '#' or ':':
            S := S + 1;

            while Src (S) /= B_Char loop
               S := S + 1;
            end loop;

            if Src (S + 1) = 'E' or else
               Src (S + 1) = 'e'
            then
               --  this means something like 5#1234.1234#E2
               S := S + 2;
            else
               exit;
            end if;

         elsif Src (S) = '+' or Src (S) = '-' then   -- 12E+34 or 12+34?

            if Src (S - 1) = 'E' or Src (S - 1) = 'e' then
               --  it is the sign of the exponent
               S := S + 1;
            else
               S := S - 1; -- to go back in the literal
               exit;
            end if;

         elsif  Src (S) = '.' then        -- 3.14 or 3..14?

            if Is_Hexadecimal_Digit (Src (S + 1)) then
               S := S + 1;
            else
               S := S - 1; -- to go back in the literal
               exit;
            end if;

         else -- for sure, we already are outside the literal
            S := S - 1; -- to go back in the literal
            exit;
         end if;
      end loop;

      return S;
   end Get_Num_Literal_End;

   --------------------
   -- Get_String_End --
   --------------------

   function Get_String_End (P : Source_Ptr) return Source_Ptr is
      Sindex : constant Source_File_Index := Get_Source_File_Index (P);
      Src    : constant Source_Buffer_Ptr := Source_Text (Sindex);
      S      : Source_Ptr;
      Quote  : Character;
   begin
      --  Src (P) is the leading quotation of the non-nul string constant
      --  which can be either '"' OR '%' (J.2 (2)).
      Quote := Src (P);
      S := P + 1;
      loop

         if Src (S) = Quote and then Src (S + 1) = Quote then
            S := S + 2;
         elsif Src (S) /= Quote then
            S := S + 1;
         else
            --  S points to the trailing quotation of the constant
            exit;
         end if;

      end loop;

      return S;
   end Get_String_End;

   --------------
   -- Get_Word --
   --------------

   function Get_Word
     (P_Start : Source_Ptr;
      P_End   : Source_Ptr)
      return String
   is
      Sindex : constant Source_File_Index := Get_Source_File_Index (P_Start);
      Src    : constant Source_Buffer_Ptr := Source_Text (Sindex);
   begin
      return String (Src (P_Start .. P_End));
   end Get_Word;

   ------------------
   -- Get_Word_End --
   ------------------

   function Get_Word_End
     (P       : Source_Ptr;
      In_Word : In_Word_Condition)
      return Source_Ptr
   is
      S      : Source_Ptr;
   begin
      S := P;
      while In_Word (S + 1) loop
         S := S + 1;
      end loop;
      return S;
   end Get_Word_End;

   ----------------------
   -- Identifier_Image --
   ----------------------

   function Identifier_Image (Ident : Node_Id) return String is
      Image_Start : Source_Ptr;
      Image_End   : Source_Ptr;
   begin
      Image_Start := Sloc (Ident);
      Image_End   := Get_Word_End (P       => Image_Start,
                                    In_Word => In_Identifier'Access);
      return Get_Word (Image_Start, Image_End);
   end Identifier_Image;

   -------------------
   -- In_Identifier --
   -------------------

   function In_Identifier (P : Source_Ptr) return Boolean is
      Sindex : constant Source_File_Index := Get_Source_File_Index (P);
      Src    : constant Source_Buffer_Ptr := Source_Text (Sindex);
      Char   : Character;
      Result : Boolean := True;
   begin
      Char := Src (P);

      if Char = ' '      or else
         Char = '&'      or else
         Char = '''      or else
         Char = '('      or else
         Char = ')'      or else
         Char = '*'      or else
         Char = '+'      or else
         Char = ','      or else
         Char = '-'      or else
         Char = '.'      or else
         Char = '/'      or else
         Char = ':'      or else
         Char = ';'      or else
         Char = '<'      or else
         Char = '='      or else
         Char = '>'      or else
         Char = '|'      or else
         Char = ASCII.LF or else
         Char = ASCII.FF or else
         Char = ASCII.HT or else
         Char = ASCII.VT or else
         Char = ASCII.CR
      then
         Result := False;
      end if;

      return Result;

   end In_Identifier;

   ---------------------
   -- Next_Identifier --
   ---------------------

   function Next_Identifier (P : Source_Ptr) return Source_Ptr is
      Sindex : constant Source_File_Index := Get_Source_File_Index (P);
      Src    : constant Source_Buffer_Ptr := Source_Text (Sindex);
      S      : Source_Ptr;
   begin
      S := P + 1;
      while not Is_Letter (Src (S)) loop

         if Src (S) = '-' and then Src (S + 1) = '-' then
            Skip_Comment (S);
         else
            S := S + 1;
         end if;

      end loop;

      return S;
   end Next_Identifier;

   ---------------------
   -- Number_Of_Lines --
   ---------------------

   function Number_Of_Lines (E : Asis.Element) return Integer is
      SFI : Source_File_Index := Get_Source_File_Index (Get_Location (E));
   begin
--      return Integer (Num_Source_Lines (SFI) + Line_Offset (SFI));
      return Integer (Num_Source_Lines (SFI));
   end Number_Of_Lines;

   --------------------
   -- Operator_Image --
   --------------------

   function Operator_Image (Node : Node_Id) return String is
      S_Start : Source_Ptr := Sloc (Node);
      --  S_Start points to the leading character of a given operator symbol.
      Sindex  : constant Source_File_Index :=
                   Get_Source_File_Index (S_Start);
      Src     : constant Source_Buffer_Ptr := Source_Text (Sindex);
      S_End   : Source_Ptr := S_Start;
      --  should be set as pointing to the last character of a given
      --  operator symbol.
      Ch      : Character;
   begin
      Ch := Src (S_Start);

      if (Ch = 'A' or Ch = 'a'    -- "abs" or "and"
        or Ch = 'M' or Ch = 'm'    -- "mod"
        or Ch = 'N' or Ch = 'n'    -- "not"
        or Ch = 'R' or Ch = 'r'    -- "rem"
        or Ch = 'X' or Ch = 'x')   -- "xor"
      then
         S_End := S_Start + 2;

      elsif (Ch = 'O' or Ch = 'o') then -- "or"
         S_End := S_Start + 1;

      elsif (Ch = '='             -- "="
           or Ch = '+'             -- "+"
           or Ch = '-'             -- "-"
           or Ch = '&')            -- "&"
      then
         S_End := S_Start;

      elsif (Ch = '/'  -- "/=" or "/"?
           or Ch = '<'  -- "<=" or "<"?
           or Ch = '>'  -- ">=" or ">"?
           or Ch = '*') -- "**" or "*"?
      then
         Ch := Src (S_Start + 1);
         if (Ch = '=' or else     -- "/=", "<=" or ">="
              Ch = '*')           -- "**"
         then
            S_End := S_Start + 1;
         else
            S_End := S_Start;
            --  "<", ">", "*" or "/"
         end if;
      end if;

      return (1 => '"') & String (Src (S_Start .. S_End)) & (1 => '"');
   end Operator_Image;

   -------------------------
   -- Rightmost_Non_Blank --
   -------------------------

   function Rightmost_Non_Blank (P : Source_Ptr) return Source_Ptr is
      S : Source_Ptr := P;
      Sindex : constant Source_File_Index := Get_Source_File_Index (P);
      Src    : constant Source_Buffer_Ptr := Source_Text (Sindex);
   begin
      loop
         if Src (S) = '-' and then Src (S + 1) = '-' then
            Skip_Comment (S);
         elsif Is_Graphic (Src (S)) and then Src (S) /= ' ' then
            exit;
         else
            S := S + 1;
         end if;
      end loop;
      return S;
   end Rightmost_Non_Blank;

   ------------------------------
   -- Search_Beginning_Of_Word --
   ------------------------------


   function Search_Beginning_Of_Word (S : Source_Ptr) return Source_Ptr is
      SFI : constant Source_File_Index := Get_Source_File_Index (S);
      Src : constant Source_Buffer_Ptr := Source_Text (SFI);
      S_P : Source_Ptr;

   begin
      S_P := S;
      while S_P >= Source_First (SFI)
        and then (Src (S_P) in 'A' .. 'Z' or else
                  Src (S_P) in 'a' .. 'z' or else
                  Src (S_P) in '0' .. '9' or else
                  Src (S_P) = '_')
      loop
         S_P := S_P - 1;
      end loop;

      return S_P + 1;
   end Search_Beginning_Of_Word;

   ------------------------
   -- Search_End_Of_Word --
   ------------------------

   function Search_End_Of_Word (S : Source_Ptr) return Source_Ptr is
      S_P  : Source_Ptr        := S;
      SFI  : Source_File_Index := Get_Source_File_Index (S);
      Src  : Source_Buffer_Ptr := Source_Text (SFI);
      Char : Character;
   begin

      Char := Src (S_P);

      while not (Char = ' '      or else
                 Char = '&'      or else
                 Char = '''      or else
                 Char = '('      or else
                 Char = ')'      or else
                 Char = '*'      or else
                 Char = '+'      or else
                 Char = ','      or else
                 Char = '-'      or else
                 Char = '.'      or else
                 Char = '/'      or else
                 Char = ':'      or else
                 Char = ';'      or else
                 Char = '<'      or else
                 Char = '='      or else
                 Char = '>'      or else
                 Char = '|'      or else
                 Char = ASCII.LF or else
                 Char = ASCII.FF or else
                 Char = ASCII.HT or else
                 Char = ASCII.VT or else
                 Char = ASCII.CR)
      loop
         S_P := S_P + 1;
         Char := Src (S_P);
      end loop;

      S_P := S_P - 1;

      return S_P;

   end Search_End_Of_Word;

   -----------------------------
   -- Search_Left_Parenthesis --
   -----------------------------

   function Search_Left_Parenthesis (S : Source_Ptr) return Source_Ptr is
      S_P : Source_Ptr        := S - 1;
      SFI : Source_File_Index := Get_Source_File_Index (S);
      Src : Source_Buffer_Ptr := Source_Text (SFI);
   begin
      loop
         case Src (S_P) is
            when  '(' =>
               return  S_P;
            when  CR | LF   =>
               declare
                  TempS : Source_Ptr := Line_Start (S_P);
               begin
                  while (Src (TempS) /= '-' or else
                          Src (TempS + 1) /= '-')
                     and then
                          TempS < S_P
                  loop
                     TempS := TempS + 1;
                  end loop;
                  S_P := TempS - 1;
               end;

            when others =>
               S_P := S_P - 1;
         end case;
      end loop;
   end Search_Left_Parenthesis;

   ----------------------
   -- Search_Next_Word --
   ----------------------

   function Search_Next_Word (S : Source_Ptr) return Source_Ptr is
      S_P : Source_Ptr        := S + 1;
      SFI : Source_File_Index := Get_Source_File_Index (S);
      Src : Source_Buffer_Ptr := Source_Text (SFI);
   begin
      loop
         case Src (S_P) is
            when  ' ' | HT | CR | LF =>
               S_P := S_P + 1;
            when  '-' =>
               if Src (S_P + 1) = '-' then
                  Skip_Comment (S_P);
               else
                  return S_P;
               end if;
            when others  =>
               return S_P;
         end case;
      end loop;
   end Search_Next_Word;

   ----------------------
   -- Search_Prev_Word --
   ----------------------

   function Search_Prev_Word (S : Source_Ptr) return Source_Ptr is
      S_P : Source_Ptr        := S - 1;
      SFI : Source_File_Index := Get_Source_File_Index (S);
      Src : Source_Buffer_Ptr := Source_Text (SFI);
   begin
      loop
         case Src (S_P) is
            when  ' ' | HT  =>
               S_P := S_P - 1;
            when  CR | LF   =>
               declare
                  TempS : Source_Ptr := Line_Start (S_P);
               begin
                  while (Src (TempS) /= '-' or else
                          Src (TempS + 1) /= '-')
                       and then
                          TempS < S_P
                  loop
                     TempS := TempS + 1;
                  end loop;
                  S_P := TempS - 1;
               end;
            when others  =>
               return S_P;
         end case;
      end loop;
   end Search_Prev_Word;

   ----------------------------
   -- Search_Prev_Word_Start --
   ----------------------------

   function Search_Prev_Word_Start (S : Source_Ptr) return Source_Ptr is
   begin
      return Search_Beginning_Of_Word (Search_Prev_Word (S));
   end Search_Prev_Word_Start;

   -----------------------------
   -- Search_Rightmost_Symbol --
   -----------------------------

   function Search_Rightmost_Symbol
     (P    : Source_Ptr;
      Char : Character := ';')
      return Source_Ptr
   is
      S      : Source_Ptr := P;
      --  the location to be returned, the search is started from P
      Sindex : constant Source_File_Index := Get_Source_File_Index (P);
      Src    : constant Source_Buffer_Ptr := Source_Text (Sindex);
   begin
      while Src (S) /= Char loop

         if Src (S) = '-' and then Src (S + 1) = '-' then
            Skip_Comment (S);

         elsif (Src (S) = '"' or else Src (S) = '%')
             and then
               not (Src (S - 1) = ''' and then Src (S + 1) = ''')
         then
            Skip_String (S);

         else
            S := S + 1;
         end if;

      end loop;

      return S;
   end Search_Rightmost_Symbol;

   -----------------
   -- Skip_String --
   -----------------

   procedure Skip_String (P : in out Source_Ptr)  is
      Sindex : constant Source_File_Index := Get_Source_File_Index (P);
      Src    : constant Source_Buffer_Ptr := Source_Text (Sindex);
      Quoter : Character := Src (P);
   begin
      --  we are in the beginning of a legal string literal in a legal
      --  Ada program. So we do not have to be careful with all
      --  the checks:
      while not (Src (P) = Quoter and then Src (P + 1) /= Quoter) loop
         P := P + 1;
      end loop;
      P := P + 1;
   end Skip_String;

   ------------------
   -- Skip_Comment --
   ------------------

   procedure Skip_Comment (P : in out Source_Ptr) is
      Sindex : constant Source_File_Index := Get_Source_File_Index (P);
      Src    : constant Source_Buffer_Ptr := Source_Text (Sindex);
   begin
      if Src (P) = '-' and then Src (P + 1) = '-' then
         P := P + 2;
         while not (Src (P) = VT or else
                    Src (P) = CR or else
                    Src (P) = LF or else
                    Src (P) = FF)
         loop
            P := P + 1;
         end loop;
      end if;
   end Skip_Comment;

   ------------------------------
   -- Source_Locations_To_Span --
   ------------------------------

   function Source_Locations_To_Span
     (Span_Beg : Source_Ptr;
      Span_End : Source_Ptr)
      return Span
   is
      Sp : Span;
   begin
      Sp.First_Line   := Line_Number (Get_Physical_Line_Number   (Span_Beg));
      Sp.First_Column := Character_Position (A_Get_Column_Number (Span_Beg));
      Sp.Last_Line    := Line_Number (Get_Physical_Line_Number   (Span_End));
      Sp.Last_Column  := Character_Position (A_Get_Column_Number (Span_End));

      return Sp;
   end Source_Locations_To_Span;

   ------------------
   -- String_Image --
   ------------------

   function String_Image (Node : Node_Id) return String is
      S_Start : Source_Ptr := Sloc (Node);
      --  S_Start points to the leading quote of a given string literal.
      Sindex  : constant Source_File_Index :=
                   Get_Source_File_Index (S_Start);
      Src     : constant Source_Buffer_Ptr := Source_Text (Sindex);
      S_End   : Source_Ptr := S_Start + 1;
      --  should be set as pointing to the last character of a
      --  string literal; empty and  non-empty literals are processed
      --  in the same way - we simply take a literal as it is from the
      --  Source Buffer
      Quote  : Character := Src (S_Start);
      --  Quoter may be '"' or '%'!
   begin
      loop
         if Src (S_End)     = Quote and then
            Src (S_End + 1) = Quote
         then
            --  doubled string quote as an element of a given string
            S_End := S_End + 2;
         elsif Src (S_End)  /= Quote then
            --  "usial" string element
            S_End := S_End + 1;
         else
            --  S_End points to the trailing quote of a given string
            exit;
         end if;
      end loop;

      return String (Src (S_Start .. S_End));

   end String_Image;

end A4G.A_Sinput;
