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