New Language: Ada

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@45959 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 659 insertions, 0 deletions

diff --git a/gcc/ada/sfn_scan.adb b/gcc/ada/sfn_scan.adb
new file mode 100644
index 00000000000..57bc534f582
--- /dev/null
+++ b/gcc/ada/sfn_scan.adb
@@ -0,0 +1,659 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                             S F N _ S C A N                              --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.6 $
+--                                                                          --
+--          Copyright (C) 2000-2001 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 2,  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.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with 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.                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+with Ada.Exceptions; use Ada.Exceptions;
+
+package body SFN_Scan is
+
+   use ASCII;
+   --  Allow easy access to control character definitions
+
+   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_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_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
+      return P > S'Last;
+   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
+
+      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") 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);
+
+                  begin
+                     Require_Token (")");
+                     Require_Token (";");
+                     SFN_Ptr.all (Typ, U, F);
+                  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 successfuly 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 ("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;