1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2000-2010, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 with Ada.Exceptions; use Ada.Exceptions;
34 package body SFN_Scan is
37 -- Allow easy access to control character definitions
39 EOF : constant Character := ASCII.SUB;
40 -- The character SUB (16#1A#) is used in DOS-derived systems, such as
41 -- Windows to signal the end of a text file. If this character appears as
42 -- the last character of a file scanned by a call to Scan_SFN_Pragmas, then
43 -- it is ignored, otherwise it is treated as an illegal character.
45 type String_Ptr is access String;
48 -- Points to the gnat.adc input file
51 -- Subscript of next character to process in S
54 -- Current line number
56 Start_Of_Line : Natural;
57 -- Subscript of first character at start of current line
59 ----------------------
60 -- Local Procedures --
61 ----------------------
63 function Acquire_Integer return Natural;
64 -- This function skips white space, and then scans and returns
65 -- an unsigned integer. Raises Error if no integer is present
66 -- or if the integer is greater than 999.
68 function Acquire_String (B : Natural; E : Natural) return String;
69 -- This function takes a string scanned out by Scan_String, strips
70 -- the enclosing quote characters and any internal doubled quote
71 -- characters, and returns the result as a String. The arguments
72 -- B and E are as returned from a call to Scan_String. The lower
73 -- bound of the string returned is always 1.
75 function Acquire_Unit_Name return String;
76 -- Skips white space, and then scans and returns a unit name. The
77 -- unit name is cased exactly as it appears in the source file.
78 -- The terminating character must be white space, or a comma or
79 -- a right parenthesis or end of file.
81 function At_EOF return Boolean;
82 pragma Inline (At_EOF);
83 -- Returns True if at end of file, False if not. Note that this
84 -- function does NOT skip white space, so P is always unchanged.
86 procedure Check_Not_At_EOF;
87 pragma Inline (Check_Not_At_EOF);
88 -- Skips past white space if any, and then raises Error if at
89 -- end of file. Otherwise returns with P skipped past whitespace.
91 function Check_File_Type return Character;
92 -- Skips white space if any, and then looks for any of the tokens
93 -- Spec_File_Name, Body_File_Name, or Subunit_File_Name. If one
94 -- of these is found then the value returned is 's', 'b' or 'u'
95 -- respectively, and P is bumped past the token. If none of
96 -- these tokens is found, then P is unchanged (except for
97 -- possible skip of white space), and a space is returned.
99 function Check_Token (T : String) return Boolean;
100 -- Skips white space if any, and then checks if the string at the
101 -- current location matches the given string T, and the character
102 -- immediately following is non-alphabetic, non-numeric. If so,
103 -- P is stepped past the token, and True is returned. If not,
104 -- P is unchanged (except for possibly skipping past whitespace),
105 -- and False is returned. S may contain only lower-case letters
108 procedure Error (Err : String);
109 -- Called if an error is detected. Raises Syntax_Error_In_GNAT_ADC
110 -- with a message of the form gnat.adc:line:col: xxx, where xxx is
111 -- the string Err passed as a parameter.
113 procedure Require_Token (T : String);
114 -- Skips white space if any, and then requires the given string
115 -- to be present. If it is, the P is stepped past it, otherwise
116 -- Error is raised, since this is a syntax error. Require_Token
117 -- is used only for sequences of special characters, so there
118 -- is no issue of terminators, or casing of letters.
120 procedure Scan_String (B : out Natural; E : out Natural);
121 -- Skips white space if any, then requires that a double quote
122 -- or percent be present (start of string). Raises error if
123 -- neither of these two characters is found. Otherwise scans
124 -- out the string, and returns with P pointing past the
125 -- closing quote and S (B .. E) contains the characters of the
126 -- string (including the enclosing quotes, with internal quotes
127 -- still doubled). Raises Error if the string is malformed.
130 -- Skips P past any white space characters (end of line
131 -- characters, spaces, comments, horizontal tab characters).
133 ---------------------
134 -- Acquire_Integer --
135 ---------------------
137 function Acquire_Integer return Natural is
143 if S (P) not in '0' .. '9' then
144 Error ("missing index parameter");
147 while S (P) in '0' .. '9' loop
148 N := N * 10 + Character'Pos (S (P)) - Character'Pos ('0');
151 Error ("index value greater than 999");
164 function Acquire_String (B : Natural; E : Natural) return String is
165 Str : String (1 .. E - B - 1);
166 Q : constant Character := S (B);
177 if S (Ptr) = Q and then S (Ptr + 1) = Q then
187 -----------------------
188 -- Acquire_Unit_Name --
189 -----------------------
191 function Acquire_Unit_Name return String is
198 while not At_EOF loop
199 exit when S (P) not in '0' .. '9'
200 and then S (P) /= '.'
201 and then S (P) /= '_'
202 and then not (S (P) = '[' and then S (P + 1) = '"')
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 S (P) < 'A';
211 Error ("null unit name");
214 return S (B .. P - 1);
215 end Acquire_Unit_Name;
221 function At_EOF return Boolean is
223 -- Immediate return (False) if before last character of file
228 -- Special case: DOS EOF character as last character of file is
229 -- allowed and treated as an end of file.
231 elsif P = S'Last then
234 -- If beyond last character of file, then definitely at EOF
241 ---------------------
242 -- Check_File_Type --
243 ---------------------
245 function Check_File_Type return Character is
247 if Check_Token ("spec_file_name") then
249 elsif Check_Token ("body_file_name") then
251 elsif Check_Token ("subunit_file_name") then
258 ----------------------
259 -- Check_Not_At_EOF --
260 ----------------------
262 procedure Check_Not_At_EOF is
267 Error ("unexpected end of file");
271 end Check_Not_At_EOF;
277 function Check_Token (T : String) return Boolean is
285 for K in T'Range loop
293 if C in 'A' .. 'Z' then
294 C := Character'Val (Character'Pos (C) +
295 (Character'Pos ('a') - Character'Pos ('A')));
313 or else C in 'a' .. 'z'
314 or else C in 'A' .. 'Z'
315 or else C > Character'Val (127)
329 procedure Error (Err : String) is
333 M : String (1 .. 80);
334 -- Buffer used to build resulting error msg
337 -- Pointer to last set location in M
339 procedure Add_Nat (N : Natural);
340 -- Add chars of integer to error msg buffer
346 procedure Add_Nat (N : Natural) is
353 M (LM) := Character'Val (N mod 10 + Character'Pos ('0'));
356 -- Start of processing for Error
359 M (1 .. 9) := "gnat.adc:";
365 -- Determine column number
367 for X in Start_Of_Line .. P loop
371 C := (C + 7) / 8 * 8;
381 M (LM + 1 .. LM + Err'Length) := Err;
382 LM := LM + Err'Length;
384 Raise_Exception (Syntax_Error_In_GNAT_ADC'Identity, M (1 .. LM));
391 procedure Require_Token (T : String) is
398 for J in T'Range loop
400 if At_EOF or else S (P) /= T (J) then
402 S : String (1 .. T'Length + 10);
405 S (1 .. 9) := "missing """;
406 S (10 .. T'Length + 9) := T;
407 S (T'Length + 10) := '"';
418 ----------------------
419 -- Scan_SFN_Pragmas --
420 ----------------------
422 procedure Scan_SFN_Pragmas
424 SFN_Ptr : Set_File_Name_Ptr;
425 SFNP_Ptr : Set_File_Name_Pattern_Ptr)
433 S := Source'Unrestricted_Access;
437 -- Loop through pragmas in file
439 Main_Scan_Loop : loop
441 exit Main_Scan_Loop when At_EOF;
443 -- Error if something other than pragma
445 if not Check_Token ("pragma") then
446 Error ("non pragma encountered");
449 -- Source_File_Name pragma case
451 if Check_Token ("source_file_name")
453 Check_Token ("source_file_name_project")
457 Typ := Check_File_Type;
459 -- First format, with unit name first
462 if Check_Token ("unit_name") then
463 Require_Token ("=>");
467 U : constant String := Acquire_Unit_Name;
471 Typ := Check_File_Type;
473 if Typ /= 's' and then Typ /= 'b' then
474 Error ("bad pragma");
477 Require_Token ("=>");
481 F : constant String := Acquire_String (B, E);
485 -- Scan Index parameter if present
487 if Check_Token (",") then
488 if Check_Token ("index") then
489 Require_Token ("=>");
492 X := Acquire_Integer;
499 SFN_Ptr.all (Typ, U, F, X);
503 -- Second format with pattern string
506 Require_Token ("=>");
510 Pat : constant String := Acquire_String (B, E);
514 -- Check exactly one asterisk
516 for J in Pat'Range loop
517 if Pat (J) = '*' then
523 Error ("** not allowed");
530 -- Loop to scan out Casing or Dot_Replacement parameters
534 exit when S (P) = ')';
537 if Check_Token ("casing") then
538 Require_Token ("=>");
541 Error ("duplicate casing argument");
542 elsif Check_Token ("lowercase") then
544 elsif Check_Token ("uppercase") then
546 elsif Check_Token ("mixedcase") then
549 Error ("invalid casing argument");
552 elsif Check_Token ("dot_replacement") then
553 Require_Token ("=>");
556 Error ("duplicate dot_replacement");
562 Error ("invalid argument");
574 SFNP_Ptr.all (Pat, Typ, ".", Cas);
578 Dot : constant String := Acquire_String (B, E);
581 SFNP_Ptr.all (Pat, Typ, Dot, Cas);
587 -- Some other pragma, scan to semicolon at end of pragma
591 exit Main_Scan_Loop when At_EOF;
592 exit Skip_Loop when S (P) = ';';
594 if S (P) = '"' or else S (P) = '%' then
601 -- We successfully skipped to semicolon, so skip past it
605 end loop Main_Scan_Loop;
609 Cursor := P - S'First + 1;
611 end Scan_SFN_Pragmas;
617 procedure Scan_String (B : out Natural; E : out Natural) is
625 elsif S (P) = '%' then
628 Error ("bad string");
632 -- Scan out the string, B points to first char
638 if At_EOF or else S (P) = LF or else S (P) = CR then
640 ("missing string quote");
642 elsif S (P) = HT then
643 Error ("tab character in string");
645 elsif S (P) /= Q then
653 -- Check for doubled quote
655 if not At_EOF and then S (P) = Q then
658 -- Otherwise this is the terminating quote
674 WS_Scan : while not At_EOF loop
677 -- End of physical line
680 Line_Num := Line_Num + 1;
684 and then (S (P) = CR or else S (P) = LF)
686 Line_Num := Line_Num + 1;
692 -- All other cases of white space characters
694 when ' ' | FF | VT | HT =>
703 Error ("bad comment");
705 elsif S (P) = '-' then
708 while not At_EOF loop
710 when CR | LF | FF | VT =>