1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2000-2005, 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 2, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 with Ada.Exceptions; use Ada.Exceptions;
36 package body SFN_Scan is
39 -- Allow easy access to control character definitions
41 EOF : constant Character := ASCII.SUB;
42 -- The character SUB (16#1A#) is used in DOS and other systems derived
43 -- from DOS (OS/2, NT etc) to signal the end of a text file. If this
44 -- character appears as the last character of a file scanned by a call
45 -- to Scan_SFN_Pragmas, then it is ignored, otherwise it is treated as
46 -- an illegal character.
48 type String_Ptr is access String;
51 -- Points to the gnat.adc input file
54 -- Subscript of next character to process in S
57 -- Current line number
59 Start_Of_Line : Natural;
60 -- Subscript of first character at start of current line
62 ----------------------
63 -- Local Procedures --
64 ----------------------
66 function Acquire_Integer return Natural;
67 -- This function skips white space, and then scans and returns
68 -- an unsigned integer. Raises Error if no integer is present
69 -- or if the integer is greater than 999.
71 function Acquire_String (B : Natural; E : Natural) return String;
72 -- This function takes a string scanned out by Scan_String, strips
73 -- the enclosing quote characters and any internal doubled quote
74 -- characters, and returns the result as a String. The arguments
75 -- B and E are as returned from a call to Scan_String. The lower
76 -- bound of the string returned is always 1.
78 function Acquire_Unit_Name return String;
79 -- Skips white space, and then scans and returns a unit name. The
80 -- unit name is cased exactly as it appears in the source file.
81 -- The terminating character must be white space, or a comma or
82 -- a right parenthesis or end of file.
84 function At_EOF return Boolean;
85 pragma Inline (At_EOF);
86 -- Returns True if at end of file, False if not. Note that this
87 -- function does NOT skip white space, so P is always unchanged.
89 procedure Check_Not_At_EOF;
90 pragma Inline (Check_Not_At_EOF);
91 -- Skips past white space if any, and then raises Error if at
92 -- end of file. Otherwise returns with P skipped past whitespace.
94 function Check_File_Type return Character;
95 -- Skips white space if any, and then looks for any of the tokens
96 -- Spec_File_Name, Body_File_Name, or Subunit_File_Name. If one
97 -- of these is found then the value returned is 's', 'b' or 'u'
98 -- respectively, and P is bumped past the token. If none of
99 -- these tokens is found, then P is unchanged (except for
100 -- possible skip of white space), and a space is returned.
102 function Check_Token (T : String) return Boolean;
103 -- Skips white space if any, and then checks if the string at the
104 -- current location matches the given string T, and the character
105 -- immediately following is non-alphabetic, non-numeric. If so,
106 -- P is stepped past the token, and True is returned. If not,
107 -- P is unchanged (except for possibly skipping past whitespace),
108 -- and False is returned. S may contain only lower-case letters
111 procedure Error (Err : String);
112 -- Called if an error is detected. Raises Syntax_Error_In_GNAT_ADC
113 -- with a message of the form gnat.adc:line:col: xxx, where xxx is
114 -- the string Err passed as a parameter.
116 procedure Require_Token (T : String);
117 -- Skips white space if any, and then requires the given string
118 -- to be present. If it is, the P is stepped past it, otherwise
119 -- Error is raised, since this is a syntax error. Require_Token
120 -- is used only for sequences of special characters, so there
121 -- is no issue of terminators, or casing of letters.
123 procedure Scan_String (B : out Natural; E : out Natural);
124 -- Skips white space if any, then requires that a double quote
125 -- or percent be present (start of string). Raises error if
126 -- neither of these two characters is found. Otherwise scans
127 -- out the string, and returns with P pointing past the
128 -- closing quote and S (B .. E) contains the characters of the
129 -- string (including the enclosing quotes, with internal quotes
130 -- still doubled). Raises Error if the string is malformed.
133 -- Skips P past any white space characters (end of line
134 -- characters, spaces, comments, horizontal tab characters).
136 ---------------------
137 -- Acquire_Integer --
138 ---------------------
140 function Acquire_Integer return Natural is
146 if S (P) not in '0' .. '9' then
147 Error ("missing index parameter");
150 while S (P) in '0' .. '9' loop
151 N := N * 10 + Character'Pos (S (P)) - Character'Pos ('0');
154 Error ("index value greater than 999");
167 function Acquire_String (B : Natural; E : Natural) return String is
168 Str : String (1 .. E - B - 1);
169 Q : constant Character := S (B);
180 if S (Ptr) = Q and then S (Ptr + 1) = Q then
190 -----------------------
191 -- Acquire_Unit_Name --
192 -----------------------
194 function Acquire_Unit_Name return String is
201 while not At_EOF loop
202 exit when S (P) not in '0' .. '9'
203 and then S (P) /= '.'
204 and then S (P) /= '_'
205 and then not (S (P) = '[' and then S (P + 1) = '"')
206 and then not (S (P) = '"' and then S (P - 1) = '[')
207 and then not (S (P) = '"' and then S (P + 1) = ']')
208 and then not (S (P) = ']' and then S (P - 1) = '"')
209 and then S (P) < 'A';
214 Error ("null unit name");
217 return S (B .. P - 1);
218 end Acquire_Unit_Name;
224 function At_EOF return Boolean is
226 -- Immediate return (False) if before last character of file
231 -- Special case: DOS EOF character as last character of file is
232 -- allowed and treated as an end of file.
234 elsif P = S'Last then
237 -- If beyond last character of file, then definitely at EOF
244 ---------------------
245 -- Check_File_Type --
246 ---------------------
248 function Check_File_Type return Character is
250 if Check_Token ("spec_file_name") then
252 elsif Check_Token ("body_file_name") then
254 elsif Check_Token ("subunit_file_name") then
261 ----------------------
262 -- Check_Not_At_EOF --
263 ----------------------
265 procedure Check_Not_At_EOF is
270 Error ("unexpected end of file");
274 end Check_Not_At_EOF;
280 function Check_Token (T : String) return Boolean is
288 for K in T'Range loop
296 if C in 'A' .. 'Z' then
297 C := Character'Val (Character'Pos (C) +
298 (Character'Pos ('a') - Character'Pos ('A')));
316 or else C in 'a' .. 'z'
317 or else C in 'A' .. 'Z'
318 or else C > Character'Val (127)
332 procedure Error (Err : String) is
336 M : String (1 .. 80);
337 -- Buffer used to build resulting error msg
340 -- Pointer to last set location in M
342 procedure Add_Nat (N : Natural);
343 -- Add chars of integer to error msg buffer
349 procedure Add_Nat (N : Natural) is
356 M (LM) := Character'Val (N mod 10 + Character'Pos ('0'));
359 -- Start of processing for Error
362 M (1 .. 9) := "gnat.adc:";
368 -- Determine column number
370 for X in Start_Of_Line .. P loop
374 C := (C + 7) / 8 * 8;
384 M (LM + 1 .. LM + Err'Length) := Err;
385 LM := LM + Err'Length;
387 Raise_Exception (Syntax_Error_In_GNAT_ADC'Identity, M (1 .. LM));
394 procedure Require_Token (T : String) is
401 for J in T'Range loop
403 if At_EOF or else S (P) /= T (J) then
405 S : String (1 .. T'Length + 10);
408 S (1 .. 9) := "missing """;
409 S (10 .. T'Length + 9) := T;
410 S (T'Length + 10) := '"';
421 ----------------------
422 -- Scan_SFN_Pragmas --
423 ----------------------
425 procedure Scan_SFN_Pragmas
427 SFN_Ptr : Set_File_Name_Ptr;
428 SFNP_Ptr : Set_File_Name_Pattern_Ptr)
436 S := Source'Unrestricted_Access;
440 -- Loop through pragmas in file
442 Main_Scan_Loop : loop
444 exit Main_Scan_Loop when At_EOF;
446 -- Error if something other than pragma
448 if not Check_Token ("pragma") then
449 Error ("non pragma encountered");
452 -- Source_File_Name pragma case
454 if Check_Token ("source_file_name")
456 Check_Token ("source_file_name_project")
460 Typ := Check_File_Type;
462 -- First format, with unit name first
465 if Check_Token ("unit_name") then
466 Require_Token ("=>");
470 U : constant String := Acquire_Unit_Name;
474 Typ := Check_File_Type;
476 if Typ /= 's' and then Typ /= 'b' then
477 Error ("bad pragma");
480 Require_Token ("=>");
484 F : constant String := Acquire_String (B, E);
488 -- Scan Index parameter if present
490 if Check_Token (",") then
491 if Check_Token ("index") then
492 Require_Token ("=>");
495 X := Acquire_Integer;
502 SFN_Ptr.all (Typ, U, F, X);
506 -- Second format with pattern string
509 Require_Token ("=>");
513 Pat : constant String := Acquire_String (B, E);
517 -- Check exactly one asterisk
519 for J in Pat'Range loop
520 if Pat (J) = '*' then
526 Error ("** not allowed");
533 -- Loop to scan out Casing or Dot_Replacement parameters
537 exit when S (P) = ')';
540 if Check_Token ("casing") then
541 Require_Token ("=>");
544 Error ("duplicate casing argument");
545 elsif Check_Token ("lowercase") then
547 elsif Check_Token ("uppercase") then
549 elsif Check_Token ("mixedcase") then
552 Error ("invalid casing argument");
555 elsif Check_Token ("dot_replacement") then
556 Require_Token ("=>");
559 Error ("duplicate dot_replacement");
565 Error ("invalid argument");
577 SFNP_Ptr.all (Pat, Typ, ".", Cas);
581 Dot : constant String := Acquire_String (B, E);
584 SFNP_Ptr.all (Pat, Typ, Dot, Cas);
590 -- Some other pragma, scan to semicolon at end of pragma
594 exit Main_Scan_Loop when At_EOF;
595 exit Skip_Loop when S (P) = ';';
597 if S (P) = '"' or else S (P) = '%' then
604 -- We successfuly skipped to semicolon, so skip past it
608 end loop Main_Scan_Loop;
612 Cursor := P - S'First + 1;
614 end Scan_SFN_Pragmas;
620 procedure Scan_String (B : out Natural; E : out Natural) is
628 elsif S (P) = '%' then
631 Error ("bad string");
635 -- Scan out the string, B points to first char
641 if At_EOF or else S (P) = LF or else S (P) = CR then
642 Error ("missing string quote");
644 elsif S (P) = HT then
645 Error ("tab character in string");
647 elsif S (P) /= Q then
655 -- Check for doubled quote
657 if not At_EOF and then S (P) = Q then
660 -- Otherwise this is the terminating quote
676 WS_Scan : while not At_EOF loop
679 -- End of physical line
682 Line_Num := Line_Num + 1;
686 and then (S (P) = CR or else S (P) = LF)
688 Line_Num := Line_Num + 1;
694 -- All other cases of white space characters
696 when ' ' | FF | VT | HT =>
705 Error ("bad comment");
707 elsif S (P) = '-' then
710 while not At_EOF loop
712 when CR | LF | FF | VT =>