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

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [sfn_scan.adb] - Blame information for rev 310

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-2009, 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 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 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_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [sfn_scan.adb] - Blame information for rev 310

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