aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.9/gcc/ada/sfn_scan.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.9/gcc/ada/sfn_scan.adb')
-rw-r--r--gcc-4.9/gcc/ada/sfn_scan.adb729
1 files changed, 729 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/ada/sfn_scan.adb b/gcc-4.9/gcc/ada/sfn_scan.adb
new file mode 100644
index 000000000..1d24ca227
--- /dev/null
+++ b/gcc-4.9/gcc/ada/sfn_scan.adb
@@ -0,0 +1,729 @@
+------------------------------------------------------------------------------
+-- --
+-- 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;