diff options
Diffstat (limited to 'gcc-4.4.3/gcc/ada/sfn_scan.adb')
| -rw-r--r-- | gcc-4.4.3/gcc/ada/sfn_scan.adb | 729 |
1 files changed, 0 insertions, 729 deletions
diff --git a/gcc-4.4.3/gcc/ada/sfn_scan.adb b/gcc-4.4.3/gcc/ada/sfn_scan.adb deleted file mode 100644 index 226ef8b58..000000000 --- a/gcc-4.4.3/gcc/ada/sfn_scan.adb +++ /dev/null @@ -1,729 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 ("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; |