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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [sfn_scan.adb] - Blame information for rev 706

Details | Compare with Previous | View Log


------------------------------------------------------------------------------
--                                                                          --
--                         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;

Browse

Tools

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [sfn_scan.adb] - Blame information for rev 706

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