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