1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2000-2001 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, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, 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 type String_Ptr
is access String;
44 -- Points to the gnat.adc input file
47 -- Subscript of next character to process in S
50 -- Current line number
52 Start_Of_Line
: Natural;
53 -- Subscript of first character at start of current line
55 ----------------------
56 -- Local Procedures --
57 ----------------------
59 function Acquire_String
(B
: Natural; E
: Natural) return String;
60 -- This function takes a string scanned out by Scan_String, strips
61 -- the enclosing quote characters and any internal doubled quote
62 -- characters, and returns the result as a String. The arguments
63 -- B and E are as returned from a call to Scan_String. The lower
64 -- bound of the string returned is always 1.
66 function Acquire_Unit_Name
return String;
67 -- Skips white space, and then scans and returns a unit name. The
68 -- unit name is cased exactly as it appears in the source file.
69 -- The terminating character must be white space, or a comma or
70 -- a right parenthesis or end of file.
72 function At_EOF
return Boolean;
73 pragma Inline
(At_EOF
);
74 -- Returns True if at end of file, False if not. Note that this
75 -- function does NOT skip white space, so P is always unchanged.
77 procedure Check_Not_At_EOF
;
78 pragma Inline
(Check_Not_At_EOF
);
79 -- Skips past white space if any, and then raises Error if at
80 -- end of file. Otherwise returns with P skipped past whitespace.
82 function Check_File_Type
return Character;
83 -- Skips white space if any, and then looks for any of the tokens
84 -- Spec_File_Name, Body_File_Name, or Subunit_File_Name. If one
85 -- of these is found then the value returned is 's', 'b' or 'u'
86 -- respectively, and P is bumped past the token. If none of
87 -- these tokens is found, then P is unchanged (except for
88 -- possible skip of white space), and a space is returned.
90 function Check_Token
(T
: String) return Boolean;
91 -- Skips white space if any, and then checks if the string at the
92 -- current location matches the given string T, and the character
93 -- immediately following is non-alphabetic, non-numeric. If so,
94 -- P is stepped past the token, and True is returned. If not,
95 -- P is unchanged (except for possibly skipping past whitespace),
96 -- and False is returned. S may contain only lower-case letters
99 procedure Error
(Err
: String);
100 -- Called if an error is detected. Raises Syntax_Error_In_GNAT_ADC
101 -- with a message of the form gnat.adc:line:col: xxx, where xxx is
102 -- the string Err passed as a parameter.
104 procedure Require_Token
(T
: String);
105 -- Skips white space if any, and then requires the given string
106 -- to be present. If it is, the P is stepped past it, otherwise
107 -- Error is raised, since this is a syntax error. Require_Token
108 -- is used only for sequences of special characters, so there
109 -- is no issue of terminators, or casing of letters.
111 procedure Scan_String
(B
: out Natural; E
: out Natural);
112 -- Skips white space if any, then requires that a double quote
113 -- or percent be present (start of string). Raises error if
114 -- neither of these two characters is found. Otherwise scans
115 -- out the string, and returns with P pointing past the
116 -- closing quote and S (B .. E) contains the characters of the
117 -- string (including the enclosing quotes, with internal quotes
118 -- still doubled). Raises Error if the string is malformed.
121 -- Skips P past any white space characters (end of line
122 -- characters, spaces, comments, horizontal tab characters).
128 function Acquire_String
(B
: Natural; E
: Natural) return String is
129 Str
: String (1 .. E
- B
- 1);
130 Q
: constant Character := S
(B
);
141 if S
(Ptr
) = Q
and then S
(Ptr
+ 1) = Q
then
151 -----------------------
152 -- Acquire_Unit_Name --
153 -----------------------
155 function Acquire_Unit_Name
return String is
162 while not At_EOF
loop
163 exit when S
(P
) not in '0' .. '9'
164 and then S
(P
) /= '.'
165 and then S
(P
) /= '_'
166 and then not (S
(P
) = '[' and then S
(P
+ 1) = '"')
167 and then not (S
(P
) = '"' and then S
(P
- 1) = '[')
168 and then not (S
(P
) = '"' and then S
(P
+ 1) = ']')
169 and then not (S
(P
) = ']' and then S
(P
- 1) = '"')
170 and then S
(P
) < 'A';
175 Error
("null unit name");
178 return S
(B
.. P
- 1);
179 end Acquire_Unit_Name
;
185 function At_EOF
return Boolean is
190 ---------------------
191 -- Check_File_Type --
192 ---------------------
194 function Check_File_Type
return Character is
196 if Check_Token
("spec_file_name") then
198 elsif Check_Token
("body_file_name") then
200 elsif Check_Token
("subunit_file_name") then
207 ----------------------
208 -- Check_Not_At_EOF --
209 ----------------------
211 procedure Check_Not_At_EOF
is
216 Error
("unexpected end of file");
220 end Check_Not_At_EOF
;
226 function Check_Token
(T
: String) return Boolean is
234 for K
in T
'Range loop
242 if C
in 'A' .. 'Z' then
243 C
:= Character'Val (Character'Pos (C
) +
244 (Character'Pos ('a') - Character'Pos ('A')));
262 or else C
in 'a' .. 'z'
263 or else C
in 'A' .. 'Z'
264 or else C
> Character'Val (127)
278 procedure Error
(Err
: String) is
282 M
: String (1 .. 80);
283 -- Buffer used to build resulting error msg
286 -- Pointer to last set location in M
288 procedure Add_Nat
(N
: Natural);
289 -- Add chars of integer to error msg buffer
291 procedure Add_Nat
(N
: Natural) is
298 M
(LM
) := Character'Val (N
mod 10 + Character'Pos ('0'));
301 -- Start of processing for Error
304 M
(1 .. 9) := "gnat.adc:";
310 -- Determine column number
312 for X
in Start_Of_Line
.. P
loop
316 C
:= (C
+ 7) / 8 * 8;
326 M
(LM
+ 1 .. LM
+ Err
'Length) := Err
;
327 LM
:= LM
+ Err
'Length;
329 Raise_Exception
(Syntax_Error_In_GNAT_ADC
'Identity, M
(1 .. LM
));
336 procedure Require_Token
(T
: String) is
343 for J
in T
'Range loop
345 if At_EOF
or else S
(P
) /= T
(J
) then
347 S
: String (1 .. T
'Length + 10);
350 S
(1 .. 9) := "missing """;
351 S
(10 .. T
'Length + 9) := T
;
352 S
(T
'Length + 10) := '"';
363 ----------------------
364 -- Scan_SFN_Pragmas --
365 ----------------------
367 procedure Scan_SFN_Pragmas
369 SFN_Ptr
: Set_File_Name_Ptr
;
370 SFNP_Ptr
: Set_File_Name_Pattern_Ptr
)
378 S
:= Source
'Unrestricted_Access;
382 -- Loop through pragmas in file
384 Main_Scan_Loop
: loop
386 exit Main_Scan_Loop
when At_EOF
;
388 -- Error if something other than pragma
390 if not Check_Token
("pragma") then
391 Error
("non pragma encountered");
394 -- Source_File_Name pragma case
396 if Check_Token
("source_file_name") then
399 Typ
:= Check_File_Type
;
401 -- First format, with unit name first
404 if Check_Token
("unit_name") then
405 Require_Token
("=>");
409 U
: constant String := Acquire_Unit_Name
;
413 Typ
:= Check_File_Type
;
415 if Typ
/= 's' and then Typ
/= 'b' then
416 Error
("bad pragma");
419 Require_Token
("=>");
423 F
: constant String := Acquire_String
(B
, E
);
428 SFN_Ptr
.all (Typ
, U
, F
);
432 -- Second format with pattern string
435 Require_Token
("=>");
439 Pat
: constant String := Acquire_String
(B
, E
);
443 -- Check exactly one asterisk
445 for J
in Pat
'Range loop
446 if Pat
(J
) = '*' then
452 Error
("** not allowed");
459 -- Loop to scan out Casing or Dot_Replacement parameters
463 exit when S
(P
) = ')';
466 if Check_Token
("casing") then
467 Require_Token
("=>");
470 Error
("duplicate casing argument");
471 elsif Check_Token
("lowercase") then
473 elsif Check_Token
("uppercase") then
475 elsif Check_Token
("mixedcase") then
478 Error
("invalid casing argument");
481 elsif Check_Token
("dot_replacement") then
482 Require_Token
("=>");
485 Error
("duplicate dot_replacement");
491 Error
("invalid argument");
503 SFNP_Ptr
.all (Pat
, Typ
, ".", Cas
);
507 Dot
: constant String := Acquire_String
(B
, E
);
510 SFNP_Ptr
.all (Pat
, Typ
, Dot
, Cas
);
516 -- Some other pragma, scan to semicolon at end of pragma
520 exit Main_Scan_Loop
when At_EOF
;
521 exit Skip_Loop
when S
(P
) = ';';
523 if S
(P
) = '"' or else S
(P
) = '%' then
530 -- We successfuly skipped to semicolon, so skip past it
534 end loop Main_Scan_Loop
;
538 Cursor
:= P
- S
'First + 1;
540 end Scan_SFN_Pragmas
;
546 procedure Scan_String
(B
: out Natural; E
: out Natural) is
554 elsif S
(P
) = '%' then
557 Error
("bad string");
561 -- Scan out the string, B points to first char
567 if At_EOF
or else S
(P
) = LF
or else S
(P
) = CR
then
568 Error
("missing string quote");
570 elsif S
(P
) = HT
then
571 Error
("tab character in string");
573 elsif S
(P
) /= Q
then
581 -- Check for doubled quote
583 if not At_EOF
and then S
(P
) = Q
then
586 -- Otherwise this is the terminating quote
602 WS_Scan
: while not At_EOF
loop
605 -- End of physical line
608 Line_Num
:= Line_Num
+ 1;
612 and then (S
(P
) = CR
or else S
(P
) = LF
)
614 Line_Num
:= Line_Num
+ 1;
620 -- All other cases of white space characters
622 when ' ' | FF | VT | HT
=>
631 Error
("bad comment");
633 elsif S
(P
) = '-' then
636 while not At_EOF
loop
638 when CR | LF | FF | VT
=>