From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/ada/sfn_scan.adb | 729 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 729 insertions(+) create mode 100644 gcc/ada/sfn_scan.adb (limited to 'gcc/ada/sfn_scan.adb') diff --git a/gcc/ada/sfn_scan.adb b/gcc/ada/sfn_scan.adb new file mode 100644 index 000000000..1d24ca227 --- /dev/null +++ b/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 -- +-- . -- +-- -- +-- 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; -- cgit v1.2.3