+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- S F N _ S C A N --
--- --
--- B o d y --
--- --
--- $Revision: 1.1.16.1 $
--- --
--- Copyright (C) 2000-2001 Free Software Foundation, Inc. --
--- --
--- GNAT is free software; you can redistribute it and/or modify it under --
--- terms of the GNU General Public License as published by the Free Soft- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
--- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
--- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
--- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- GNAT was originally developed by the GNAT team at New York University. --
--- 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
-
- type String_Ptr is access String;
-
- S : String_Ptr;
- -- Points to the gnat.adc input file
-
- P : Natural;
- -- Subscript of next character to process in S
-
- Line_Num : Natural;
- -- Current line number
-
- Start_Of_Line : Natural;
- -- Subscript of first character at start of current line
-
- ----------------------
- -- Local Procedures --
- ----------------------
-
- function Acquire_String (B : Natural; E : Natural) return String;
- -- This function takes a string scanned out by Scan_String, strips
- -- the enclosing quote characters and any internal doubled quote
- -- characters, and returns the result as a String. The arguments
- -- B and E are as returned from a call to Scan_String. The lower
- -- bound of the string returned is always 1.
-
- function Acquire_Unit_Name return String;
- -- Skips white space, and then scans and returns a unit name. The
- -- unit name is cased exactly as it appears in the source file.
- -- The terminating character must be white space, or a comma or
- -- a right parenthesis or end of file.
-
- function At_EOF return Boolean;
- pragma Inline (At_EOF);
- -- Returns True if at end of file, False if not. Note that this
- -- function does NOT skip white space, so P is always unchanged.
-
- procedure Check_Not_At_EOF;
- pragma Inline (Check_Not_At_EOF);
- -- Skips past white space if any, and then raises Error if at
- -- end of file. Otherwise returns with P skipped past whitespace.
-
- function Check_File_Type return Character;
- -- Skips white space if any, and then looks for any of the tokens
- -- Spec_File_Name, Body_File_Name, or Subunit_File_Name. If one
- -- of these is found then the value returned is 's', 'b' or 'u'
- -- respectively, and P is bumped past the token. If none of
- -- these tokens is found, then P is unchanged (except for
- -- possible skip of white space), and a space is returned.
-
- function Check_Token (T : String) return Boolean;
- -- Skips white space if any, and then checks if the string at the
- -- current location matches the given string T, and the character
- -- immediately following is non-alphabetic, non-numeric. If so,
- -- P is stepped past the token, and True is returned. If not,
- -- P is unchanged (except for possibly skipping past whitespace),
- -- and False is returned. S may contain only lower-case letters
- -- ('a' .. 'z').
-
- procedure Error (Err : String);
- -- Called if an error is detected. Raises Syntax_Error_In_GNAT_ADC
- -- with a message of the form gnat.adc:line:col: xxx, where xxx is
- -- the string Err passed as a parameter.
-
- procedure Require_Token (T : String);
- -- Skips white space if any, and then requires the given string
- -- to be present. If it is, the P is stepped past it, otherwise
- -- Error is raised, since this is a syntax error. Require_Token
- -- is used only for sequences of special characters, so there
- -- is no issue of terminators, or casing of letters.
-
- procedure Scan_String (B : out Natural; E : out Natural);
- -- Skips white space if any, then requires that a double quote
- -- or percent be present (start of string). Raises error if
- -- neither of these two characters is found. Otherwise scans
- -- out the string, and returns with P pointing past the
- -- closing quote and S (B .. E) contains the characters of the
- -- string (including the enclosing quotes, with internal quotes
- -- still doubled). Raises Error if the string is malformed.
-
- procedure Skip_WS;
- -- Skips P past any white space characters (end of line
- -- characters, spaces, comments, horizontal tab characters).
-
- --------------------
- -- Acquire_String --
- --------------------
-
- function Acquire_String (B : Natural; E : Natural) return String is
- Str : String (1 .. E - B - 1);
- Q : constant Character := S (B);
- J : Natural;
- Ptr : Natural;
-
- begin
- Ptr := B + 1;
- J := 0;
- while Ptr < E loop
- J := J + 1;
- Str (J) := S (Ptr);
-
- if S (Ptr) = Q and then S (Ptr + 1) = Q then
- Ptr := Ptr + 2;
- else
- Ptr := Ptr + 1;
- end if;
- end loop;
-
- return Str (1 .. J);
- end Acquire_String;
-
- -----------------------
- -- Acquire_Unit_Name --
- -----------------------
-
- function Acquire_Unit_Name return String is
- B : Natural;
-
- begin
- Check_Not_At_EOF;
- B := P;
-
- while not At_EOF loop
- exit when S (P) not in '0' .. '9'
- and then S (P) /= '.'
- and then S (P) /= '_'
- and then not (S (P) = '[' and then S (P + 1) = '"')
- and then not (S (P) = '"' and then S (P - 1) = '[')
- and then not (S (P) = '"' and then S (P + 1) = ']')
- and then not (S (P) = ']' and then S (P - 1) = '"')
- and then S (P) < 'A';
- P := P + 1;
- end loop;
-
- if P = B then
- Error ("null unit name");
- end if;
-
- return S (B .. P - 1);
- end Acquire_Unit_Name;
-
- ------------
- -- At_EOF --
- ------------
-
- function At_EOF return Boolean is
- begin
- return P > S'Last;
- end At_EOF;
-
- ---------------------
- -- Check_File_Type --
- ---------------------
-
- function Check_File_Type return Character is
- begin
- if Check_Token ("spec_file_name") then
- return 's';
- elsif Check_Token ("body_file_name") then
- return 'b';
- elsif Check_Token ("subunit_file_name") then
- return 'u';
- else
- return ' ';
- end if;
- end Check_File_Type;
-
- ----------------------
- -- Check_Not_At_EOF --
- ----------------------
-
- procedure Check_Not_At_EOF is
- begin
- Skip_WS;
-
- if At_EOF then
- Error ("unexpected end of file");
- end if;
-
- return;
- end Check_Not_At_EOF;
-
- -----------------
- -- Check_Token --
- -----------------
-
- function Check_Token (T : String) return Boolean is
- Save_P : Natural;
- C : Character;
-
- begin
- Skip_WS;
- Save_P := P;
-
- for K in T'Range loop
- if At_EOF then
- P := Save_P;
- return False;
- end if;
-
- C := S (P);
-
- if C in 'A' .. 'Z' then
- C := Character'Val (Character'Pos (C) +
- (Character'Pos ('a') - Character'Pos ('A')));
- end if;
-
- if C /= T (K) then
- P := Save_P;
- return False;
- end if;
-
- P := P + 1;
- end loop;
-
- if At_EOF then
- return True;
- end if;
-
- C := S (P);
-
- if C in '0' .. '9'
- or else C in 'a' .. 'z'
- or else C in 'A' .. 'Z'
- or else C > Character'Val (127)
- then
- P := Save_P;
- return False;
-
- else
- return True;
- end if;
- end Check_Token;
-
- -----------
- -- Error --
- -----------
-
- procedure Error (Err : String) is
- C : Natural := 0;
- -- Column number
-
- M : String (1 .. 80);
- -- Buffer used to build resulting error msg
-
- LM : Natural := 0;
- -- Pointer to last set location in M
-
- procedure Add_Nat (N : Natural);
- -- Add chars of integer to error msg buffer
-
- procedure Add_Nat (N : Natural) is
- begin
- if N > 9 then
- Add_Nat (N / 10);
- end if;
-
- LM := LM + 1;
- M (LM) := Character'Val (N mod 10 + Character'Pos ('0'));
- end Add_Nat;
-
- -- Start of processing for Error
-
- begin
- M (1 .. 9) := "gnat.adc:";
- LM := 9;
- Add_Nat (Line_Num);
- LM := LM + 1;
- M (LM) := ':';
-
- -- Determine column number
-
- for X in Start_Of_Line .. P loop
- C := C + 1;
-
- if S (X) = HT then
- C := (C + 7) / 8 * 8;
- end if;
- end loop;
-
- Add_Nat (C);
- M (LM + 1) := ':';
- LM := LM + 1;
- M (LM + 1) := ' ';
- LM := LM + 1;
-
- M (LM + 1 .. LM + Err'Length) := Err;
- LM := LM + Err'Length;
-
- Raise_Exception (Syntax_Error_In_GNAT_ADC'Identity, M (1 .. LM));
- end Error;
-
- -------------------
- -- Require_Token --
- -------------------
-
- procedure Require_Token (T : String) is
- SaveP : Natural;
-
- begin
- Skip_WS;
- SaveP := P;
-
- for J in T'Range loop
-
- if At_EOF or else S (P) /= T (J) then
- declare
- S : String (1 .. T'Length + 10);
-
- begin
- S (1 .. 9) := "missing """;
- S (10 .. T'Length + 9) := T;
- S (T'Length + 10) := '"';
- P := SaveP;
- Error (S);
- end;
-
- else
- P := P + 1;
- end if;
- end loop;
- end Require_Token;
-
- ----------------------
- -- Scan_SFN_Pragmas --
- ----------------------
-
- procedure Scan_SFN_Pragmas
- (Source : String;
- SFN_Ptr : Set_File_Name_Ptr;
- SFNP_Ptr : Set_File_Name_Pattern_Ptr)
- is
- B, E : Natural;
- Typ : Character;
- Cas : Character;
-
- begin
- Line_Num := 1;
- S := Source'Unrestricted_Access;
- P := Source'First;
- Start_Of_Line := P;
-
- -- Loop through pragmas in file
-
- Main_Scan_Loop : loop
- Skip_WS;
- exit Main_Scan_Loop when At_EOF;
-
- -- Error if something other than pragma
-
- if not Check_Token ("pragma") then
- Error ("non pragma encountered");
- end if;
-
- -- Source_File_Name pragma case
-
- if Check_Token ("source_file_name") then
- Require_Token ("(");
-
- Typ := Check_File_Type;
-
- -- First format, with unit name first
-
- if Typ = ' ' then
- if Check_Token ("unit_name") then
- Require_Token ("=>");
- end if;
-
- declare
- U : constant String := Acquire_Unit_Name;
-
- begin
- Require_Token (",");
- Typ := Check_File_Type;
-
- if Typ /= 's' and then Typ /= 'b' then
- Error ("bad pragma");
- end if;
-
- Require_Token ("=>");
- Scan_String (B, E);
-
- declare
- F : constant String := Acquire_String (B, E);
-
- begin
- Require_Token (")");
- Require_Token (";");
- SFN_Ptr.all (Typ, U, F);
- end;
- end;
-
- -- Second format with pattern string
-
- else
- Require_Token ("=>");
- Scan_String (B, E);
-
- declare
- Pat : constant String := Acquire_String (B, E);
- Nas : Natural := 0;
-
- begin
- -- Check exactly one asterisk
-
- for J in Pat'Range loop
- if Pat (J) = '*' then
- Nas := Nas + 1;
- end if;
- end loop;
-
- if Nas /= 1 then
- Error ("** not allowed");
- end if;
-
- B := 0;
- E := 0;
- Cas := ' ';
-
- -- Loop to scan out Casing or Dot_Replacement parameters
-
- loop
- Check_Not_At_EOF;
- exit when S (P) = ')';
- Require_Token (",");
-
- if Check_Token ("casing") then
- Require_Token ("=>");
-
- if Cas /= ' ' then
- Error ("duplicate casing argument");
- elsif Check_Token ("lowercase") then
- Cas := 'l';
- elsif Check_Token ("uppercase") then
- Cas := 'u';
- elsif Check_Token ("mixedcase") then
- Cas := 'm';
- else
- Error ("invalid casing argument");
- end if;
-
- elsif Check_Token ("dot_replacement") then
- Require_Token ("=>");
-
- if E /= 0 then
- Error ("duplicate dot_replacement");
- else
- Scan_String (B, E);
- end if;
-
- else
- Error ("invalid argument");
- end if;
- end loop;
-
- Require_Token (")");
- Require_Token (";");
-
- if Cas = ' ' then
- Cas := 'l';
- end if;
-
- if E = 0 then
- SFNP_Ptr.all (Pat, Typ, ".", Cas);
-
- else
- declare
- Dot : constant String := Acquire_String (B, E);
-
- begin
- SFNP_Ptr.all (Pat, Typ, Dot, Cas);
- end;
- end if;
- end;
- end if;
-
- -- Some other pragma, scan to semicolon at end of pragma
-
- else
- Skip_Loop : loop
- exit Main_Scan_Loop when At_EOF;
- exit Skip_Loop when S (P) = ';';
-
- if S (P) = '"' or else S (P) = '%' then
- Scan_String (B, E);
- else
- P := P + 1;
- end if;
- end loop Skip_Loop;
-
- -- We successfuly skipped to semicolon, so skip past it
-
- P := P + 1;
- end if;
- end loop Main_Scan_Loop;
-
- exception
- when others =>
- Cursor := P - S'First + 1;
- raise;
- end Scan_SFN_Pragmas;
-
- -----------------
- -- Scan_String --
- -----------------
-
- procedure Scan_String (B : out Natural; E : out Natural) is
- Q : Character;
-
- begin
- Check_Not_At_EOF;
-
- if S (P) = '"' then
- Q := '"';
- elsif S (P) = '%' then
- Q := '%';
- else
- Error ("bad string");
- Q := '"';
- end if;
-
- -- Scan out the string, B points to first char
-
- B := P;
- P := P + 1;
-
- loop
- if At_EOF or else S (P) = LF or else S (P) = CR then
- Error ("missing string quote");
-
- elsif S (P) = HT then
- Error ("tab character in string");
-
- elsif S (P) /= Q then
- P := P + 1;
-
- -- We have a quote
-
- else
- P := P + 1;
-
- -- Check for doubled quote
-
- if not At_EOF and then S (P) = Q then
- P := P + 1;
-
- -- Otherwise this is the terminating quote
-
- else
- E := P - 1;
- return;
- end if;
- end if;
- end loop;
- end Scan_String;
-
- -------------
- -- Skip_WS --
- -------------
-
- procedure Skip_WS is
- begin
- WS_Scan : while not At_EOF loop
- case S (P) is
-
- -- End of physical line
-
- when CR | LF =>
- Line_Num := Line_Num + 1;
- P := P + 1;
-
- while not At_EOF
- and then (S (P) = CR or else S (P) = LF)
- loop
- Line_Num := Line_Num + 1;
- P := P + 1;
- end loop;
-
- Start_Of_Line := P;
-
- -- All other cases of white space characters
-
- when ' ' | FF | VT | HT =>
- P := P + 1;
-
- -- Comment
-
- when '-' =>
- P := P + 1;
-
- if At_EOF then
- Error ("bad comment");
-
- elsif S (P) = '-' then
- P := P + 1;
-
- while not At_EOF loop
- case S (P) is
- when CR | LF | FF | VT =>
- exit;
- when others =>
- P := P + 1;
- end case;
- end loop;
-
- else
- P := P - 1;
- exit WS_Scan;
- end if;
-
- when others =>
- exit WS_Scan;
-
- end case;
- end loop WS_Scan;
- end Skip_WS;
-
-end SFN_Scan;
projects / msp430-gcc.git / blobdiff