?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* c-decl.c (duplicate_decls): Conditionalize DECL_SAVED_TREE copy.
[official-gcc.git] / gcc / ada / sfn_scan.adb
blob57bc534f58220751963a1d9e497af1c9afa3b514
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- S F N _ S C A N --
6 -- --
7 -- B o d y --
8 -- --
9 -- $Revision: 1.6 $
10 -- --
11 -- Copyright (C) 2000-2001 Free Software Foundation, Inc. --
12 -- --
13 -- GNAT is free software; you can redistribute it and/or modify it under --
14 -- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
16 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
17 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
18 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
19 -- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
21 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
22 -- MA 02111-1307, USA. --
23 -- --
24 -- As a special exception, if other files instantiate generics from this --
25 -- unit, or you link this unit with other files to produce an executable, --
26 -- this unit does not by itself cause the resulting executable to be --
27 -- covered by the GNU General Public License. This exception does not --
28 -- however invalidate any other reasons why the executable file might be --
29 -- covered by the GNU Public License. --
30 -- --
31 -- GNAT was originally developed by the GNAT team at New York University. --
32 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
33 -- --
34 ------------------------------------------------------------------------------
35
36 with Ada.Exceptions; use Ada.Exceptions;
37
38 package body SFN_Scan is
39
40 use ASCII;
41 -- Allow easy access to control character definitions
42
43 type String_Ptr is access String;
44
45 S : String_Ptr;
46 -- Points to the gnat.adc input file
47
48 P : Natural;
49 -- Subscript of next character to process in S
50
51 Line_Num : Natural;
52 -- Current line number
53
54 Start_Of_Line : Natural;
55 -- Subscript of first character at start of current line
56
57 ----------------------
58 -- Local Procedures --
59 ----------------------
60
61 function Acquire_String (B : Natural; E : Natural) return String;
62 -- This function takes a string scanned out by Scan_String, strips
63 -- the enclosing quote characters and any internal doubled quote
64 -- characters, and returns the result as a String. The arguments
65 -- B and E are as returned from a call to Scan_String. The lower
66 -- bound of the string returned is always 1.
67
68 function Acquire_Unit_Name return String;
69 -- Skips white space, and then scans and returns a unit name. The
70 -- unit name is cased exactly as it appears in the source file.
71 -- The terminating character must be white space, or a comma or
72 -- a right parenthesis or end of file.
73
74 function At_EOF return Boolean;
75 pragma Inline (At_EOF);
76 -- Returns True if at end of file, False if not. Note that this
77 -- function does NOT skip white space, so P is always unchanged.
78
79 procedure Check_Not_At_EOF;
80 pragma Inline (Check_Not_At_EOF);
81 -- Skips past white space if any, and then raises Error if at
82 -- end of file. Otherwise returns with P skipped past whitespace.
83
84 function Check_File_Type return Character;
85 -- Skips white space if any, and then looks for any of the tokens
86 -- Spec_File_Name, Body_File_Name, or Subunit_File_Name. If one
87 -- of these is found then the value returned is 's', 'b' or 'u'
88 -- respectively, and P is bumped past the token. If none of
89 -- these tokens is found, then P is unchanged (except for
90 -- possible skip of white space), and a space is returned.
91
92 function Check_Token (T : String) return Boolean;
93 -- Skips white space if any, and then checks if the string at the
94 -- current location matches the given string T, and the character
95 -- immediately following is non-alphabetic, non-numeric. If so,
96 -- P is stepped past the token, and True is returned. If not,
97 -- P is unchanged (except for possibly skipping past whitespace),
98 -- and False is returned. S may contain only lower-case letters
99 -- ('a' .. 'z').
100
101 procedure Error (Err : String);
102 -- Called if an error is detected. Raises Syntax_Error_In_GNAT_ADC
103 -- with a message of the form gnat.adc:line:col: xxx, where xxx is
104 -- the string Err passed as a parameter.
105
106 procedure Require_Token (T : String);
107 -- Skips white space if any, and then requires the given string
108 -- to be present. If it is, the P is stepped past it, otherwise
109 -- Error is raised, since this is a syntax error. Require_Token
110 -- is used only for sequences of special characters, so there
111 -- is no issue of terminators, or casing of letters.
112
113 procedure Scan_String (B : out Natural; E : out Natural);
114 -- Skips white space if any, then requires that a double quote
115 -- or percent be present (start of string). Raises error if
116 -- neither of these two characters is found. Otherwise scans
117 -- out the string, and returns with P pointing past the
118 -- closing quote and S (B .. E) contains the characters of the
119 -- string (including the enclosing quotes, with internal quotes
120 -- still doubled). Raises Error if the string is malformed.
121
122 procedure Skip_WS;
123 -- Skips P past any white space characters (end of line
124 -- characters, spaces, comments, horizontal tab characters).
125
126 --------------------
127 -- Acquire_String --
128 --------------------
129
130 function Acquire_String (B : Natural; E : Natural) return String is
131 Str : String (1 .. E - B - 1);
132 Q : constant Character := S (B);
133 J : Natural;
134 Ptr : Natural;
135
136 begin
137 Ptr := B + 1;
138 J := 0;
139 while Ptr < E loop
140 J := J + 1;
141 Str (J) := S (Ptr);
142
143 if S (Ptr) = Q and then S (Ptr + 1) = Q then
144 Ptr := Ptr + 2;
145 else
146 Ptr := Ptr + 1;
147 end if;
148 end loop;
149
150 return Str (1 .. J);
151 end Acquire_String;
152
153 -----------------------
154 -- Acquire_Unit_Name --
155 -----------------------
156
157 function Acquire_Unit_Name return String is
158 B : Natural;
159
160 begin
161 Check_Not_At_EOF;
162 B := P;
163
164 while not At_EOF loop
165 exit when S (P) not in '0' .. '9'
166 and then S (P) /= '.'
167 and then S (P) /= '_'
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 not (S (P) = '"' and then S (P + 1) = ']')
171 and then not (S (P) = ']' and then S (P - 1) = '"')
172 and then S (P) < 'A';
173 P := P + 1;
174 end loop;
175
176 if P = B then
177 Error ("null unit name");
178 end if;
179
180 return S (B .. P - 1);
181 end Acquire_Unit_Name;
182
183 ------------
184 -- At_EOF --
185 ------------
186
187 function At_EOF return Boolean is
188 begin
189 return P > S'Last;
190 end At_EOF;
191
192 ---------------------
193 -- Check_File_Type --
194 ---------------------
195
196 function Check_File_Type return Character is
197 begin
198 if Check_Token ("spec_file_name") then
199 return 's';
200 elsif Check_Token ("body_file_name") then
201 return 'b';
202 elsif Check_Token ("subunit_file_name") then
203 return 'u';
204 else
205 return ' ';
206 end if;
207 end Check_File_Type;
208
209 ----------------------
210 -- Check_Not_At_EOF --
211 ----------------------
212
213 procedure Check_Not_At_EOF is
214 begin
215 Skip_WS;
216
217 if At_EOF then
218 Error ("unexpected end of file");
219 end if;
220
221 return;
222 end Check_Not_At_EOF;
223
224 -----------------
225 -- Check_Token --
226 -----------------
227
228 function Check_Token (T : String) return Boolean is
229 Save_P : Natural;
230 C : Character;
231
232 begin
233 Skip_WS;
234 Save_P := P;
235
236 for K in T'Range loop
237 if At_EOF then
238 P := Save_P;
239 return False;
240 end if;
241
242 C := S (P);
243
244 if C in 'A' .. 'Z' then
245 C := Character'Val (Character'Pos (C) +
246 (Character'Pos ('a') - Character'Pos ('A')));
247 end if;
248
249 if C /= T (K) then
250 P := Save_P;
251 return False;
252 end if;
253
254 P := P + 1;
255 end loop;
256
257 if At_EOF then
258 return True;
259 end if;
260
261 C := S (P);
262
263 if C in '0' .. '9'
264 or else C in 'a' .. 'z'
265 or else C in 'A' .. 'Z'
266 or else C > Character'Val (127)
267 then
268 P := Save_P;
269 return False;
270
271 else
272 return True;
273 end if;
274 end Check_Token;
275
276 -----------
277 -- Error --
278 -----------
279
280 procedure Error (Err : String) is
281 C : Natural := 0;
282 -- Column number
283
284 M : String (1 .. 80);
285 -- Buffer used to build resulting error msg
286
287 LM : Natural := 0;
288 -- Pointer to last set location in M
289
290 procedure Add_Nat (N : Natural);
291 -- Add chars of integer to error msg buffer
292
293 procedure Add_Nat (N : Natural) is
294 begin
295 if N > 9 then
296 Add_Nat (N / 10);
297 end if;
298
299 LM := LM + 1;
300 M (LM) := Character'Val (N mod 10 + Character'Pos ('0'));
301 end Add_Nat;
302
303 -- Start of processing for Error
304
305 begin
306 M (1 .. 9) := "gnat.adc:";
307 LM := 9;
308 Add_Nat (Line_Num);
309 LM := LM + 1;
310 M (LM) := ':';
311
312 -- Determine column number
313
314 for X in Start_Of_Line .. P loop
315 C := C + 1;
316
317 if S (X) = HT then
318 C := (C + 7) / 8 * 8;
319 end if;
320 end loop;
321
322 Add_Nat (C);
323 M (LM + 1) := ':';
324 LM := LM + 1;
325 M (LM + 1) := ' ';
326 LM := LM + 1;
327
328 M (LM + 1 .. LM + Err'Length) := Err;
329 LM := LM + Err'Length;
330
331 Raise_Exception (Syntax_Error_In_GNAT_ADC'Identity, M (1 .. LM));
332 end Error;
333
334 -------------------
335 -- Require_Token --
336 -------------------
337
338 procedure Require_Token (T : String) is
339 SaveP : Natural;
340
341 begin
342 Skip_WS;
343 SaveP := P;
344
345 for J in T'Range loop
346
347 if At_EOF or else S (P) /= T (J) then
348 declare
349 S : String (1 .. T'Length + 10);
350
351 begin
352 S (1 .. 9) := "missing """;
353 S (10 .. T'Length + 9) := T;
354 S (T'Length + 10) := '"';
355 P := SaveP;
356 Error (S);
357 end;
358
359 else
360 P := P + 1;
361 end if;
362 end loop;
363 end Require_Token;
364
365 ----------------------
366 -- Scan_SFN_Pragmas --
367 ----------------------
368
369 procedure Scan_SFN_Pragmas
370 (Source : String;
371 SFN_Ptr : Set_File_Name_Ptr;
372 SFNP_Ptr : Set_File_Name_Pattern_Ptr)
373 is
374 B, E : Natural;
375 Typ : Character;
376 Cas : Character;
377
378 begin
379 Line_Num := 1;
380 S := Source'Unrestricted_Access;
381 P := Source'First;
382 Start_Of_Line := P;
383
384 -- Loop through pragmas in file
385
386 Main_Scan_Loop : loop
387 Skip_WS;
388 exit Main_Scan_Loop when At_EOF;
389
390 -- Error if something other than pragma
391
392 if not Check_Token ("pragma") then
393 Error ("non pragma encountered");
394 end if;
395
396 -- Source_File_Name pragma case
397
398 if Check_Token ("source_file_name") then
399 Require_Token ("(");
400
401 Typ := Check_File_Type;
402
403 -- First format, with unit name first
404
405 if Typ = ' ' then
406 if Check_Token ("unit_name") then
407 Require_Token ("=>");
408 end if;
409
410 declare
411 U : constant String := Acquire_Unit_Name;
412
413 begin
414 Require_Token (",");
415 Typ := Check_File_Type;
416
417 if Typ /= 's' and then Typ /= 'b' then
418 Error ("bad pragma");
419 end if;
420
421 Require_Token ("=>");
422 Scan_String (B, E);
423
424 declare
425 F : constant String := Acquire_String (B, E);
426
427 begin
428 Require_Token (")");
429 Require_Token (";");
430 SFN_Ptr.all (Typ, U, F);
431 end;
432 end;
433
434 -- Second format with pattern string
435
436 else
437 Require_Token ("=>");
438 Scan_String (B, E);
439
440 declare
441 Pat : constant String := Acquire_String (B, E);
442 Nas : Natural := 0;
443
444 begin
445 -- Check exactly one asterisk
446
447 for J in Pat'Range loop
448 if Pat (J) = '*' then
449 Nas := Nas + 1;
450 end if;
451 end loop;
452
453 if Nas /= 1 then
454 Error ("** not allowed");
455 end if;
456
457 B := 0;
458 E := 0;
459 Cas := ' ';
460
461 -- Loop to scan out Casing or Dot_Replacement parameters
462
463 loop
464 Check_Not_At_EOF;
465 exit when S (P) = ')';
466 Require_Token (",");
467
468 if Check_Token ("casing") then
469 Require_Token ("=>");
470
471 if Cas /= ' ' then
472 Error ("duplicate casing argument");
473 elsif Check_Token ("lowercase") then
474 Cas := 'l';
475 elsif Check_Token ("uppercase") then
476 Cas := 'u';
477 elsif Check_Token ("mixedcase") then
478 Cas := 'm';
479 else
480 Error ("invalid casing argument");
481 end if;
482
483 elsif Check_Token ("dot_replacement") then
484 Require_Token ("=>");
485
486 if E /= 0 then
487 Error ("duplicate dot_replacement");
488 else
489 Scan_String (B, E);
490 end if;
491
492 else
493 Error ("invalid argument");
494 end if;
495 end loop;
496
497 Require_Token (")");
498 Require_Token (";");
499
500 if Cas = ' ' then
501 Cas := 'l';
502 end if;
503
504 if E = 0 then
505 SFNP_Ptr.all (Pat, Typ, ".", Cas);
506
507 else
508 declare
509 Dot : constant String := Acquire_String (B, E);
510
511 begin
512 SFNP_Ptr.all (Pat, Typ, Dot, Cas);
513 end;
514 end if;
515 end;
516 end if;
517
518 -- Some other pragma, scan to semicolon at end of pragma
519
520 else
521 Skip_Loop : loop
522 exit Main_Scan_Loop when At_EOF;
523 exit Skip_Loop when S (P) = ';';
524
525 if S (P) = '"' or else S (P) = '%' then
526 Scan_String (B, E);
527 else
528 P := P + 1;
529 end if;
530 end loop Skip_Loop;
531
532 -- We successfuly skipped to semicolon, so skip past it
533
534 P := P + 1;
535 end if;
536 end loop Main_Scan_Loop;
537
538 exception
539 when others =>
540 Cursor := P - S'First + 1;
541 raise;
542 end Scan_SFN_Pragmas;
543
544 -----------------
545 -- Scan_String --
546 -----------------
547
548 procedure Scan_String (B : out Natural; E : out Natural) is
549 Q : Character;
550
551 begin
552 Check_Not_At_EOF;
553
554 if S (P) = '"' then
555 Q := '"';
556 elsif S (P) = '%' then
557 Q := '%';
558 else
559 Error ("bad string");
560 Q := '"';
561 end if;
562
563 -- Scan out the string, B points to first char
564
565 B := P;
566 P := P + 1;
567
568 loop
569 if At_EOF or else S (P) = LF or else S (P) = CR then
570 Error ("missing string quote");
571
572 elsif S (P) = HT then
573 Error ("tab character in string");
574
575 elsif S (P) /= Q then
576 P := P + 1;
577
578 -- We have a quote
579
580 else
581 P := P + 1;
582
583 -- Check for doubled quote
584
585 if not At_EOF and then S (P) = Q then
586 P := P + 1;
587
588 -- Otherwise this is the terminating quote
589
590 else
591 E := P - 1;
592 return;
593 end if;
594 end if;
595 end loop;
596 end Scan_String;
597
598 -------------
599 -- Skip_WS --
600 -------------
601
602 procedure Skip_WS is
603 begin
604 WS_Scan : while not At_EOF loop
605 case S (P) is
606
607 -- End of physical line
608
609 when CR | LF =>
610 Line_Num := Line_Num + 1;
611 P := P + 1;
612
613 while not At_EOF
614 and then (S (P) = CR or else S (P) = LF)
615 loop
616 Line_Num := Line_Num + 1;
617 P := P + 1;
618 end loop;
619
620 Start_Of_Line := P;
621
622 -- All other cases of white space characters
623
624 when ' ' | FF | VT | HT =>
625 P := P + 1;
626
627 -- Comment
628
629 when '-' =>
630 P := P + 1;
631
632 if At_EOF then
633 Error ("bad comment");
634
635 elsif S (P) = '-' then
636 P := P + 1;
637
638 while not At_EOF loop
639 case S (P) is
640 when CR | LF | FF | VT =>
641 exit;
642 when others =>
643 P := P + 1;
644 end case;
645 end loop;
646
647 else
648 P := P - 1;
649 exit WS_Scan;
650 end if;
651
652 when others =>
653 exit WS_Scan;
654
655 end case;
656 end loop WS_Scan;
657 end Skip_WS;
658
659 end SFN_Scan;
Mirror of the offical gcc git repository hosted at gcc.gnu.org