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