Subversion Repositories openrisc

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             S F N _ S C A N                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 2000-2010, Free Software Foundation, Inc.         --
--                                                                          --
-- 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 Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------
 
with Ada.Exceptions; use Ada.Exceptions;
 
package body SFN_Scan is
 
   use ASCII;
   --  Allow easy access to control character definitions
 
   EOF : constant Character := ASCII.SUB;
   --  The character SUB (16#1A#) is used in DOS-derived systems, such as
   --  Windows to signal the end of a text file. If this character appears as
   --  the last character of a file scanned by a call to Scan_SFN_Pragmas, then
   --  it is ignored, otherwise it is treated as an illegal character.
 
   type String_Ptr is access String;
 
   S : String_Ptr;
   --  Points to the gnat.adc input file
 
   P : Natural;
   --  Subscript of next character to process in S
 
   Line_Num : Natural;
   --  Current line number
 
   Start_Of_Line : Natural;
   --  Subscript of first character at start of current line
 
   ----------------------
   -- Local Procedures --
   ----------------------
 
   function Acquire_Integer return Natural;
   --  This function skips white space, and then scans and returns
   --  an unsigned integer. Raises Error if no integer is present
   --  or if the integer is greater than 999.
 
   function Acquire_String (B : Natural; E : Natural) return String;
   --  This function takes a string scanned out by Scan_String, strips
   --  the enclosing quote characters and any internal doubled quote
   --  characters, and returns the result as a String. The arguments
   --  B and E are as returned from a call to Scan_String. The lower
   --  bound of the string returned is always 1.
 
   function Acquire_Unit_Name return String;
   --  Skips white space, and then scans and returns a unit name. The
   --  unit name is cased exactly as it appears in the source file.
   --  The terminating character must be white space, or a comma or
   --  a right parenthesis or end of file.
 
   function At_EOF return Boolean;
   pragma Inline (At_EOF);
   --  Returns True if at end of file, False if not. Note that this
   --  function does NOT skip white space, so P is always unchanged.
 
   procedure Check_Not_At_EOF;
   pragma Inline (Check_Not_At_EOF);
   --  Skips past white space if any, and then raises Error if at
   --  end of file. Otherwise returns with P skipped past whitespace.
 
   function Check_File_Type return Character;
   --  Skips white space if any, and then looks for any of the tokens
   --  Spec_File_Name, Body_File_Name, or Subunit_File_Name. If one
   --  of these is found then the value returned is 's', 'b' or 'u'
   --  respectively, and P is bumped past the token. If none of
   --  these tokens is found, then P is unchanged (except for
   --  possible skip of white space), and a space is returned.
 
   function Check_Token (T : String) return Boolean;
   --  Skips white space if any, and then checks if the string at the
   --  current location matches the given string T, and the character
   --  immediately following is non-alphabetic, non-numeric. If so,
   --  P is stepped past the token, and True is returned. If not,
   --  P is unchanged (except for possibly skipping past whitespace),
   --  and False is returned. S may contain only lower-case letters
   --  ('a' .. 'z').
 
   procedure Error (Err : String);
   --  Called if an error is detected. Raises Syntax_Error_In_GNAT_ADC
   --  with a message of the form gnat.adc:line:col: xxx, where xxx is
   --  the string Err passed as a parameter.
 
   procedure Require_Token (T : String);
   --  Skips white space if any, and then requires the given string
   --  to be present. If it is, the P is stepped past it, otherwise
   --  Error is raised, since this is a syntax error. Require_Token
   --  is used only for sequences of special characters, so there
   --  is no issue of terminators, or casing of letters.
 
   procedure Scan_String (B : out Natural; E : out Natural);
   --  Skips white space if any, then requires that a double quote
   --  or percent be present (start of string). Raises error if
   --  neither of these two characters is found. Otherwise scans
   --  out the string, and returns with P pointing past the
   --  closing quote and S (B .. E) contains the characters of the
   --  string (including the enclosing quotes, with internal quotes
   --  still doubled). Raises Error if the string is malformed.
 
   procedure Skip_WS;
   --  Skips P past any white space characters (end of line
   --  characters, spaces, comments, horizontal tab characters).
 
   ---------------------
   -- Acquire_Integer --
   ---------------------
 
   function Acquire_Integer return Natural is
      N : Natural := 0;
 
   begin
      Skip_WS;
 
      if S (P) not in '0' .. '9' then
         Error ("missing index parameter");
      end if;
 
      while S (P) in '0' .. '9' loop
         N := N * 10 + Character'Pos (S (P)) - Character'Pos ('0');
 
         if N > 999 then
            Error ("index value greater than 999");
         end if;
 
         P := P + 1;
      end loop;
 
      return N;
   end Acquire_Integer;
 
   --------------------
   -- Acquire_String --
   --------------------
 
   function Acquire_String (B : Natural; E : Natural) return String is
      Str : String (1 .. E - B - 1);
      Q   : constant Character := S (B);
      J   : Natural;
      Ptr : Natural;
 
   begin
      Ptr := B + 1;
      J := 0;
      while Ptr < E loop
         J := J + 1;
         Str (J) := S (Ptr);
 
         if S (Ptr) = Q and then S (Ptr + 1) = Q then
            Ptr := Ptr + 2;
         else
            Ptr := Ptr + 1;
         end if;
      end loop;
 
      return Str (1 .. J);
   end Acquire_String;
 
   -----------------------
   -- Acquire_Unit_Name --
   -----------------------
 
   function Acquire_Unit_Name return String is
      B : Natural;
 
   begin
      Check_Not_At_EOF;
      B := P;
 
      while not At_EOF loop
         exit when S (P) not in '0' .. '9'
           and then S (P) /= '.'
           and then S (P) /= '_'
           and then not (S (P) = '[' and then S (P + 1) = '"')
           and then not (S (P) = '"' and then S (P - 1) = '[')
           and then not (S (P) = '"' and then S (P + 1) = ']')
           and then not (S (P) = ']' and then S (P - 1) = '"')
           and then S (P) < 'A';
         P := P + 1;
      end loop;
 
      if P = B then
         Error ("null unit name");
      end if;
 
      return S (B .. P - 1);
   end Acquire_Unit_Name;
 
   ------------
   -- At_EOF --
   ------------
 
   function At_EOF return Boolean is
   begin
      --  Immediate return (False) if before last character of file
 
      if P < S'Last then
         return False;
 
      --  Special case: DOS EOF character as last character of file is
      --  allowed and treated as an end of file.
 
      elsif P = S'Last then
         return S (P) = EOF;
 
      --  If beyond last character of file, then definitely at EOF
 
      else
         return True;
      end if;
   end At_EOF;
 
   ---------------------
   -- Check_File_Type --
   ---------------------
 
   function Check_File_Type return Character is
   begin
      if Check_Token ("spec_file_name") then
         return 's';
      elsif Check_Token ("body_file_name") then
         return 'b';
      elsif Check_Token ("subunit_file_name") then
         return 'u';
      else
         return ' ';
      end if;
   end Check_File_Type;
 
   ----------------------
   -- Check_Not_At_EOF --
   ----------------------
 
   procedure Check_Not_At_EOF is
   begin
      Skip_WS;
 
      if At_EOF then
         Error ("unexpected end of file");
      end if;
 
      return;
   end Check_Not_At_EOF;
 
   -----------------
   -- Check_Token --
   -----------------
 
   function Check_Token (T : String) return Boolean is
      Save_P : Natural;
      C : Character;
 
   begin
      Skip_WS;
      Save_P := P;
 
      for K in T'Range loop
         if At_EOF then
            P := Save_P;
            return False;
         end if;
 
         C := S (P);
 
         if C in 'A' .. 'Z' then
            C := Character'Val (Character'Pos (C) +
                                 (Character'Pos ('a') - Character'Pos ('A')));
         end if;
 
         if C /= T (K) then
            P := Save_P;
            return False;
         end if;
 
         P := P + 1;
      end loop;
 
      if At_EOF then
         return True;
      end if;
 
      C := S (P);
 
      if C in '0' .. '9'
        or else C in 'a' .. 'z'
        or else C in 'A' .. 'Z'
        or else C > Character'Val (127)
      then
         P := Save_P;
         return False;
 
      else
         return True;
      end if;
   end Check_Token;
 
   -----------
   -- Error --
   -----------
 
   procedure Error (Err : String) is
      C : Natural := 0;
      --  Column number
 
      M : String (1 .. 80);
      --  Buffer used to build resulting error msg
 
      LM : Natural := 0;
      --  Pointer to last set location in M
 
      procedure Add_Nat (N : Natural);
      --  Add chars of integer to error msg buffer
 
      -------------
      -- Add_Nat --
      -------------
 
      procedure Add_Nat (N : Natural) is
      begin
         if N > 9 then
            Add_Nat (N / 10);
         end if;
 
         LM := LM + 1;
         M (LM) := Character'Val (N mod 10 + Character'Pos ('0'));
      end Add_Nat;
 
   --  Start of processing for Error
 
   begin
      M (1 .. 9) := "gnat.adc:";
      LM := 9;
      Add_Nat (Line_Num);
      LM := LM + 1;
      M (LM) := ':';
 
      --  Determine column number
 
      for X in Start_Of_Line .. P loop
         C := C + 1;
 
         if S (X) = HT then
            C := (C + 7) / 8 * 8;
         end if;
      end loop;
 
      Add_Nat (C);
      M (LM + 1) := ':';
      LM := LM + 1;
      M (LM + 1) := ' ';
      LM := LM + 1;
 
      M (LM + 1 .. LM + Err'Length) := Err;
      LM := LM + Err'Length;
 
      Raise_Exception (Syntax_Error_In_GNAT_ADC'Identity, M (1 .. LM));
   end Error;
 
   -------------------
   -- Require_Token --
   -------------------
 
   procedure Require_Token (T : String) is
      SaveP : Natural;
 
   begin
      Skip_WS;
      SaveP := P;
 
      for J in T'Range loop
 
         if At_EOF or else S (P) /= T (J) then
            declare
               S : String (1 .. T'Length + 10);
 
            begin
               S (1 .. 9) := "missing """;
               S (10 .. T'Length + 9) := T;
               S (T'Length + 10) := '"';
               P := SaveP;
               Error (S);
            end;
 
         else
            P := P + 1;
         end if;
      end loop;
   end Require_Token;
 
   ----------------------
   -- Scan_SFN_Pragmas --
   ----------------------
 
   procedure Scan_SFN_Pragmas
     (Source   : String;
      SFN_Ptr  : Set_File_Name_Ptr;
      SFNP_Ptr : Set_File_Name_Pattern_Ptr)
   is
      B, E : Natural;
      Typ  : Character;
      Cas  : Character;
 
   begin
      Line_Num := 1;
      S := Source'Unrestricted_Access;
      P := Source'First;
      Start_Of_Line := P;
 
      --  Loop through pragmas in file
 
      Main_Scan_Loop : loop
         Skip_WS;
         exit Main_Scan_Loop when At_EOF;
 
         --  Error if something other than pragma
 
         if not Check_Token ("pragma") then
            Error ("non pragma encountered");
         end if;
 
         --  Source_File_Name pragma case
 
         if Check_Token ("source_file_name")
              or else
             Check_Token ("source_file_name_project")
         then
            Require_Token ("(");
 
            Typ := Check_File_Type;
 
            --  First format, with unit name first
 
            if Typ = ' ' then
               if Check_Token ("unit_name") then
                  Require_Token ("=>");
               end if;
 
               declare
                  U : constant String := Acquire_Unit_Name;
 
               begin
                  Require_Token (",");
                  Typ := Check_File_Type;
 
                  if Typ /= 's' and then Typ /= 'b' then
                     Error ("bad pragma");
                  end if;
 
                  Require_Token ("=>");
                  Scan_String (B, E);
 
                  declare
                     F : constant String := Acquire_String (B, E);
                     X : Natural;
 
                  begin
                     --  Scan Index parameter if present
 
                     if Check_Token (",") then
                        if Check_Token ("index") then
                           Require_Token ("=>");
                        end if;
 
                        X := Acquire_Integer;
                     else
                        X := 0;
                     end if;
 
                     Require_Token (")");
                     Require_Token (";");
                     SFN_Ptr.all (Typ, U, F, X);
                  end;
               end;
 
            --  Second format with pattern string
 
            else
               Require_Token ("=>");
               Scan_String (B, E);
 
               declare
                  Pat : constant String := Acquire_String (B, E);
                  Nas : Natural := 0;
 
               begin
                  --  Check exactly one asterisk
 
                  for J in Pat'Range loop
                     if Pat (J) = '*' then
                        Nas := Nas + 1;
                     end if;
                  end loop;
 
                  if Nas /= 1 then
                     Error ("** not allowed");
                  end if;
 
                  B := 0;
                  E := 0;
                  Cas := ' ';
 
                  --  Loop to scan out Casing or Dot_Replacement parameters
 
                  loop
                     Check_Not_At_EOF;
                     exit when S (P) = ')';
                     Require_Token (",");
 
                     if Check_Token ("casing") then
                        Require_Token ("=>");
 
                        if Cas /= ' ' then
                           Error ("duplicate casing argument");
                        elsif Check_Token ("lowercase") then
                           Cas := 'l';
                        elsif Check_Token ("uppercase") then
                           Cas := 'u';
                        elsif Check_Token ("mixedcase") then
                           Cas := 'm';
                        else
                           Error ("invalid casing argument");
                        end if;
 
                     elsif Check_Token ("dot_replacement") then
                        Require_Token ("=>");
 
                        if E /= 0 then
                           Error ("duplicate dot_replacement");
                        else
                           Scan_String (B, E);
                        end if;
 
                     else
                        Error ("invalid argument");
                     end if;
                  end loop;
 
                  Require_Token (")");
                  Require_Token (";");
 
                  if Cas = ' ' then
                     Cas := 'l';
                  end if;
 
                  if E = 0 then
                     SFNP_Ptr.all (Pat, Typ, ".", Cas);
 
                  else
                     declare
                        Dot : constant String := Acquire_String (B, E);
 
                     begin
                        SFNP_Ptr.all (Pat, Typ, Dot, Cas);
                     end;
                  end if;
               end;
            end if;
 
         --  Some other pragma, scan to semicolon at end of pragma
 
         else
            Skip_Loop : loop
               exit Main_Scan_Loop when At_EOF;
               exit Skip_Loop when S (P) = ';';
 
               if S (P) = '"' or else S (P) = '%' then
                  Scan_String (B, E);
               else
                  P := P + 1;
               end if;
            end loop Skip_Loop;
 
            --  We successfully skipped to semicolon, so skip past it
 
            P := P + 1;
         end if;
      end loop Main_Scan_Loop;
 
   exception
      when others =>
         Cursor := P - S'First + 1;
         raise;
   end Scan_SFN_Pragmas;
 
   -----------------
   -- Scan_String --
   -----------------
 
   procedure Scan_String (B : out Natural; E : out Natural) is
      Q : Character;
 
   begin
      Check_Not_At_EOF;
 
      if S (P) = '"' then
         Q := '"';
      elsif S (P) = '%' then
         Q := '%';
      else
         Error ("bad string");
         Q := '"';
      end if;
 
      --  Scan out the string, B points to first char
 
      B := P;
      P := P + 1;
 
      loop
         if At_EOF or else S (P) = LF or else S (P) = CR then
            Error -- CODEFIX
              ("missing string quote");
 
         elsif S (P) = HT then
            Error ("tab character in string");
 
         elsif S (P) /= Q then
            P := P + 1;
 
         --  We have a quote
 
         else
            P := P + 1;
 
            --  Check for doubled quote
 
            if not At_EOF and then S (P) = Q then
               P := P + 1;
 
            --  Otherwise this is the terminating quote
 
            else
               E := P - 1;
               return;
            end if;
         end if;
      end loop;
   end Scan_String;
 
   -------------
   -- Skip_WS --
   -------------
 
   procedure Skip_WS is
   begin
      WS_Scan : while not At_EOF loop
         case S (P) is
 
            --  End of physical line
 
            when CR | LF =>
               Line_Num := Line_Num + 1;
               P := P + 1;
 
               while not At_EOF
                 and then (S (P) = CR or else S (P) = LF)
               loop
                  Line_Num := Line_Num + 1;
                  P := P + 1;
               end loop;
 
               Start_Of_Line := P;
 
            --  All other cases of white space characters
 
            when ' ' | FF | VT | HT =>
               P := P + 1;
 
            --  Comment
 
            when '-' =>
               P := P + 1;
 
               if At_EOF then
                  Error ("bad comment");
 
               elsif S (P) = '-' then
                  P := P + 1;
 
                  while not At_EOF loop
                     case S (P) is
                        when CR | LF | FF | VT =>
                           exit;
                        when others =>
                           P := P + 1;
                     end case;
                  end loop;
 
               else
                  P := P - 1;
                  exit WS_Scan;
               end if;
 
            when others =>
               exit WS_Scan;
 
         end case;
      end loop WS_Scan;
   end Skip_WS;
 
end SFN_Scan;