URL https://opencores.org/ocsvn/scarts/scarts/trunk

Subversion Repositories scarts

[/] [scarts/] [trunk/] [toolchain/] [scarts-gcc/] [gcc-4.1.1/] [gcc/] [ada/] [sfn_scan.adb] - Blame information for rev 20

Go to most recent revision | Details | Compare with Previous | View Log


------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                             S F N _ S C A N                              --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 2000-2005, 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,  51  Franklin  Street,  Fifth  Floor, --
-- Boston, MA 02110-1301, 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. --
-- 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 and other systems derived
   --  from DOS (OS/2, NT etc) 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 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;

Browse

Tools

Subversion Repositories scarts

[/] [scarts/] [trunk/] [toolchain/] [scarts-gcc/] [gcc-4.1.1/] [gcc/] [ada/] [sfn_scan.adb] - Blame information for rev 20

Line No.	Rev	Author	Line
1	12	jlechner	`------------------------------------------------------------------------------`
2			`-- --`
3			`-- GNAT COMPILER COMPONENTS --`
4			`-- --`
5			`-- S F N _ S C A N --`
6			`-- --`
7			`-- B o d y --`
8			`-- --`
9			`-- Copyright (C) 2000-2005, Free Software Foundation, Inc. --`
10			`-- --`
11			`-- GNAT is free software; you can redistribute it and/or modify it under --`
12			`-- terms of the GNU General Public License as published by the Free Soft- --`
13			`-- ware Foundation; either version 2, or (at your option) any later ver- --`
14			`-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --`
15			`-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --`
16			`-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --`
17			`-- for more details. You should have received a copy of the GNU General --`
18			`-- Public License distributed with GNAT; see file COPYING. If not, write --`
19			`-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --`
20			`-- Boston, MA 02110-1301, USA. --`
21			`-- --`
22			`-- As a special exception, if other files instantiate generics from this --`
23			`-- unit, or you link this unit with other files to produce an executable, --`
24			`-- this unit does not by itself cause the resulting executable to be --`
25			`-- covered by the GNU General Public License. This exception does not --`
26			`-- however invalidate any other reasons why the executable file might be --`
27			`-- covered by the GNU Public License. --`
28			`-- --`
29			`-- GNAT was originally developed by the GNAT team at New York University. --`
30			`-- Extensive contributions were provided by Ada Core Technologies Inc. --`
31			`-- --`
32			`------------------------------------------------------------------------------`
33
34			`with Ada.Exceptions; use Ada.Exceptions;`
35
36			`package body SFN_Scan is`
37
38			`use ASCII;`
39			`-- Allow easy access to control character definitions`
40
41			`EOF : constant Character := ASCII.SUB;`
42			`-- The character SUB (16#1A#) is used in DOS and other systems derived`
43			`-- from DOS (OS/2, NT etc) to signal the end of a text file. If this`
44			`-- character appears as the last character of a file scanned by a call`
45			`-- to Scan_SFN_Pragmas, then it is ignored, otherwise it is treated as`
46			`-- an illegal character.`
47
48			`type String_Ptr is access String;`
49
50			`S : String_Ptr;`
51			`-- Points to the gnat.adc input file`
52
53			`P : Natural;`
54			`-- Subscript of next character to process in S`
55
56			`Line_Num : Natural;`
57			`-- Current line number`
58
59			`Start_Of_Line : Natural;`
60			`-- Subscript of first character at start of current line`
61
62			`----------------------`
63			`-- Local Procedures --`
64			`----------------------`
65
66			`function Acquire_Integer return Natural;`
67			`-- This function skips white space, and then scans and returns`
68			`-- an unsigned integer. Raises Error if no integer is present`
69			`-- or if the integer is greater than 999.`
70
71			`function Acquire_String (B : Natural; E : Natural) return String;`
72			`-- This function takes a string scanned out by Scan_String, strips`
73			`-- the enclosing quote characters and any internal doubled quote`
74			`-- characters, and returns the result as a String. The arguments`
75			`-- B and E are as returned from a call to Scan_String. The lower`
76			`-- bound of the string returned is always 1.`
77
78			`function Acquire_Unit_Name return String;`
79			`-- Skips white space, and then scans and returns a unit name. The`
80			`-- unit name is cased exactly as it appears in the source file.`
81			`-- The terminating character must be white space, or a comma or`
82			`-- a right parenthesis or end of file.`
83
84			`function At_EOF return Boolean;`
85			`pragma Inline (At_EOF);`
86			`-- Returns True if at end of file, False if not. Note that this`
87			`-- function does NOT skip white space, so P is always unchanged.`
88
89			`procedure Check_Not_At_EOF;`
90			`pragma Inline (Check_Not_At_EOF);`
91			`-- Skips past white space if any, and then raises Error if at`
92			`-- end of file. Otherwise returns with P skipped past whitespace.`
93
94			`function Check_File_Type return Character;`
95			`-- Skips white space if any, and then looks for any of the tokens`
96			`-- Spec_File_Name, Body_File_Name, or Subunit_File_Name. If one`
97			`-- of these is found then the value returned is 's', 'b' or 'u'`
98			`-- respectively, and P is bumped past the token. If none of`
99			`-- these tokens is found, then P is unchanged (except for`
100			`-- possible skip of white space), and a space is returned.`
101
102			`function Check_Token (T : String) return Boolean;`
103			`-- Skips white space if any, and then checks if the string at the`
104			`-- current location matches the given string T, and the character`
105			`-- immediately following is non-alphabetic, non-numeric. If so,`
106			`-- P is stepped past the token, and True is returned. If not,`
107			`-- P is unchanged (except for possibly skipping past whitespace),`
108			`-- and False is returned. S may contain only lower-case letters`
109			`-- ('a' .. 'z').`
110
111			`procedure Error (Err : String);`
112			`-- Called if an error is detected. Raises Syntax_Error_In_GNAT_ADC`
113			`-- with a message of the form gnat.adc:line:col: xxx, where xxx is`
114			`-- the string Err passed as a parameter.`
115
116			`procedure Require_Token (T : String);`
117			`-- Skips white space if any, and then requires the given string`
118			`-- to be present. If it is, the P is stepped past it, otherwise`
119			`-- Error is raised, since this is a syntax error. Require_Token`
120			`-- is used only for sequences of special characters, so there`
121			`-- is no issue of terminators, or casing of letters.`
122
123			`procedure Scan_String (B : out Natural; E : out Natural);`
124			`-- Skips white space if any, then requires that a double quote`
125			`-- or percent be present (start of string). Raises error if`
126			`-- neither of these two characters is found. Otherwise scans`
127			`-- out the string, and returns with P pointing past the`
128			`-- closing quote and S (B .. E) contains the characters of the`
129			`-- string (including the enclosing quotes, with internal quotes`
130			`-- still doubled). Raises Error if the string is malformed.`
131
132			`procedure Skip_WS;`
133			`-- Skips P past any white space characters (end of line`
134			`-- characters, spaces, comments, horizontal tab characters).`
135
136			`---------------------`
137			`-- Acquire_Integer --`
138			`---------------------`
139
140			`function Acquire_Integer return Natural is`
141			`N : Natural := 0;`
142
143			`begin`
144			`Skip_WS;`
145
146			`if S (P) not in '0' .. '9' then`
147			`Error ("missing index parameter");`
148			`end if;`
149
150			`while S (P) in '0' .. '9' loop`
151			`N := N * 10 + Character'Pos (S (P)) - Character'Pos ('0');`
152
153			`if N > 999 then`
154			`Error ("index value greater than 999");`
155			`end if;`
156
157			`P := P + 1;`
158			`end loop;`
159
160			`return N;`
161			`end Acquire_Integer;`
162
163			`--------------------`
164			`-- Acquire_String --`
165			`--------------------`
166
167			`function Acquire_String (B : Natural; E : Natural) return String is`
168			`Str : String (1 .. E - B - 1);`
169			`Q : constant Character := S (B);`
170			`J : Natural;`
171			`Ptr : Natural;`
172
173			`begin`
174			`Ptr := B + 1;`
175			`J := 0;`
176			`while Ptr < E loop`
177			`J := J + 1;`
178			`Str (J) := S (Ptr);`
179
180			`if S (Ptr) = Q and then S (Ptr + 1) = Q then`
181			`Ptr := Ptr + 2;`
182			`else`
183			`Ptr := Ptr + 1;`
184			`end if;`
185			`end loop;`
186
187			`return Str (1 .. J);`
188			`end Acquire_String;`
189
190			`-----------------------`
191			`-- Acquire_Unit_Name --`
192			`-----------------------`
193
194			`function Acquire_Unit_Name return String is`
195			`B : Natural;`
196
197			`begin`
198			`Check_Not_At_EOF;`
199			`B := P;`
200
201			`while not At_EOF loop`
202			`exit when S (P) not in '0' .. '9'`
203			`and then S (P) /= '.'`
204			`and then S (P) /= '_'`
205			`and then not (S (P) = '[' and then S (P + 1) = '"')`
206			`and then not (S (P) = '"' and then S (P - 1) = '[')`
207			`and then not (S (P) = '"' and then S (P + 1) = ']')`
208			`and then not (S (P) = ']' and then S (P - 1) = '"')`
209			`and then S (P) < 'A';`
210			`P := P + 1;`
211			`end loop;`
212
213			`if P = B then`
214			`Error ("null unit name");`
215			`end if;`
216
217			`return S (B .. P - 1);`
218			`end Acquire_Unit_Name;`
219
220			`------------`
221			`-- At_EOF --`
222			`------------`
223
224			`function At_EOF return Boolean is`
225			`begin`
226			`-- Immediate return (False) if before last character of file`
227
228			`if P < S'Last then`
229			`return False;`
230
231			`-- Special case: DOS EOF character as last character of file is`
232			`-- allowed and treated as an end of file.`
233
234			`elsif P = S'Last then`
235			`return S (P) = EOF;`
236
237			`-- If beyond last character of file, then definitely at EOF`
238
239			`else`
240			`return True;`
241			`end if;`
242			`end At_EOF;`
243
244			`---------------------`
245			`-- Check_File_Type --`
246			`---------------------`
247
248			`function Check_File_Type return Character is`
249			`begin`
250			`if Check_Token ("spec_file_name") then`
251			`return 's';`
252			`elsif Check_Token ("body_file_name") then`
253			`return 'b';`
254			`elsif Check_Token ("subunit_file_name") then`
255			`return 'u';`
256			`else`
257			`return ' ';`
258			`end if;`
259			`end Check_File_Type;`
260
261			`----------------------`
262			`-- Check_Not_At_EOF --`
263			`----------------------`
264
265			`procedure Check_Not_At_EOF is`
266			`begin`
267			`Skip_WS;`
268
269			`if At_EOF then`
270			`Error ("unexpected end of file");`
271			`end if;`
272
273			`return;`
274			`end Check_Not_At_EOF;`
275
276			`-----------------`
277			`-- Check_Token --`
278			`-----------------`
279
280			`function Check_Token (T : String) return Boolean is`
281			`Save_P : Natural;`
282			`C : Character;`
283
284			`begin`
285			`Skip_WS;`
286			`Save_P := P;`
287
288			`for K in T'Range loop`
289			`if At_EOF then`
290			`P := Save_P;`
291			`return False;`
292			`end if;`
293
294			`C := S (P);`
295
296			`if C in 'A' .. 'Z' then`
297			`C := Character'Val (Character'Pos (C) +`
298			`(Character'Pos ('a') - Character'Pos ('A')));`
299			`end if;`
300
301			`if C /= T (K) then`
302			`P := Save_P;`
303			`return False;`
304			`end if;`
305
306			`P := P + 1;`
307			`end loop;`
308
309			`if At_EOF then`
310			`return True;`
311			`end if;`
312
313			`C := S (P);`
314
315			`if C in '0' .. '9'`
316			`or else C in 'a' .. 'z'`
317			`or else C in 'A' .. 'Z'`
318			`or else C > Character'Val (127)`
319			`then`
320			`P := Save_P;`
321			`return False;`
322
323			`else`
324			`return True;`
325			`end if;`
326			`end Check_Token;`
327
328			`-----------`
329			`-- Error --`
330			`-----------`
331
332			`procedure Error (Err : String) is`
333			`C : Natural := 0;`
334			`-- Column number`
335
336			`M : String (1 .. 80);`
337			`-- Buffer used to build resulting error msg`
338
339			`LM : Natural := 0;`
340			`-- Pointer to last set location in M`
341
342			`procedure Add_Nat (N : Natural);`
343			`-- Add chars of integer to error msg buffer`
344
345			`-------------`
346			`-- Add_Nat --`
347			`-------------`
348
349			`procedure Add_Nat (N : Natural) is`
350			`begin`
351			`if N > 9 then`
352			`Add_Nat (N / 10);`
353			`end if;`
354
355			`LM := LM + 1;`
356			`M (LM) := Character'Val (N mod 10 + Character'Pos ('0'));`
357			`end Add_Nat;`
358
359			`-- Start of processing for Error`
360
361			`begin`
362			`M (1 .. 9) := "gnat.adc:";`
363			`LM := 9;`
364			`Add_Nat (Line_Num);`
365			`LM := LM + 1;`
366			`M (LM) := ':';`
367
368			`-- Determine column number`
369
370			`for X in Start_Of_Line .. P loop`
371			`C := C + 1;`
372
373			`if S (X) = HT then`
374			`C := (C + 7) / 8 * 8;`
375			`end if;`
376			`end loop;`
377
378			`Add_Nat (C);`
379			`M (LM + 1) := ':';`
380			`LM := LM + 1;`
381			`M (LM + 1) := ' ';`
382			`LM := LM + 1;`
383
384			`M (LM + 1 .. LM + Err'Length) := Err;`
385			`LM := LM + Err'Length;`
386
387			`Raise_Exception (Syntax_Error_In_GNAT_ADC'Identity, M (1 .. LM));`
388			`end Error;`
389
390			`-------------------`
391			`-- Require_Token --`
392			`-------------------`
393
394			`procedure Require_Token (T : String) is`
395			`SaveP : Natural;`
396
397			`begin`
398			`Skip_WS;`
399			`SaveP := P;`
400
401			`for J in T'Range loop`
402
403			`if At_EOF or else S (P) /= T (J) then`
404			`declare`
405			`S : String (1 .. T'Length + 10);`
406
407			`begin`
408			`S (1 .. 9) := "missing """;`
409			`S (10 .. T'Length + 9) := T;`
410			`S (T'Length + 10) := '"';`
411			`P := SaveP;`
412			`Error (S);`
413			`end;`
414
415			`else`
416			`P := P + 1;`
417			`end if;`
418			`end loop;`
419			`end Require_Token;`
420
421			`----------------------`
422			`-- Scan_SFN_Pragmas --`
423			`----------------------`
424
425			`procedure Scan_SFN_Pragmas`
426			`(Source : String;`
427			`SFN_Ptr : Set_File_Name_Ptr;`
428			`SFNP_Ptr : Set_File_Name_Pattern_Ptr)`
429			`is`
430			`B, E : Natural;`
431			`Typ : Character;`
432			`Cas : Character;`
433
434			`begin`
435			`Line_Num := 1;`
436			`S := Source'Unrestricted_Access;`
437			`P := Source'First;`
438			`Start_Of_Line := P;`
439
440			`-- Loop through pragmas in file`
441
442			`Main_Scan_Loop : loop`
443			`Skip_WS;`
444			`exit Main_Scan_Loop when At_EOF;`
445
446			`-- Error if something other than pragma`
447
448			`if not Check_Token ("pragma") then`
449			`Error ("non pragma encountered");`
450			`end if;`
451
452			`-- Source_File_Name pragma case`
453
454			`if Check_Token ("source_file_name")`
455			`or else`
456			`Check_Token ("source_file_name_project")`
457			`then`
458			`Require_Token ("(");`
459
460			`Typ := Check_File_Type;`
461
462			`-- First format, with unit name first`
463
464			`if Typ = ' ' then`
465			`if Check_Token ("unit_name") then`
466			`Require_Token ("=>");`
467			`end if;`
468
469			`declare`
470			`U : constant String := Acquire_Unit_Name;`
471
472			`begin`
473			`Require_Token (",");`
474			`Typ := Check_File_Type;`
475
476			`if Typ /= 's' and then Typ /= 'b' then`
477			`Error ("bad pragma");`
478			`end if;`
479
480			`Require_Token ("=>");`
481			`Scan_String (B, E);`
482
483			`declare`
484			`F : constant String := Acquire_String (B, E);`
485			`X : Natural;`
486
487			`begin`
488			`-- Scan Index parameter if present`
489
490			`if Check_Token (",") then`
491			`if Check_Token ("index") then`
492			`Require_Token ("=>");`
493			`end if;`
494
495			`X := Acquire_Integer;`
496			`else`
497			`X := 0;`
498			`end if;`
499
500			`Require_Token (")");`
501			`Require_Token (";");`
502			`SFN_Ptr.all (Typ, U, F, X);`
503			`end;`
504			`end;`
505
506			`-- Second format with pattern string`
507
508			`else`
509			`Require_Token ("=>");`
510			`Scan_String (B, E);`
511
512			`declare`
513			`Pat : constant String := Acquire_String (B, E);`
514			`Nas : Natural := 0;`
515
516			`begin`
517			`-- Check exactly one asterisk`
518
519			`for J in Pat'Range loop`
520			`if Pat (J) = '*' then`
521			`Nas := Nas + 1;`
522			`end if;`
523			`end loop;`
524
525			`if Nas /= 1 then`
526			`Error ("** not allowed");`
527			`end if;`
528
529			`B := 0;`
530			`E := 0;`
531			`Cas := ' ';`
532
533			`-- Loop to scan out Casing or Dot_Replacement parameters`
534
535			`loop`
536			`Check_Not_At_EOF;`
537			`exit when S (P) = ')';`
538			`Require_Token (",");`
539
540			`if Check_Token ("casing") then`
541			`Require_Token ("=>");`
542
543			`if Cas /= ' ' then`
544			`Error ("duplicate casing argument");`
545			`elsif Check_Token ("lowercase") then`
546			`Cas := 'l';`
547			`elsif Check_Token ("uppercase") then`
548			`Cas := 'u';`
549			`elsif Check_Token ("mixedcase") then`
550			`Cas := 'm';`
551			`else`
552			`Error ("invalid casing argument");`
553			`end if;`
554
555			`elsif Check_Token ("dot_replacement") then`
556			`Require_Token ("=>");`
557
558			`if E /= 0 then`
559			`Error ("duplicate dot_replacement");`
560			`else`
561			`Scan_String (B, E);`
562			`end if;`
563
564			`else`
565			`Error ("invalid argument");`
566			`end if;`
567			`end loop;`
568
569			`Require_Token (")");`
570			`Require_Token (";");`
571
572			`if Cas = ' ' then`
573			`Cas := 'l';`
574			`end if;`
575
576			`if E = 0 then`
577			`SFNP_Ptr.all (Pat, Typ, ".", Cas);`
578
579			`else`
580			`declare`
581			`Dot : constant String := Acquire_String (B, E);`
582
583			`begin`
584			`SFNP_Ptr.all (Pat, Typ, Dot, Cas);`
585			`end;`
586			`end if;`
587			`end;`
588			`end if;`
589
590			`-- Some other pragma, scan to semicolon at end of pragma`
591
592			`else`
593			`Skip_Loop : loop`
594			`exit Main_Scan_Loop when At_EOF;`
595			`exit Skip_Loop when S (P) = ';';`
596
597			`if S (P) = '"' or else S (P) = '%' then`
598			`Scan_String (B, E);`
599			`else`
600			`P := P + 1;`
601			`end if;`
602			`end loop Skip_Loop;`
603
604			`-- We successfuly skipped to semicolon, so skip past it`
605
606			`P := P + 1;`
607			`end if;`
608			`end loop Main_Scan_Loop;`
609
610			`exception`
611			`when others =>`
612			`Cursor := P - S'First + 1;`
613			`raise;`
614			`end Scan_SFN_Pragmas;`
615
616			`-----------------`
617			`-- Scan_String --`
618			`-----------------`
619
620			`procedure Scan_String (B : out Natural; E : out Natural) is`
621			`Q : Character;`
622
623			`begin`
624			`Check_Not_At_EOF;`
625
626			`if S (P) = '"' then`
627			`Q := '"';`
628			`elsif S (P) = '%' then`
629			`Q := '%';`
630			`else`
631			`Error ("bad string");`
632			`Q := '"';`
633			`end if;`
634
635			`-- Scan out the string, B points to first char`
636
637			`B := P;`
638			`P := P + 1;`
639
640			`loop`
641			`if At_EOF or else S (P) = LF or else S (P) = CR then`
642			`Error ("missing string quote");`
643
644			`elsif S (P) = HT then`
645			`Error ("tab character in string");`
646
647			`elsif S (P) /= Q then`
648			`P := P + 1;`
649
650			`-- We have a quote`
651
652			`else`
653			`P := P + 1;`
654
655			`-- Check for doubled quote`
656
657			`if not At_EOF and then S (P) = Q then`
658			`P := P + 1;`
659
660			`-- Otherwise this is the terminating quote`
661
662			`else`
663			`E := P - 1;`
664			`return;`
665			`end if;`
666			`end if;`
667			`end loop;`
668			`end Scan_String;`
669
670			`-------------`
671			`-- Skip_WS --`
672			`-------------`
673
674			`procedure Skip_WS is`
675			`begin`
676			`WS_Scan : while not At_EOF loop`
677			`case S (P) is`
678
679			`-- End of physical line`
680
681			`when CR \| LF =>`
682			`Line_Num := Line_Num + 1;`
683			`P := P + 1;`
684
685			`while not At_EOF`
686			`and then (S (P) = CR or else S (P) = LF)`
687			`loop`
688			`Line_Num := Line_Num + 1;`
689			`P := P + 1;`
690			`end loop;`
691
692			`Start_Of_Line := P;`
693
694			`-- All other cases of white space characters`
695
696			`when ' ' \| FF \| VT \| HT =>`
697			`P := P + 1;`
698
699			`-- Comment`
700
701			`when '-' =>`
702			`P := P + 1;`
703
704			`if At_EOF then`
705			`Error ("bad comment");`
706
707			`elsif S (P) = '-' then`
708			`P := P + 1;`
709
710			`while not At_EOF loop`
711			`case S (P) is`
712			`when CR \| LF \| FF \| VT =>`
713			`exit;`
714			`when others =>`
715			`P := P + 1;`
716			`end case;`
717			`end loop;`
718
719			`else`
720			`P := P - 1;`
721			`exit WS_Scan;`
722			`end if;`
723
724			`when others =>`
725			`exit WS_Scan;`
726
727			`end case;`
728			`end loop WS_Scan;`
729			`end Skip_WS;`
730
731			`end SFN_Scan;`