1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 2000-2023, 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. 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Ada
.Exceptions
; use Ada
.Exceptions
;
28 package body SFN_Scan
is
31 -- Allow easy access to control character definitions
33 EOF
: constant Character := ASCII
.SUB
;
34 -- The character SUB (16#1A#) is used in DOS-derived systems, such as
35 -- Windows to signal the end of a text file. If this character appears as
36 -- the last character of a file scanned by a call to Scan_SFN_Pragmas, then
37 -- it is ignored, otherwise it is treated as an illegal character.
39 type String_Ptr
is access String;
42 -- Points to the gnat.adc input file
45 -- Subscript of next character to process in S
48 -- Current line number
50 Start_Of_Line
: Natural;
51 -- Subscript of first character at start of current line
53 ----------------------
54 -- Local Procedures --
55 ----------------------
57 function Acquire_Integer
return Natural;
58 -- This function skips white space, and then scans and returns
59 -- an unsigned integer. Raises Error if no integer is present
60 -- or if the integer is greater than 999.
62 function Acquire_String
(B
: Natural; E
: Natural) return String;
63 -- This function takes a string scanned out by Scan_String, strips
64 -- the enclosing quote characters and any internal doubled quote
65 -- characters, and returns the result as a String. The arguments
66 -- B and E are as returned from a call to Scan_String. The lower
67 -- bound of the string returned is always 1.
69 function Acquire_Unit_Name
return String;
70 -- Skips white space, and then scans and returns a unit name. The
71 -- unit name is cased exactly as it appears in the source file.
72 -- The terminating character must be white space, or a comma or
73 -- a right parenthesis or end of file.
75 function At_EOF
return Boolean;
76 pragma Inline
(At_EOF
);
77 -- Returns True if at end of file, False if not. Note that this
78 -- function does NOT skip white space, so P is always unchanged.
80 procedure Check_Not_At_EOF
;
81 pragma Inline
(Check_Not_At_EOF
);
82 -- Skips past white space if any, and then raises Error if at
83 -- end of file. Otherwise returns with P skipped past whitespace.
85 function Check_File_Type
return Character;
86 -- Skips white space if any, and then looks for any of the tokens
87 -- Spec_File_Name, Body_File_Name, or Subunit_File_Name. If one
88 -- of these is found then the value returned is 's', 'b' or 'u'
89 -- respectively, and P is bumped past the token. If none of
90 -- these tokens is found, then P is unchanged (except for
91 -- possible skip of white space), and a space is returned.
93 function Check_Token
(T
: String) return Boolean;
94 -- Skips white space if any, and then checks if the string at the
95 -- current location matches the given string T, and the character
96 -- immediately following is non-alphabetic, non-numeric. If so,
97 -- P is stepped past the token, and True is returned. If not,
98 -- P is unchanged (except for possibly skipping past whitespace),
99 -- and False is returned. T may contain only lower-case letters
102 procedure Error
(Err
: String);
103 pragma No_Return
(Error
);
104 -- Called if an error is detected. Raises Syntax_Error_In_GNAT_ADC
105 -- with a message of the form gnat.adc:line:col: xxx, where xxx is
106 -- the string Err passed as a parameter.
108 procedure Require_Token
(T
: String);
109 -- Skips white space if any, and then requires the given string
110 -- to be present. If it is, the P is stepped past it, otherwise
111 -- Error is raised, since this is a syntax error. Require_Token
112 -- is used only for sequences of special characters, so there
113 -- is no issue of terminators, or casing of letters.
115 procedure Scan_String
(B
: out Natural; E
: out Natural);
116 -- Skips white space if any, then requires that a double quote
117 -- or percent be present (start of string). Raises error if
118 -- neither of these two characters is found. Otherwise scans
119 -- out the string, and returns with P pointing past the
120 -- closing quote and S (B .. E) contains the characters of the
121 -- string (including the enclosing quotes, with internal quotes
122 -- still doubled). Raises Error if the string is malformed.
125 -- Skips P past any white space characters (end of line
126 -- characters, spaces, comments, horizontal tab characters).
128 ---------------------
129 -- Acquire_Integer --
130 ---------------------
132 function Acquire_Integer
return Natural is
138 if S
(P
) not in '0' .. '9' then
139 Error
("missing index parameter");
142 while S
(P
) in '0' .. '9' loop
143 N
:= N
* 10 + Character'Pos (S
(P
)) - Character'Pos ('0');
146 Error
("index value greater than 999");
159 function Acquire_String
(B
: Natural; E
: Natural) return String is
160 Str
: String (1 .. E
- B
- 1);
161 Q
: constant Character := S
(B
);
172 if S
(Ptr
) = Q
and then S
(Ptr
+ 1) = Q
then
182 -----------------------
183 -- Acquire_Unit_Name --
184 -----------------------
186 function Acquire_Unit_Name
return String is
193 while not At_EOF
loop
194 exit when S
(P
) not in '0' .. '9'
195 and then S
(P
) /= '.'
196 and then S
(P
) /= '_'
197 and then not (S
(P
) = '[' and then S
(P
+ 1) = '"')
198 and then not (S
(P
) = '"' and then S
(P
- 1) = '[')
199 and then not (S
(P
) = '"' and then S
(P
+ 1) = ']')
200 and then not (S
(P
) = ']' and then S
(P
- 1) = '"')
201 and then S
(P
) < 'A';
206 Error
("null unit name");
209 return S
(B
.. P
- 1);
210 end Acquire_Unit_Name
;
216 function At_EOF
return Boolean is
218 -- Immediate return (False) if before last character of file
223 -- Special case: DOS EOF character as last character of file is
224 -- allowed and treated as an end of file.
226 elsif P
= S
'Last then
229 -- If beyond last character of file, then definitely at EOF
236 ---------------------
237 -- Check_File_Type --
238 ---------------------
240 function Check_File_Type
return Character is
242 if Check_Token
("spec_file_name") then
244 elsif Check_Token
("body_file_name") then
246 elsif Check_Token
("subunit_file_name") then
253 ----------------------
254 -- Check_Not_At_EOF --
255 ----------------------
257 procedure Check_Not_At_EOF
is
262 Error
("unexpected end of file");
266 end Check_Not_At_EOF
;
272 function Check_Token
(T
: String) return Boolean is
280 for K
in T
'Range loop
288 if C
in 'A' .. 'Z' then
289 C
:= Character'Val (Character'Pos (C
) +
290 (Character'Pos ('a') - Character'Pos ('A')));
308 or else C
in 'a' .. 'z'
309 or else C
in 'A' .. 'Z'
310 or else C
> Character'Val (127)
324 procedure Error
(Err
: String) is
328 M
: String (1 .. 80);
329 -- Buffer used to build resulting error msg
332 -- Pointer to last set location in M
334 procedure Add_Nat
(N
: Natural);
335 -- Add chars of integer to error msg buffer
341 procedure Add_Nat
(N
: Natural) is
348 M
(LM
) := Character'Val (N
mod 10 + Character'Pos ('0'));
351 -- Start of processing for Error
354 M
(1 .. 9) := "gnat.adc:";
360 -- Determine column number
362 for X
in Start_Of_Line
.. P
loop
366 C
:= (C
+ 7) / 8 * 8;
376 M
(LM
+ 1 .. LM
+ Err
'Length) := Err
;
377 LM
:= LM
+ Err
'Length;
379 Raise_Exception
(Syntax_Error_In_GNAT_ADC
'Identity, M
(1 .. LM
));
386 procedure Require_Token
(T
: String) is
393 for J
in T
'Range loop
395 if At_EOF
or else S
(P
) /= T
(J
) then
397 S
: String (1 .. T
'Length + 10);
400 S
(1 .. 9) := "missing """;
401 S
(10 .. T
'Length + 9) := T
;
402 S
(T
'Length + 10) := '"';
413 ----------------------
414 -- Scan_SFN_Pragmas --
415 ----------------------
417 procedure Scan_SFN_Pragmas
419 SFN_Ptr
: Set_File_Name_Ptr
;
420 SFNP_Ptr
: Set_File_Name_Pattern_Ptr
)
428 S
:= Source
'Unrestricted_Access;
432 -- Loop through pragmas in file
434 Main_Scan_Loop
: loop
436 exit Main_Scan_Loop
when At_EOF
;
438 -- Error if something other than pragma
440 if not Check_Token
("pragma") then
441 Error
("non pragma encountered");
444 -- Source_File_Name pragma case
446 if Check_Token
("source_file_name")
448 Check_Token
("source_file_name_project")
452 Typ
:= Check_File_Type
;
454 -- First format, with unit name first
457 if Check_Token
("unit_name") then
458 Require_Token
("=>");
462 U
: constant String := Acquire_Unit_Name
;
466 Typ
:= Check_File_Type
;
468 if Typ
/= 's' and then Typ
/= 'b' then
469 Error
("bad pragma");
472 Require_Token
("=>");
476 F
: constant String := Acquire_String
(B
, E
);
480 -- Scan Index parameter if present
482 if Check_Token
(",") then
483 if Check_Token
("index") then
484 Require_Token
("=>");
487 X
:= Acquire_Integer
;
494 SFN_Ptr
.all (Typ
, U
, F
, X
);
498 -- Second format with pattern string
501 Require_Token
("=>");
505 Pat
: constant String := Acquire_String
(B
, E
);
509 -- Check exactly one asterisk
511 for J
in Pat
'Range loop
512 if Pat
(J
) = '*' then
518 Error
("** not allowed");
525 -- Loop to scan out Casing or Dot_Replacement parameters
529 exit when S
(P
) = ')';
532 if Check_Token
("casing") then
533 Require_Token
("=>");
536 Error
("duplicate casing argument");
537 elsif Check_Token
("lowercase") then
539 elsif Check_Token
("uppercase") then
541 elsif Check_Token
("mixedcase") then
544 Error
("invalid casing argument");
547 elsif Check_Token
("dot_replacement") then
548 Require_Token
("=>");
551 Error
("duplicate dot_replacement");
557 Error
("invalid argument");
569 SFNP_Ptr
.all (Pat
, Typ
, ".", Cas
);
573 Dot
: constant String := Acquire_String
(B
, E
);
576 SFNP_Ptr
.all (Pat
, Typ
, Dot
, Cas
);
582 -- Some other pragma, scan to semicolon at end of pragma
587 exit Main_Scan_Loop
when At_EOF
;
588 exit Skip_Loop
when S
(P
) = ';';
590 if S
(P
) = '"' or else S
(P
) = '%' then
597 -- We successfully skipped to semicolon, so skip past it
601 end loop Main_Scan_Loop
;
605 pragma Assert
(P
'Valid);
606 Cursor
:= P
- S
'First + 1;
608 end Scan_SFN_Pragmas
;
614 procedure Scan_String
(B
: out Natural; E
: out Natural) is
622 elsif S
(P
) = '%' then
625 Error
("bad string");
628 -- Scan out the string, B points to first char
634 if At_EOF
or else S
(P
) = LF
or else S
(P
) = CR
then
636 ("missing string quote");
638 elsif S
(P
) = HT
then
639 Error
("tab character in string");
641 elsif S
(P
) /= Q
then
649 -- Check for doubled quote
651 if not At_EOF
and then S
(P
) = Q
then
654 -- Otherwise this is the terminating quote
670 WS_Scan
: while not At_EOF
loop
673 -- End of physical line
676 Line_Num
:= Line_Num
+ 1;
680 and then (S
(P
) = CR
or else S
(P
) = LF
)
682 Line_Num
:= Line_Num
+ 1;
688 -- All other cases of white space characters
690 when ' ' | FF | VT | HT
=>
699 Error
("bad comment");
701 elsif S
(P
) = '-' then
704 while not At_EOF
loop
706 when CR | LF | FF | VT
=>