|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- S F N _ S C A N --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 2000-2018, Free Software Foundation, Inc. --
|
|
111
|
10 -- --
|
|
|
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. --
|
|
|
17 -- --
|
|
|
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. --
|
|
|
21 -- --
|
|
|
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/>. --
|
|
|
26 -- --
|
|
|
27 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
29 -- --
|
|
|
30 ------------------------------------------------------------------------------
|
|
|
31
|
|
|
32 with Ada.Exceptions; use Ada.Exceptions;
|
|
|
33
|
|
|
34 package body SFN_Scan is
|
|
|
35
|
|
|
36 use ASCII;
|
|
|
37 -- Allow easy access to control character definitions
|
|
|
38
|
|
|
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.
|
|
|
44
|
|
|
45 type String_Ptr is access String;
|
|
|
46
|
|
|
47 S : String_Ptr;
|
|
|
48 -- Points to the gnat.adc input file
|
|
|
49
|
|
|
50 P : Natural;
|
|
|
51 -- Subscript of next character to process in S
|
|
|
52
|
|
|
53 Line_Num : Natural;
|
|
|
54 -- Current line number
|
|
|
55
|
|
|
56 Start_Of_Line : Natural;
|
|
|
57 -- Subscript of first character at start of current line
|
|
|
58
|
|
|
59 ----------------------
|
|
|
60 -- Local Procedures --
|
|
|
61 ----------------------
|
|
|
62
|
|
|
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.
|
|
|
67
|
|
|
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.
|
|
|
74
|
|
|
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.
|
|
|
80
|
|
|
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.
|
|
|
85
|
|
|
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.
|
|
|
90
|
|
|
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.
|
|
|
98
|
|
|
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. T may contain only lower-case letters
|
|
|
106 -- ('a' .. 'z').
|
|
|
107
|
|
|
108 procedure Error (Err : String);
|
|
131
|
109 pragma No_Return (Error);
|
|
111
|
110 -- Called if an error is detected. Raises Syntax_Error_In_GNAT_ADC
|
|
|
111 -- with a message of the form gnat.adc:line:col: xxx, where xxx is
|
|
|
112 -- the string Err passed as a parameter.
|
|
|
113
|
|
|
114 procedure Require_Token (T : String);
|
|
|
115 -- Skips white space if any, and then requires the given string
|
|
|
116 -- to be present. If it is, the P is stepped past it, otherwise
|
|
|
117 -- Error is raised, since this is a syntax error. Require_Token
|
|
|
118 -- is used only for sequences of special characters, so there
|
|
|
119 -- is no issue of terminators, or casing of letters.
|
|
|
120
|
|
|
121 procedure Scan_String (B : out Natural; E : out Natural);
|
|
|
122 -- Skips white space if any, then requires that a double quote
|
|
|
123 -- or percent be present (start of string). Raises error if
|
|
|
124 -- neither of these two characters is found. Otherwise scans
|
|
|
125 -- out the string, and returns with P pointing past the
|
|
|
126 -- closing quote and S (B .. E) contains the characters of the
|
|
|
127 -- string (including the enclosing quotes, with internal quotes
|
|
|
128 -- still doubled). Raises Error if the string is malformed.
|
|
|
129
|
|
|
130 procedure Skip_WS;
|
|
|
131 -- Skips P past any white space characters (end of line
|
|
|
132 -- characters, spaces, comments, horizontal tab characters).
|
|
|
133
|
|
|
134 ---------------------
|
|
|
135 -- Acquire_Integer --
|
|
|
136 ---------------------
|
|
|
137
|
|
|
138 function Acquire_Integer return Natural is
|
|
|
139 N : Natural := 0;
|
|
|
140
|
|
|
141 begin
|
|
|
142 Skip_WS;
|
|
|
143
|
|
|
144 if S (P) not in '0' .. '9' then
|
|
|
145 Error ("missing index parameter");
|
|
|
146 end if;
|
|
|
147
|
|
|
148 while S (P) in '0' .. '9' loop
|
|
|
149 N := N * 10 + Character'Pos (S (P)) - Character'Pos ('0');
|
|
|
150
|
|
|
151 if N > 999 then
|
|
|
152 Error ("index value greater than 999");
|
|
|
153 end if;
|
|
|
154
|
|
|
155 P := P + 1;
|
|
|
156 end loop;
|
|
|
157
|
|
|
158 return N;
|
|
|
159 end Acquire_Integer;
|
|
|
160
|
|
|
161 --------------------
|
|
|
162 -- Acquire_String --
|
|
|
163 --------------------
|
|
|
164
|
|
|
165 function Acquire_String (B : Natural; E : Natural) return String is
|
|
|
166 Str : String (1 .. E - B - 1);
|
|
|
167 Q : constant Character := S (B);
|
|
|
168 J : Natural;
|
|
|
169 Ptr : Natural;
|
|
|
170
|
|
|
171 begin
|
|
|
172 Ptr := B + 1;
|
|
|
173 J := 0;
|
|
|
174 while Ptr < E loop
|
|
|
175 J := J + 1;
|
|
|
176 Str (J) := S (Ptr);
|
|
|
177
|
|
|
178 if S (Ptr) = Q and then S (Ptr + 1) = Q then
|
|
|
179 Ptr := Ptr + 2;
|
|
|
180 else
|
|
|
181 Ptr := Ptr + 1;
|
|
|
182 end if;
|
|
|
183 end loop;
|
|
|
184
|
|
|
185 return Str (1 .. J);
|
|
|
186 end Acquire_String;
|
|
|
187
|
|
|
188 -----------------------
|
|
|
189 -- Acquire_Unit_Name --
|
|
|
190 -----------------------
|
|
|
191
|
|
|
192 function Acquire_Unit_Name return String is
|
|
|
193 B : Natural;
|
|
|
194
|
|
|
195 begin
|
|
|
196 Check_Not_At_EOF;
|
|
|
197 B := P;
|
|
|
198
|
|
|
199 while not At_EOF loop
|
|
|
200 exit when S (P) not in '0' .. '9'
|
|
|
201 and then S (P) /= '.'
|
|
|
202 and then S (P) /= '_'
|
|
|
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 not (S (P) = ']' and then S (P - 1) = '"')
|
|
|
207 and then S (P) < 'A';
|
|
|
208 P := P + 1;
|
|
|
209 end loop;
|
|
|
210
|
|
|
211 if P = B then
|
|
|
212 Error ("null unit name");
|
|
|
213 end if;
|
|
|
214
|
|
|
215 return S (B .. P - 1);
|
|
|
216 end Acquire_Unit_Name;
|
|
|
217
|
|
|
218 ------------
|
|
|
219 -- At_EOF --
|
|
|
220 ------------
|
|
|
221
|
|
|
222 function At_EOF return Boolean is
|
|
|
223 begin
|
|
|
224 -- Immediate return (False) if before last character of file
|
|
|
225
|
|
|
226 if P < S'Last then
|
|
|
227 return False;
|
|
|
228
|
|
|
229 -- Special case: DOS EOF character as last character of file is
|
|
|
230 -- allowed and treated as an end of file.
|
|
|
231
|
|
|
232 elsif P = S'Last then
|
|
|
233 return S (P) = EOF;
|
|
|
234
|
|
|
235 -- If beyond last character of file, then definitely at EOF
|
|
|
236
|
|
|
237 else
|
|
|
238 return True;
|
|
|
239 end if;
|
|
|
240 end At_EOF;
|
|
|
241
|
|
|
242 ---------------------
|
|
|
243 -- Check_File_Type --
|
|
|
244 ---------------------
|
|
|
245
|
|
|
246 function Check_File_Type return Character is
|
|
|
247 begin
|
|
|
248 if Check_Token ("spec_file_name") then
|
|
|
249 return 's';
|
|
|
250 elsif Check_Token ("body_file_name") then
|
|
|
251 return 'b';
|
|
|
252 elsif Check_Token ("subunit_file_name") then
|
|
|
253 return 'u';
|
|
|
254 else
|
|
|
255 return ' ';
|
|
|
256 end if;
|
|
|
257 end Check_File_Type;
|
|
|
258
|
|
|
259 ----------------------
|
|
|
260 -- Check_Not_At_EOF --
|
|
|
261 ----------------------
|
|
|
262
|
|
|
263 procedure Check_Not_At_EOF is
|
|
|
264 begin
|
|
|
265 Skip_WS;
|
|
|
266
|
|
|
267 if At_EOF then
|
|
|
268 Error ("unexpected end of file");
|
|
|
269 end if;
|
|
|
270
|
|
|
271 return;
|
|
|
272 end Check_Not_At_EOF;
|
|
|
273
|
|
|
274 -----------------
|
|
|
275 -- Check_Token --
|
|
|
276 -----------------
|
|
|
277
|
|
|
278 function Check_Token (T : String) return Boolean is
|
|
|
279 Save_P : Natural;
|
|
|
280 C : Character;
|
|
|
281
|
|
|
282 begin
|
|
|
283 Skip_WS;
|
|
|
284 Save_P := P;
|
|
|
285
|
|
|
286 for K in T'Range loop
|
|
|
287 if At_EOF then
|
|
|
288 P := Save_P;
|
|
|
289 return False;
|
|
|
290 end if;
|
|
|
291
|
|
|
292 C := S (P);
|
|
|
293
|
|
|
294 if C in 'A' .. 'Z' then
|
|
|
295 C := Character'Val (Character'Pos (C) +
|
|
|
296 (Character'Pos ('a') - Character'Pos ('A')));
|
|
|
297 end if;
|
|
|
298
|
|
|
299 if C /= T (K) then
|
|
|
300 P := Save_P;
|
|
|
301 return False;
|
|
|
302 end if;
|
|
|
303
|
|
|
304 P := P + 1;
|
|
|
305 end loop;
|
|
|
306
|
|
|
307 if At_EOF then
|
|
|
308 return True;
|
|
|
309 end if;
|
|
|
310
|
|
|
311 C := S (P);
|
|
|
312
|
|
|
313 if C in '0' .. '9'
|
|
|
314 or else C in 'a' .. 'z'
|
|
|
315 or else C in 'A' .. 'Z'
|
|
|
316 or else C > Character'Val (127)
|
|
|
317 then
|
|
|
318 P := Save_P;
|
|
|
319 return False;
|
|
|
320
|
|
|
321 else
|
|
|
322 return True;
|
|
|
323 end if;
|
|
|
324 end Check_Token;
|
|
|
325
|
|
|
326 -----------
|
|
|
327 -- Error --
|
|
|
328 -----------
|
|
|
329
|
|
|
330 procedure Error (Err : String) is
|
|
|
331 C : Natural := 0;
|
|
|
332 -- Column number
|
|
|
333
|
|
|
334 M : String (1 .. 80);
|
|
|
335 -- Buffer used to build resulting error msg
|
|
|
336
|
|
|
337 LM : Natural := 0;
|
|
|
338 -- Pointer to last set location in M
|
|
|
339
|
|
|
340 procedure Add_Nat (N : Natural);
|
|
|
341 -- Add chars of integer to error msg buffer
|
|
|
342
|
|
|
343 -------------
|
|
|
344 -- Add_Nat --
|
|
|
345 -------------
|
|
|
346
|
|
|
347 procedure Add_Nat (N : Natural) is
|
|
|
348 begin
|
|
|
349 if N > 9 then
|
|
|
350 Add_Nat (N / 10);
|
|
|
351 end if;
|
|
|
352
|
|
|
353 LM := LM + 1;
|
|
|
354 M (LM) := Character'Val (N mod 10 + Character'Pos ('0'));
|
|
|
355 end Add_Nat;
|
|
|
356
|
|
|
357 -- Start of processing for Error
|
|
|
358
|
|
|
359 begin
|
|
|
360 M (1 .. 9) := "gnat.adc:";
|
|
|
361 LM := 9;
|
|
|
362 Add_Nat (Line_Num);
|
|
|
363 LM := LM + 1;
|
|
|
364 M (LM) := ':';
|
|
|
365
|
|
|
366 -- Determine column number
|
|
|
367
|
|
|
368 for X in Start_Of_Line .. P loop
|
|
|
369 C := C + 1;
|
|
|
370
|
|
|
371 if S (X) = HT then
|
|
|
372 C := (C + 7) / 8 * 8;
|
|
|
373 end if;
|
|
|
374 end loop;
|
|
|
375
|
|
|
376 Add_Nat (C);
|
|
|
377 M (LM + 1) := ':';
|
|
|
378 LM := LM + 1;
|
|
|
379 M (LM + 1) := ' ';
|
|
|
380 LM := LM + 1;
|
|
|
381
|
|
|
382 M (LM + 1 .. LM + Err'Length) := Err;
|
|
|
383 LM := LM + Err'Length;
|
|
|
384
|
|
|
385 Raise_Exception (Syntax_Error_In_GNAT_ADC'Identity, M (1 .. LM));
|
|
|
386 end Error;
|
|
|
387
|
|
|
388 -------------------
|
|
|
389 -- Require_Token --
|
|
|
390 -------------------
|
|
|
391
|
|
|
392 procedure Require_Token (T : String) is
|
|
|
393 SaveP : Natural;
|
|
|
394
|
|
|
395 begin
|
|
|
396 Skip_WS;
|
|
|
397 SaveP := P;
|
|
|
398
|
|
|
399 for J in T'Range loop
|
|
|
400
|
|
|
401 if At_EOF or else S (P) /= T (J) then
|
|
|
402 declare
|
|
|
403 S : String (1 .. T'Length + 10);
|
|
|
404
|
|
|
405 begin
|
|
|
406 S (1 .. 9) := "missing """;
|
|
|
407 S (10 .. T'Length + 9) := T;
|
|
|
408 S (T'Length + 10) := '"';
|
|
|
409 P := SaveP;
|
|
|
410 Error (S);
|
|
|
411 end;
|
|
|
412
|
|
|
413 else
|
|
|
414 P := P + 1;
|
|
|
415 end if;
|
|
|
416 end loop;
|
|
|
417 end Require_Token;
|
|
|
418
|
|
|
419 ----------------------
|
|
|
420 -- Scan_SFN_Pragmas --
|
|
|
421 ----------------------
|
|
|
422
|
|
|
423 procedure Scan_SFN_Pragmas
|
|
|
424 (Source : String;
|
|
|
425 SFN_Ptr : Set_File_Name_Ptr;
|
|
|
426 SFNP_Ptr : Set_File_Name_Pattern_Ptr)
|
|
|
427 is
|
|
|
428 B, E : Natural;
|
|
|
429 Typ : Character;
|
|
|
430 Cas : Character;
|
|
|
431
|
|
|
432 begin
|
|
|
433 Line_Num := 1;
|
|
|
434 S := Source'Unrestricted_Access;
|
|
|
435 P := Source'First;
|
|
|
436 Start_Of_Line := P;
|
|
|
437
|
|
|
438 -- Loop through pragmas in file
|
|
|
439
|
|
|
440 Main_Scan_Loop : loop
|
|
|
441 Skip_WS;
|
|
|
442 exit Main_Scan_Loop when At_EOF;
|
|
|
443
|
|
|
444 -- Error if something other than pragma
|
|
|
445
|
|
|
446 if not Check_Token ("pragma") then
|
|
|
447 Error ("non pragma encountered");
|
|
|
448 end if;
|
|
|
449
|
|
|
450 -- Source_File_Name pragma case
|
|
|
451
|
|
|
452 if Check_Token ("source_file_name")
|
|
|
453 or else
|
|
|
454 Check_Token ("source_file_name_project")
|
|
|
455 then
|
|
|
456 Require_Token ("(");
|
|
|
457
|
|
|
458 Typ := Check_File_Type;
|
|
|
459
|
|
|
460 -- First format, with unit name first
|
|
|
461
|
|
|
462 if Typ = ' ' then
|
|
|
463 if Check_Token ("unit_name") then
|
|
|
464 Require_Token ("=>");
|
|
|
465 end if;
|
|
|
466
|
|
|
467 declare
|
|
|
468 U : constant String := Acquire_Unit_Name;
|
|
|
469
|
|
|
470 begin
|
|
|
471 Require_Token (",");
|
|
|
472 Typ := Check_File_Type;
|
|
|
473
|
|
|
474 if Typ /= 's' and then Typ /= 'b' then
|
|
|
475 Error ("bad pragma");
|
|
|
476 end if;
|
|
|
477
|
|
|
478 Require_Token ("=>");
|
|
|
479 Scan_String (B, E);
|
|
|
480
|
|
|
481 declare
|
|
|
482 F : constant String := Acquire_String (B, E);
|
|
|
483 X : Natural;
|
|
|
484
|
|
|
485 begin
|
|
|
486 -- Scan Index parameter if present
|
|
|
487
|
|
|
488 if Check_Token (",") then
|
|
|
489 if Check_Token ("index") then
|
|
|
490 Require_Token ("=>");
|
|
|
491 end if;
|
|
|
492
|
|
|
493 X := Acquire_Integer;
|
|
|
494 else
|
|
|
495 X := 0;
|
|
|
496 end if;
|
|
|
497
|
|
|
498 Require_Token (")");
|
|
|
499 Require_Token (";");
|
|
|
500 SFN_Ptr.all (Typ, U, F, X);
|
|
|
501 end;
|
|
|
502 end;
|
|
|
503
|
|
|
504 -- Second format with pattern string
|
|
|
505
|
|
|
506 else
|
|
|
507 Require_Token ("=>");
|
|
|
508 Scan_String (B, E);
|
|
|
509
|
|
|
510 declare
|
|
|
511 Pat : constant String := Acquire_String (B, E);
|
|
|
512 Nas : Natural := 0;
|
|
|
513
|
|
|
514 begin
|
|
|
515 -- Check exactly one asterisk
|
|
|
516
|
|
|
517 for J in Pat'Range loop
|
|
|
518 if Pat (J) = '*' then
|
|
|
519 Nas := Nas + 1;
|
|
|
520 end if;
|
|
|
521 end loop;
|
|
|
522
|
|
|
523 if Nas /= 1 then
|
|
|
524 Error ("** not allowed");
|
|
|
525 end if;
|
|
|
526
|
|
|
527 B := 0;
|
|
|
528 E := 0;
|
|
|
529 Cas := ' ';
|
|
|
530
|
|
|
531 -- Loop to scan out Casing or Dot_Replacement parameters
|
|
|
532
|
|
|
533 loop
|
|
|
534 Check_Not_At_EOF;
|
|
|
535 exit when S (P) = ')';
|
|
|
536 Require_Token (",");
|
|
|
537
|
|
|
538 if Check_Token ("casing") then
|
|
|
539 Require_Token ("=>");
|
|
|
540
|
|
|
541 if Cas /= ' ' then
|
|
|
542 Error ("duplicate casing argument");
|
|
|
543 elsif Check_Token ("lowercase") then
|
|
|
544 Cas := 'l';
|
|
|
545 elsif Check_Token ("uppercase") then
|
|
|
546 Cas := 'u';
|
|
|
547 elsif Check_Token ("mixedcase") then
|
|
|
548 Cas := 'm';
|
|
|
549 else
|
|
|
550 Error ("invalid casing argument");
|
|
|
551 end if;
|
|
|
552
|
|
|
553 elsif Check_Token ("dot_replacement") then
|
|
|
554 Require_Token ("=>");
|
|
|
555
|
|
|
556 if E /= 0 then
|
|
|
557 Error ("duplicate dot_replacement");
|
|
|
558 else
|
|
|
559 Scan_String (B, E);
|
|
|
560 end if;
|
|
|
561
|
|
|
562 else
|
|
|
563 Error ("invalid argument");
|
|
|
564 end if;
|
|
|
565 end loop;
|
|
|
566
|
|
|
567 Require_Token (")");
|
|
|
568 Require_Token (";");
|
|
|
569
|
|
|
570 if Cas = ' ' then
|
|
|
571 Cas := 'l';
|
|
|
572 end if;
|
|
|
573
|
|
|
574 if E = 0 then
|
|
|
575 SFNP_Ptr.all (Pat, Typ, ".", Cas);
|
|
|
576
|
|
|
577 else
|
|
|
578 declare
|
|
|
579 Dot : constant String := Acquire_String (B, E);
|
|
|
580
|
|
|
581 begin
|
|
|
582 SFNP_Ptr.all (Pat, Typ, Dot, Cas);
|
|
|
583 end;
|
|
|
584 end if;
|
|
|
585 end;
|
|
|
586 end if;
|
|
|
587
|
|
|
588 -- Some other pragma, scan to semicolon at end of pragma
|
|
|
589
|
|
|
590 else
|
|
|
591 Skip_Loop : loop
|
|
|
592 exit Main_Scan_Loop when At_EOF;
|
|
|
593 exit Skip_Loop when S (P) = ';';
|
|
|
594
|
|
|
595 if S (P) = '"' or else S (P) = '%' then
|
|
|
596 Scan_String (B, E);
|
|
|
597 else
|
|
|
598 P := P + 1;
|
|
|
599 end if;
|
|
|
600 end loop Skip_Loop;
|
|
|
601
|
|
|
602 -- We successfully skipped to semicolon, so skip past it
|
|
|
603
|
|
|
604 P := P + 1;
|
|
|
605 end if;
|
|
|
606 end loop Main_Scan_Loop;
|
|
|
607
|
|
|
608 exception
|
|
|
609 when others =>
|
|
|
610 Cursor := P - S'First + 1;
|
|
|
611 raise;
|
|
|
612 end Scan_SFN_Pragmas;
|
|
|
613
|
|
|
614 -----------------
|
|
|
615 -- Scan_String --
|
|
|
616 -----------------
|
|
|
617
|
|
|
618 procedure Scan_String (B : out Natural; E : out Natural) is
|
|
|
619 Q : Character;
|
|
|
620
|
|
|
621 begin
|
|
|
622 Check_Not_At_EOF;
|
|
|
623
|
|
|
624 if S (P) = '"' then
|
|
|
625 Q := '"';
|
|
|
626 elsif S (P) = '%' then
|
|
|
627 Q := '%';
|
|
|
628 else
|
|
|
629 Error ("bad string");
|
|
|
630 Q := '"';
|
|
|
631 end if;
|
|
|
632
|
|
|
633 -- Scan out the string, B points to first char
|
|
|
634
|
|
|
635 B := P;
|
|
|
636 P := P + 1;
|
|
|
637
|
|
|
638 loop
|
|
|
639 if At_EOF or else S (P) = LF or else S (P) = CR then
|
|
|
640 Error -- CODEFIX
|
|
|
641 ("missing string quote");
|
|
|
642
|
|
|
643 elsif S (P) = HT then
|
|
|
644 Error ("tab character in string");
|
|
|
645
|
|
|
646 elsif S (P) /= Q then
|
|
|
647 P := P + 1;
|
|
|
648
|
|
|
649 -- We have a quote
|
|
|
650
|
|
|
651 else
|
|
|
652 P := P + 1;
|
|
|
653
|
|
|
654 -- Check for doubled quote
|
|
|
655
|
|
|
656 if not At_EOF and then S (P) = Q then
|
|
|
657 P := P + 1;
|
|
|
658
|
|
|
659 -- Otherwise this is the terminating quote
|
|
|
660
|
|
|
661 else
|
|
|
662 E := P - 1;
|
|
|
663 return;
|
|
|
664 end if;
|
|
|
665 end if;
|
|
|
666 end loop;
|
|
|
667 end Scan_String;
|
|
|
668
|
|
|
669 -------------
|
|
|
670 -- Skip_WS --
|
|
|
671 -------------
|
|
|
672
|
|
|
673 procedure Skip_WS is
|
|
|
674 begin
|
|
|
675 WS_Scan : while not At_EOF loop
|
|
|
676 case S (P) is
|
|
|
677
|
|
|
678 -- End of physical line
|
|
|
679
|
|
|
680 when CR | LF =>
|
|
|
681 Line_Num := Line_Num + 1;
|
|
|
682 P := P + 1;
|
|
|
683
|
|
|
684 while not At_EOF
|
|
|
685 and then (S (P) = CR or else S (P) = LF)
|
|
|
686 loop
|
|
|
687 Line_Num := Line_Num + 1;
|
|
|
688 P := P + 1;
|
|
|
689 end loop;
|
|
|
690
|
|
|
691 Start_Of_Line := P;
|
|
|
692
|
|
|
693 -- All other cases of white space characters
|
|
|
694
|
|
|
695 when ' ' | FF | VT | HT =>
|
|
|
696 P := P + 1;
|
|
|
697
|
|
|
698 -- Comment
|
|
|
699
|
|
|
700 when '-' =>
|
|
|
701 P := P + 1;
|
|
|
702
|
|
|
703 if At_EOF then
|
|
|
704 Error ("bad comment");
|
|
|
705
|
|
|
706 elsif S (P) = '-' then
|
|
|
707 P := P + 1;
|
|
|
708
|
|
|
709 while not At_EOF loop
|
|
|
710 case S (P) is
|
|
|
711 when CR | LF | FF | VT =>
|
|
|
712 exit;
|
|
|
713 when others =>
|
|
|
714 P := P + 1;
|
|
|
715 end case;
|
|
|
716 end loop;
|
|
|
717
|
|
|
718 else
|
|
|
719 P := P - 1;
|
|
|
720 exit WS_Scan;
|
|
|
721 end if;
|
|
|
722
|
|
|
723 when others =>
|
|
|
724 exit WS_Scan;
|
|
|
725
|
|
|
726 end case;
|
|
|
727 end loop WS_Scan;
|
|
|
728 end Skip_WS;
|
|
|
729
|
|
|
730 end SFN_Scan;
|
