?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2018-08-29 Richard Biener <rguenther@suse.de>
[official-gcc.git] / gcc / ada / sfn_scan.adb
blobe37906d3f4532f61f393cd08bcc2d4dc911b48d8
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-2018, 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 pragma No_Return (Error);
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;
Mirror of the offical gcc git repository hosted at gcc.gnu.org