?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
LWG 2975 ensure construct(pair<T,U>*, ...) used to construct pairs
[official-gcc.git] / gcc / ada / sfn_scan.adb
blob5dd65fb493989910cbd1c035949fef0581b3ae41
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 -- 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;
Mirror of the offical gcc git repository hosted at gcc.gnu.org