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