?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* config/rs6000/rs6000.md: Document why a pattern is not
[official-gcc.git] / gcc / ada / xgnatugn.adb
blob5a992f4e8ed728954d1e943f39109c1f8db6a82d
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT SYSTEM UTILITIES --
4 -- --
5 -- X G N A T U G N --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2003-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 ------------------------------------------------------------------------------
23
24 -- This utility is used to process the source of gnat_ugn.texi to make a
25 -- version suitable for running through standard Texinfo processor. It is
26 -- invoked as follows:
27
28 -- xgnatugn <target> <in-file> <word-list> [ <out-file> [ <warnings> ] ]
29
30 -- 1. <target> is the target type of the manual, which is one of:
31
32 -- unw Unix and Windows platforms
33 -- vms OpenVMS
34
35 -- 2. <in-file> is the file name of the Texinfo file to be
36 -- preprocessed.
37
38 -- 3. <word-list> is the name of the word list file. This file is used for
39 -- rewriting the VMS edition. Each line contains a word mapping: The source
40 -- word in the first column, the target word in the second column. The
41 -- columns are separated by a '^' character. When preprocessing for VMS, the
42 -- first word is replaced with the second. (Words consist of letters,
43 -- digits, and the four characters "?-_~". A sequence of multiple words can
44 -- be replaced if they are listed in the first column, separated by a single
45 -- space character. If multiple words are to be replaced, there must be a
46 -- replacement for each prefix.)
47
48 -- 4. <out-file> (optional) is the name of the output file. It defaults to
49 -- gnat_ugn_unw.texi or gnat_ugn_vms.texi, depending on the target.
50
51 -- 5. <warnings> (optional, and allowed only if <out-file> is explicit)
52 -- can be any string. If present, it indicates that warning messages are
53 -- to be output to Standard_Error. If absent, no warning messages are
54 -- generated.
55
56 -- The following steps are performed:
57
58 -- In VMS mode
59
60 -- Any occurrences of ^alpha^beta^ are replaced by beta. The sequence
61 -- must fit on a single line, and there can only be one occurrence on a
62 -- line.
63
64 -- Any occurrences of a word in the Ug_Words list are replaced by the
65 -- appropriate vms equivalents. Note that replacements do not occur
66 -- within ^alpha^beta^ sequences.
67
68 -- Any occurence of [filename].extension, where extension one of the
69 -- following:
70
71 -- "o", "ads", "adb", "ali", "ada", "atb", "ats", "adc", "c"
72
73 -- replaced by the appropriate VMS names (all upper case with .o
74 -- replaced .OBJ). Note that replacements do not occur within
75 -- ^alpha^beta^ sequences.
76
77 -- In UNW mode
78
79 -- Any occurrences of ^alpha^beta^ are replaced by alpha. The sequence
80 -- must fit on a single line.
81
82 -- In both modes
83
84 -- The sequence ^^^ is replaced by a single ^. This escape sequence
85 -- must be used if the literal character ^ is to appear in the
86 -- output. A line containing this escape sequence may not also contain
87 -- a ^alpha^beta^ sequence.
88
89 -- Recognize @ifset and @ifclear (this is because we have menu problems
90 -- if we let makeinfo handle the ifset/ifclear pairs
91
92 with Ada.Command_Line; use Ada.Command_Line;
93 with Ada.Strings; use Ada.Strings;
94 with Ada.Strings.Fixed; use Ada.Strings.Fixed;
95 with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
96 with Ada.Strings.Maps; use Ada.Strings.Maps;
97 with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
98 with Ada.Text_IO; use Ada.Text_IO;
99
100 with GNAT.Spitbol; use GNAT.Spitbol;
101 with GNAT.Spitbol.Table_VString; use GNAT.Spitbol.Table_VString;
102
103 procedure Xgnatugn is
104
105 procedure Usage;
106 -- Print usage information. Invoked if an invalid command line is
107 -- encountered.
108
109 Output_File : File_Type;
110 -- The preprocessed output is written to this file
111
112 type Input_File is record
113 Name : VString;
114 Data : File_Type;
115 Line : Natural := 0;
116 end record;
117 -- Records information on an input file. Name and Line are used
118 -- in error messages, Line is updated automatically by Get_Line.
119
120 function Get_Line (Input : access Input_File) return String;
121 -- Returns a line from Input and performs the necessary
122 -- line-oriented checks (length, character set, trailing spaces).
123
124 Number_Of_Warnings : Natural := 0;
125 Number_Of_Errors : Natural := 0;
126 Warnings_Enabled : Boolean;
127
128 procedure Error
129 (Input : Input_File;
130 At_Character : Natural;
131 Message : String);
132 procedure Error
133 (Input : Input_File;
134 Message : String);
135 -- Prints a message reporting an error on line Input.Line. If
136 -- At_Character is not 0, indicate the exact character at which
137 -- the error occurs.
138
139 procedure Warning
140 (Input : Input_File;
141 At_Character : Natural;
142 Message : String);
143 procedure Warning
144 (Input : Input_File;
145 Message : String);
146 -- Like Error, but just print a warning message.
147
148 Dictionary_File : aliased Input_File;
149 procedure Read_Dictionary_File;
150 -- Dictionary_File is opened using the name given on the command
151 -- line. It contains the replacements for the Ug_Words list.
152 -- Read_Dictionary_File reads Dictionary_File and fills the
153 -- Ug_Words table.
154
155 Source_File : aliased Input_File;
156 procedure Process_Source_File;
157 -- Source_File is opened using the name given on the command line.
158 -- It contains the Texinfo source code. Process_Source_File
159 -- performs the necessary replacements.
160
161 type Target_Type is (UNW, VMS);
162 Target : Target_Type;
163 -- The target for which preprocessing is performed:
164 -- UNW (Unix and Windows) or VMS
165 -- The Target variable is initialized using the command line.
166
167 Valid_Characters : constant Character_Set
168 := To_Set (Span => (' ', '~'));
169 -- This array controls which characters are permitted in the input
170 -- file (after line breaks have been removed). Valid characters
171 -- are all printable ASCII characters and the space character.
172
173 Word_Characters : constant Character_Set :=
174 (To_Set (Ranges =>
175 (('0', '9'), ('a', 'z'), ('A', 'Z')))
176 or To_Set ("?-_~"));
177 -- The characters which are permitted in words. Other (valid)
178 -- characters are assumed to be delimiters between words. Note that
179 -- this set has to include all characters of the source words of the
180 -- Ug_Words dictionary.
181
182 Reject_Trailing_Spaces : constant Boolean := True;
183 -- Controls whether Xgnatug rejects superfluous space characters
184 -- at the end of lines.
185
186 Maximum_Line_Length : constant Positive := 79;
187 Fatal_Line_Length_Limit : constant Positive := 5000;
188 Fatal_Line_Length : exception;
189 -- If Maximum_Line_Length is exceeded in an input file, an error
190 -- message is printed. If Fatal_Line_Length is exceeded,
191 -- execution terminates with a Fatal_Line_Length exception.
192
193 VMS_Escape_Character : constant Character := '^';
194 -- The character used to mark VMS alternatives (^alpha^beta^).
195
196 Extensions : GNAT.Spitbol.Table_VString.Table (20);
197 procedure Initialize_Extensions;
198 -- This table records extensions and their replacement for
199 -- rewriting filenames in the VMS version of the manual.
200
201 function Is_Extension (Extension : String) return Boolean;
202 function Get_Replacement_Extension (Extension : String) return String;
203 -- These functions query the replacement table. Is_Extension
204 -- checks if the given string is a known extension.
205 -- Get_Replacement returns the replacement extension.
206
207 Ug_Words : GNAT.Spitbol.Table_VString.Table (200);
208 function Is_Known_Word (Word : String) return Boolean;
209 function Get_Replacement_Word (Word : String) return String;
210 -- The Ug_Words table lists replacement words for the VMS version
211 -- of the manual. Is_Known_Word and Get_Replacement_Word query
212 -- this table. The table is filled using Read_Dictionary_File.
213
214 function Rewrite_Source_Line (Line : String) return String;
215 -- This subprogram takes a line and rewrites it according to Target.
216 -- It relies on information in Source_File to generate error messages.
217
218 type Conditional is (Set, Clear);
219 procedure Push_Conditional (Cond : Conditional; Flag : Target_Type);
220 procedure Pop_Conditional (Cond : Conditional);
221 -- These subprograms deal with conditional processing (@ifset/@ifclear).
222 -- They rely on information in Source_File to generate error messages.
223
224 function Currently_Excluding return Boolean;
225 -- Returns true if conditional processing directives imply that the
226 -- current line should not be included in the output.
227
228 function VMS_Context_Determined return Boolean;
229 -- Returns true if, in the current conditional preprocessing context, we
230 -- always have a VMS or a non-VMS version, regardless of the value of
231 -- Target.
232
233 function In_VMS_Section return Boolean;
234 -- Returns True if in an "@ifset vms" section.
235
236 procedure Check_No_Pending_Conditional;
237 -- Checks that all preprocessing directives have been properly matched by
238 -- their @end counterpart. If this is not the case, print an error
239 -- message.
240
241 -- The following definitions implement a stack to track the conditional
242 -- preprocessing context.
243
244 type Conditional_Context is record
245 Starting_Line : Positive;
246 Cond : Conditional;
247 Flag : Target_Type;
248 Excluding : Boolean;
249 end record;
250
251 Conditional_Stack_Depth : constant := 3;
252
253 Conditional_Stack :
254 array (1 .. Conditional_Stack_Depth) of Conditional_Context;
255
256 Conditional_TOS : Natural := 0;
257 -- Pointer to the Top Of Stack for Conditional_Stack.
258
259 -----------
260 -- Usage --
261 -----------
262
263 procedure Usage is
264 begin
265 Put_Line (Standard_Error,
266 "usage: xgnatug TARGET SOURCE DICTIONARY [OUTFILE [WARNINGS]]");
267 New_Line;
268 Put_Line (Standard_Error, "TARGET is one of:");
269
270 for T in Target_Type'Range loop
271 Put_Line (Standard_Error, " " & Target_Type'Image (T));
272 end loop;
273
274 New_Line;
275 Put_Line (Standard_Error, "SOURCE is the source file to process.");
276 New_Line;
277 Put_Line (Standard_Error, "DICTIONARY is the name of a file "
278 & "that contains word replacements");
279 Put_Line (Standard_Error, "for the VMS version.");
280 New_Line;
281 Put_Line (Standard_Error,
282 "OUT-FILE, if present, is the output file to be created;");
283 Put_Line (Standard_Error,
284 "If OUT-FILE is absent, the output file is either " &
285 "gnat_ugn_unw.texi, ");
286 Put_Line (Standard_Error,
287 "or gnat_ugn_vms.texi, depending on TARGET.");
288 New_Line;
289 Put_Line (Standard_Error,
290 "WARNINGS, if present, is any string;");
291 Put_Line (Standard_Error,
292 "it will result in warning messages (e.g., line too long))");
293 Put_Line (Standard_Error,
294 "being output to Standard_Error.");
295 end Usage;
296
297 --------------
298 -- Get_Line --
299 --------------
300
301 function Get_Line (Input : access Input_File) return String is
302 Line_Buffer : String (1 .. Fatal_Line_Length_Limit);
303 Last : Natural;
304
305 begin
306 Input.Line := Input.Line + 1;
307 Get_Line (Input.Data, Line_Buffer, Last);
308
309 if Last = Line_Buffer'Last then
310 Error (Input.all, "line exceeds fatal line length limit");
311 raise Fatal_Line_Length;
312 end if;
313
314 declare
315 Line : String renames Line_Buffer (Line_Buffer'First .. Last);
316
317 begin
318 for J in Line'Range loop
319 if not Is_In (Line (J), Valid_Characters) then
320 Error (Input.all, J, "invalid character");
321 exit;
322 end if;
323 end loop;
324
325 if Line'Length > Maximum_Line_Length then
326 Warning (Input.all, Maximum_Line_Length + 1, "line too long");
327 end if;
328
329 if Reject_Trailing_Spaces
330 and then Line'Length > 0
331 and then Line (Line'Last) = ' '
332 then
333 Error (Input.all, Line'Last, "trailing space character");
334 end if;
335
336 return Trim (Line, Right);
337 end;
338 end Get_Line;
339
340 -----------
341 -- Error --
342 -----------
343
344 procedure Error
345 (Input : Input_File;
346 Message : String)
347 is
348 begin
349 Error (Input, 0, Message);
350 end Error;
351
352 procedure Error
353 (Input : Input_File;
354 At_Character : Natural;
355 Message : String)
356 is
357 Line_Image : constant String := Integer'Image (Input.Line);
358 At_Character_Image : constant String := Integer'Image (At_Character);
359 -- These variables are required because we have to drop the leading
360 -- space character.
361
362 begin
363 Number_Of_Errors := Number_Of_Errors + 1;
364
365 if At_Character > 0 then
366 Put_Line (Standard_Error,
367 S (Input.Name) & ':'
368 & Line_Image (Line_Image'First + 1 .. Line_Image'Last) & ':'
369 & At_Character_Image (At_Character_Image'First + 1
370 .. At_Character_Image'Last)
371 & ": "
372 & Message);
373 else
374 Put_Line (Standard_Error,
375 S (Input.Name) & ':'
376 & Line_Image (Line_Image'First + 1 .. Line_Image'Last)
377 & ": "
378 & Message);
379 end if;
380 end Error;
381
382 -------------
383 -- Warning --
384 -------------
385
386 procedure Warning
387 (Input : Input_File;
388 Message : String)
389 is
390 begin
391 if Warnings_Enabled then
392 Warning (Input, 0, Message);
393 end if;
394 end Warning;
395
396 procedure Warning
397 (Input : Input_File;
398 At_Character : Natural;
399 Message : String)
400 is
401 Line_Image : constant String := Integer'Image (Input.Line);
402 At_Character_Image : constant String := Integer'Image (At_Character);
403 -- These variables are required because we have to drop the leading
404 -- space character.
405
406 begin
407 if not Warnings_Enabled then
408 return;
409 end if;
410
411 Number_Of_Warnings := Number_Of_Warnings + 1;
412
413 if At_Character > 0 then
414 Put_Line (Standard_Error,
415 S (Input.Name) & ':'
416 & Line_Image (Line_Image'First + 1 .. Line_Image'Last) & ':'
417 & At_Character_Image (At_Character_Image'First + 1
418 .. At_Character_Image'Last)
419 & ": warning: "
420 & Message);
421 else
422 Put_Line (Standard_Error,
423 S (Input.Name) & ':'
424 & Line_Image (Line_Image'First + 1 .. Line_Image'Last)
425 & ": warning: "
426 & Message);
427 end if;
428 end Warning;
429
430 --------------------------
431 -- Read_Dictionary_File --
432 --------------------------
433
434 procedure Read_Dictionary_File is
435 begin
436 while not End_Of_File (Dictionary_File.Data) loop
437 declare
438 Line : constant String :=
439 Get_Line (Dictionary_File'Access);
440 Split : constant Natural :=
441 Index (Line, (1 => VMS_Escape_Character));
442
443 begin
444 if Line'Length = 0 then
445 Error (Dictionary_File, "empty line in dictionary file");
446
447 elsif Line (Line'First) = ' ' then
448 Error (Dictionary_File, 1, "line starts with space character");
449
450 elsif Split = 0 then
451 Error (Dictionary_File, "line does not contain "
452 & VMS_Escape_Character & " character");
453 else
454 declare
455 Source : constant String :=
456 Trim (Line (1 .. Split - 1), Both);
457 Target : constant String :=
458 Trim (Line (Split + 1 .. Line'Last), Both);
459 Two_Spaces : constant Natural :=
460 Index (Source, " ");
461 Non_Word_Character : constant Natural :=
462 Index (Source,
463 Word_Characters or
464 To_Set (" "),
465 Outside);
466
467 begin
468 if Two_Spaces /= 0 then
469 Error (Dictionary_File, Two_Spaces,
470 "multiple space characters in source word");
471 end if;
472
473 if Non_Word_Character /= 0 then
474 Error (Dictionary_File, Non_Word_Character,
475 "illegal character in source word");
476 end if;
477
478 if Source'Length = 0 then
479 Error (Dictionary_File, "source is empty");
480
481 elsif Target'Length = 0 then
482 Error (Dictionary_File, "target is empty");
483
484 else
485 Set (Ug_Words, Source, V (Target));
486
487 -- Ensure that if Source is a sequence of words
488 -- "WORD1 WORD2 ...", we already have a mapping for
489 -- "WORD1".
490
491 for J in Source'Range loop
492 if Source (J) = ' ' then
493 declare
494 Prefix : String renames
495 Source (Source'First .. J - 1);
496
497 begin
498 if not Is_Known_Word (Prefix) then
499 Error (Dictionary_File,
500 "prefix '" & Prefix
501 & "' not known at this point");
502 end if;
503 end;
504 end if;
505 end loop;
506 end if;
507 end;
508 end if;
509 end;
510 end loop;
511 end Read_Dictionary_File;
512
513 -------------------------
514 -- Rewrite_Source_Line --
515 -------------------------
516
517 function Rewrite_Source_Line (Line : String) return String is
518
519 -- We use a simple lexer to split the line into tokens:
520
521 -- Word consisting entirely of Word_Characters
522 -- VMS_Alternative ^alpha^beta^ replacement (but not ^^^)
523 -- Space a space character
524 -- Other everything else (sequence of non-word characters)
525 -- VMS_Error incomplete VMS alternative
526 -- End_Of_Line no more characters on this line
527
528 -- A sequence of three VMS_Escape_Characters is automatically
529 -- collapsed to an Other token.
530
531 type Token_Span is record
532 First, Last : Positive;
533 end record;
534 -- The character range covered by a token in Line
535
536 type Token_Kind is (End_Of_Line, Word, Other,
537 VMS_Alternative, VMS_Error);
538 type Token_Record (Kind : Token_Kind := End_Of_Line) is record
539 First : Positive;
540 case Kind is
541 when Word | Other =>
542 Span : Token_Span;
543 when VMS_Alternative =>
544 Non_VMS, VMS : Token_Span;
545 when VMS_Error | End_Of_Line =>
546 null;
547 end case;
548 end record;
549
550 Input_Position : Positive := Line'First;
551 Token : Token_Record;
552 -- The position of the next character to be processed by Next_Token
553
554 procedure Next_Token;
555 -- Returns the next token in Line, starting at Input_Position
556
557 Rewritten_Line : VString;
558 -- Collects the line as it is rewritten
559
560 procedure Rewrite_Word;
561 -- The current token is assumed to be a Word. When processing the VMS
562 -- version of the manual, additional tokens are gathered to check if
563 -- we have a file name or a sequence of known words.
564
565 procedure Maybe_Rewrite_Extension;
566 -- The current token is assumed to be Other. When processing the VMS
567 -- version of the manual and the token represents a single dot ".",
568 -- the following word is rewritten according to the rules for
569 -- extensions.
570
571 VMS_Token_Seen : Boolean := False;
572 -- This is set to true if a VMS_Alternative has been encountered, or a
573 -- ^^^ token.
574
575 ----------------
576 -- Next_Token --
577 ----------------
578
579 procedure Next_Token is
580 Remaining_Line : String renames Line (Input_Position .. Line'Last);
581 Last_Character : Natural;
582
583 begin
584 if Remaining_Line'Length = 0 then
585 Token := (End_Of_Line, Remaining_Line'First);
586 return;
587 end if;
588
589 -- ^alpha^beta^, the VMS_Alternative case.
590
591 if Remaining_Line (Remaining_Line'First) = VMS_Escape_Character then
592 declare
593 VMS_Second_Character, VMS_Third_Character : Natural;
594
595 begin
596 if VMS_Token_Seen then
597 Error (Source_File, Remaining_Line'First,
598 "multiple " & VMS_Escape_Character
599 & " characters on a single line");
600 else
601 VMS_Token_Seen := True;
602 end if;
603
604 -- Find the second and third escape character. If one of
605 -- them is not present, generate an error token.
606
607 VMS_Second_Character :=
608 Index (Remaining_Line (Remaining_Line'First + 1
609 .. Remaining_Line'Last),
610 (1 => VMS_Escape_Character));
611
612 if VMS_Second_Character = 0 then
613 Input_Position := Remaining_Line'Last + 1;
614 Token := (VMS_Error, Remaining_Line'First);
615 return;
616 end if;
617
618 VMS_Third_Character :=
619 Index (Remaining_Line (VMS_Second_Character + 1
620 .. Remaining_Line'Last),
621 (1 => VMS_Escape_Character));
622
623 if VMS_Third_Character = 0 then
624 Input_Position := Remaining_Line'Last + 1;
625 Token := (VMS_Error, Remaining_Line'First);
626 return;
627 end if;
628
629 -- Consume all the characters we are about to include in
630 -- the token.
631
632 Input_Position := VMS_Third_Character + 1;
633
634 -- Check if we are in a ^^^ situation, and return an Other
635 -- token in this case.
636
637 if Remaining_Line'First + 1 = VMS_Second_Character
638 and then Remaining_Line'First + 2 = VMS_Third_Character
639 then
640 Token := (Other, Remaining_Line'First,
641 (Remaining_Line'First, Remaining_Line'First));
642 return;
643 end if;
644
645 Token := (VMS_Alternative, Remaining_Line'First,
646 (Remaining_Line'First + 1, VMS_Second_Character - 1),
647 (VMS_Second_Character + 1, VMS_Third_Character - 1));
648 return;
649 end;
650 end if; -- VMS_Alternative
651
652 -- The Word case. Search for characters not in Word_Characters.
653 -- We have found a word if the first non-word character is not
654 -- the first character in Remaining_Line, i.e. if Remaining_Line
655 -- starts with a word character.
656
657 Last_Character := Index (Remaining_Line, Word_Characters, Outside);
658 if Last_Character /= Remaining_Line'First then
659
660 -- If we haven't found a character which is not in
661 -- Word_Characters, all remaining characters are part of the
662 -- current Word token.
663
664 if Last_Character = 0 then
665 Last_Character := Remaining_Line'Last + 1;
666 end if;
667
668 Input_Position := Last_Character;
669 Token := (Word, Remaining_Line'First,
670 (Remaining_Line'First, Last_Character - 1));
671 return;
672 end if;
673
674 -- Remaining characters are in the Other category. To speed
675 -- up processing, we collect them together if there are several
676 -- of them.
677
678 Input_Position := Last_Character + 1;
679 Token := (Other,
680 Remaining_Line'First,
681 (Remaining_Line'First, Last_Character));
682 end Next_Token;
683
684 ------------------
685 -- Rewrite_Word --
686 ------------------
687
688 procedure Rewrite_Word is
689 First_Word : String
690 renames Line (Token.Span.First .. Token.Span.Last);
691
692 begin
693 -- We do not perform any error checking below, so we can just skip
694 -- all processing for the non-VMS version.
695
696 if Target /= VMS then
697 Append (Rewritten_Line, First_Word);
698 Next_Token;
699 return;
700 end if;
701
702 if Is_Known_Word (First_Word) then
703
704 -- If we have a word from the dictionary, we look for the
705 -- longest possible sequence we can rewrite.
706
707 declare
708 Seq : Token_Span := Token.Span;
709 Lost_Space : Boolean := False;
710
711 begin
712 Next_Token;
713 loop
714 if Token.Kind = Other
715 and then Line (Token.Span.First .. Token.Span.Last) = " "
716 then
717 Next_Token;
718 if Token.Kind /= Word
719 or else not Is_Known_Word (Line (Seq.First
720 .. Token.Span.Last))
721 then
722 -- When we reach this point, the following
723 -- conditions are true:
724 --
725 -- Seq is a known word.
726 -- The previous token was a space character.
727 -- Seq extended to the current token is not a
728 -- known word.
729
730 Lost_Space := True;
731 exit;
732
733 else
734
735 -- Extend Seq to cover the current (known) word.
736
737 Seq.Last := Token.Span.Last;
738 Next_Token;
739 end if;
740
741 else
742 -- When we reach this point, the following conditions
743 -- are true:
744 --
745 -- Seq is a known word.
746 -- The previous token was a word.
747 -- The current token is not a space character.
748
749 exit;
750 end if;
751 end loop;
752
753 -- Rewrite Seq, and add the lost space if necessary
754
755 Append (Rewritten_Line,
756 Get_Replacement_Word (Line (Seq.First .. Seq.Last)));
757 if Lost_Space then
758 Append (Rewritten_Line, ' ');
759 end if;
760
761 -- The unknown token will be processed during the
762 -- next iteration of the main loop.
763 return;
764 end;
765 end if;
766
767 Next_Token;
768
769 if Token.Kind = Other
770 and then Line (Token.Span.First .. Token.Span.Last) = "."
771 then
772 -- Deal with extensions
773
774 Next_Token;
775 if Token.Kind = Word
776 and then Is_Extension (Line (Token.Span.First
777 .. Token.Span.Last))
778 then
779 -- We have discovered a file extension. Convert the file
780 -- name to upper case.
781
782 Append (Rewritten_Line,
783 Translate (First_Word, Upper_Case_Map) & '.');
784 Append (Rewritten_Line,
785 Get_Replacement_Extension
786 (Line (Token.Span.First .. Token.Span.Last)));
787 Next_Token;
788 else
789 -- We already have: Word ".", followed by an unknown
790 -- token.
791
792 Append (Rewritten_Line, First_Word & '.');
793
794 -- The unknown token will be processed during the next
795 -- iteration of the main loop.
796 end if;
797
798 else
799 -- We have an unknown Word, followed by an unknown token.
800 -- The unknown token will be processed by the outer loop.
801
802 Append (Rewritten_Line, First_Word);
803 end if;
804 end Rewrite_Word;
805
806 -----------------------------
807 -- Maybe_Rewrite_Extension --
808 -----------------------------
809
810 procedure Maybe_Rewrite_Extension is
811 begin
812 -- Again, we need no special processing in the non-VMS case
813
814 if Target = VMS
815 and then Line (Token.Span.First .. Token.Span.Last) = "."
816 then
817 -- This extension is not preceded by a word, otherwise
818 -- Rewrite_Word would have handled it.
819
820 Next_Token;
821 if Token.Kind = Word
822 and then Is_Extension (Line (Token.Span.First
823 .. Token.Span.Last))
824 then
825 Append (Rewritten_Line, '.' & Get_Replacement_Extension
826 (Line (Token.Span.First .. Token.Span.Last)));
827 Next_Token;
828 else
829 Append (Rewritten_Line, '.');
830 end if;
831 else
832 Append (Rewritten_Line, Line (Token.Span.First
833 .. Token.Span.Last));
834 Next_Token;
835 end if;
836 end Maybe_Rewrite_Extension;
837
838 -- Start of processing for Process_Source_Line
839
840 begin
841 -- The following parser recognizes the following special token
842 -- sequences:
843
844 -- Word "." Word rewrite as file name if second word is extension
845 -- Word " " Word rewrite as a single word using Ug_Words table
846
847 Next_Token;
848 loop
849 case Token.Kind is
850 when End_Of_Line =>
851 exit;
852
853 when Word =>
854 Rewrite_Word;
855
856 when Other =>
857 Maybe_Rewrite_Extension;
858
859 when VMS_Alternative =>
860 if VMS_Context_Determined then
861 if (not In_VMS_Section)
862 or else
863 Line (Token.VMS.First .. Token.VMS.Last) /=
864 Line (Token.Non_VMS.First .. Token.Non_VMS.Last)
865 then
866 Warning (Source_File, Token.First,
867 "VMS alternative already determined "
868 & "by conditionals");
869 end if;
870 end if;
871 if Target = VMS then
872 Append (Rewritten_Line, Line (Token.VMS.First
873 .. Token.VMS.Last));
874 else
875 Append (Rewritten_Line, Line (Token.Non_VMS.First
876 .. Token.Non_VMS.Last));
877 end if;
878 Next_Token;
879
880 when VMS_Error =>
881 Error (Source_File, Token.First, "invalid VMS alternative");
882 Next_Token;
883 end case;
884 end loop;
885
886 return S (Rewritten_Line);
887 end Rewrite_Source_Line;
888
889 -------------------------
890 -- Process_Source_File --
891 -------------------------
892
893 procedure Process_Source_File is
894 Ifset : constant String := "@ifset ";
895 Ifclear : constant String := "@ifclear ";
896 Endsetclear : constant String := "@end ";
897 -- Strings to be recognized for conditional processing.
898
899 begin
900 while not End_Of_File (Source_File.Data) loop
901 declare
902 Line : constant String := Get_Line (Source_File'Access);
903 Rewritten : constant String := Rewrite_Source_Line (Line);
904 -- We unconditionally rewrite the line so that we can check the
905 -- syntax of all lines, and not only those which are actually
906 -- included in the output.
907
908 Have_Conditional : Boolean := False;
909 -- True if we have encountered a conditional preprocessing
910 -- directive.
911
912 Cond : Conditional;
913 -- The kind of the directive.
914
915 Flag : Target_Type;
916 -- Its flag.
917
918 begin
919 -- If the line starts with @ifset or @ifclear, we try to convert
920 -- the following flag to one of our target types. If we fail,
921 -- Have_Conditional remains False.
922
923 if Line'Length >= Ifset'Length
924 and then Line (1 .. Ifset'Length) = Ifset
925 then
926 Cond := Set;
927
928 declare
929 Arg : constant String :=
930 Trim (Line (Ifset'Length + 1 .. Line'Last), Both);
931
932 begin
933 Flag := Target_Type'Value (Arg);
934
935 if Translate (Target_Type'Image (Flag), Lower_Case_Map)
936 /= Arg
937 then
938 Error (Source_File, "flag has to be lowercase");
939 end if;
940
941 Have_Conditional := True;
942
943 exception
944 when Constraint_Error =>
945 Error (Source_File, "unknown flag for '@ifset'");
946 end;
947
948 elsif Line'Length >= Ifclear'Length
949 and then Line (1 .. Ifclear'Length) = Ifclear
950 then
951 Cond := Clear;
952
953 declare
954 Arg : constant String :=
955 Trim (Line (Ifclear'Length + 1 .. Line'Last), Both);
956
957 begin
958 Flag := Target_Type'Value (Arg);
959 if Translate (Target_Type'Image (Flag), Lower_Case_Map)
960 /= Arg
961 then
962 Error (Source_File, "flag has to be lowercase");
963 end if;
964
965 Have_Conditional := True;
966
967 exception
968 when Constraint_Error =>
969 Error (Source_File, "unknown flag for '@ifclear'");
970 end;
971 end if;
972
973 if Have_Conditional then
974
975 -- We create a new conditional context and suppress the
976 -- directive in the output.
977
978 Push_Conditional (Cond, Flag);
979
980 elsif Line'Length >= Endsetclear'Length
981 and then Line (1 .. Endsetclear'Length) = Endsetclear
982 then
983 -- The '@end ifset'/'@end ifclear' case is handled here. We
984 -- have to pop the conditional context.
985
986 declare
987 First, Last : Natural;
988
989 begin
990 Find_Token (Source => Line (Endsetclear'Length + 1
991 .. Line'Length),
992 Set => Letter_Set,
993 Test => Inside,
994 First => First,
995 Last => Last);
996
997 if Last = 0 then
998 Error (Source_File, "'@end' without argument");
999 else
1000 if Line (First .. Last) = "ifset" then
1001 Have_Conditional := True;
1002 Cond := Set;
1003 elsif Line (First .. Last) = "ifclear" then
1004 Have_Conditional := True;
1005 Cond := Clear;
1006 end if;
1007
1008 if Have_Conditional then
1009 Pop_Conditional (Cond);
1010 end if;
1011
1012 -- We fall through to the ordinary case for other @end
1013 -- directives.
1014
1015 end if; -- @end without argument
1016 end;
1017 end if; -- Have_Conditional
1018
1019 if not Have_Conditional then
1020
1021 -- The ordinary case.
1022
1023 if not Currently_Excluding then
1024 Put_Line (Output_File, Rewritten);
1025 end if;
1026 end if;
1027 end;
1028 end loop;
1029
1030 Check_No_Pending_Conditional;
1031 end Process_Source_File;
1032
1033 ---------------------------
1034 -- Initialize_Extensions --
1035 ---------------------------
1036
1037 procedure Initialize_Extensions is
1038
1039 procedure Add (Extension : String);
1040 -- Adds an extension which is replaced with itself (in upper
1041 -- case).
1042
1043 procedure Add (Extension, Replacement : String);
1044 -- Adds an extension with a custom replacement.
1045
1046 ---------
1047 -- Add --
1048 ---------
1049
1050 procedure Add (Extension : String) is
1051 begin
1052 Add (Extension, Translate (Extension, Upper_Case_Map));
1053 end Add;
1054
1055 procedure Add (Extension, Replacement : String) is
1056 begin
1057 Set (Extensions, Extension, V (Replacement));
1058 end Add;
1059
1060 -- Start of processing for Initialize_Extensions
1061
1062 begin
1063 -- To avoid performance degradation, increase the constant in the
1064 -- definition of Extensions above if you add more extensions here.
1065
1066 Add ("o", "OBJ");
1067 Add ("ads");
1068 Add ("adb");
1069 Add ("ali");
1070 Add ("ada");
1071 Add ("atb");
1072 Add ("ats");
1073 Add ("adc");
1074 Add ("c");
1075 end Initialize_Extensions;
1076
1077 ------------------
1078 -- Is_Extension --
1079 ------------------
1080
1081 function Is_Extension (Extension : String) return Boolean is
1082 begin
1083 return Present (Extensions, Extension);
1084 end Is_Extension;
1085
1086 -------------------------------
1087 -- Get_Replacement_Extension --
1088 -------------------------------
1089
1090 function Get_Replacement_Extension (Extension : String) return String is
1091 begin
1092 return S (Get (Extensions, Extension));
1093 end Get_Replacement_Extension;
1094
1095 -------------------
1096 -- Is_Known_Word --
1097 -------------------
1098
1099 function Is_Known_Word (Word : String) return Boolean is
1100 begin
1101 return Present (Ug_Words, Word);
1102 end Is_Known_Word;
1103
1104 --------------------------
1105 -- Get_Replacement_Word --
1106 --------------------------
1107
1108 function Get_Replacement_Word (Word : String) return String is
1109 begin
1110 return S (Get (Ug_Words, Word));
1111 end Get_Replacement_Word;
1112
1113 ----------------------
1114 -- Push_Conditional --
1115 ----------------------
1116
1117 procedure Push_Conditional (Cond : Conditional; Flag : Target_Type) is
1118 Will_Exclude : Boolean;
1119
1120 begin
1121 -- If we are already in an excluding context, inherit this property,
1122 -- otherwise calculate it from scratch.
1123
1124 if Conditional_TOS > 0
1125 and then Conditional_Stack (Conditional_TOS).Excluding
1126 then
1127 Will_Exclude := True;
1128 else
1129 case Cond is
1130 when Set =>
1131 Will_Exclude := Flag /= Target;
1132 when Clear =>
1133 Will_Exclude := Flag = Target;
1134 end case;
1135 end if;
1136
1137 -- Check if the current directive is pointless because of a previous,
1138 -- enclosing directive.
1139
1140 for J in 1 .. Conditional_TOS loop
1141 if Conditional_Stack (J).Flag = Flag then
1142 Warning (Source_File, "directive without effect because of line"
1143 & Integer'Image (Conditional_Stack (J).Starting_Line));
1144 end if;
1145 end loop;
1146
1147 Conditional_TOS := Conditional_TOS + 1;
1148 Conditional_Stack (Conditional_TOS) :=
1149 (Starting_Line => Source_File.Line,
1150 Cond => Cond,
1151 Flag => Flag,
1152 Excluding => Will_Exclude);
1153 end Push_Conditional;
1154
1155 ---------------------
1156 -- Pop_Conditional --
1157 ---------------------
1158
1159 procedure Pop_Conditional (Cond : Conditional) is
1160 begin
1161 if Conditional_TOS > 0 then
1162 case Cond is
1163 when Set =>
1164 if Conditional_Stack (Conditional_TOS).Cond /= Set then
1165 Error (Source_File,
1166 "'@end ifset' does not match '@ifclear' at line"
1167 & Integer'Image (Conditional_Stack
1168 (Conditional_TOS).Starting_Line));
1169 end if;
1170
1171 when Clear =>
1172 if Conditional_Stack (Conditional_TOS).Cond /= Clear then
1173 Error (Source_File,
1174 "'@end ifclear' does not match '@ifset' at line"
1175 & Integer'Image (Conditional_Stack
1176 (Conditional_TOS).Starting_Line));
1177 end if;
1178 end case;
1179
1180 Conditional_TOS := Conditional_TOS - 1;
1181
1182 else
1183 case Cond is
1184 when Set =>
1185 Error (Source_File,
1186 "'@end ifset' without corresponding '@ifset'");
1187
1188 when Clear =>
1189 Error (Source_File,
1190 "'@end ifclear' without corresponding '@ifclear'");
1191 end case;
1192 end if;
1193 end Pop_Conditional;
1194
1195 -------------------------
1196 -- Currently_Excluding --
1197 -------------------------
1198
1199 function Currently_Excluding return Boolean is
1200 begin
1201 return Conditional_TOS > 0
1202 and then Conditional_Stack (Conditional_TOS).Excluding;
1203 end Currently_Excluding;
1204
1205 ----------------------------
1206 -- VMS_Context_Determined --
1207 ----------------------------
1208
1209 function VMS_Context_Determined return Boolean is
1210 begin
1211 for J in 1 .. Conditional_TOS loop
1212 if Conditional_Stack (J).Flag = VMS then
1213 return True;
1214 end if;
1215 end loop;
1216
1217 return False;
1218 end VMS_Context_Determined;
1219
1220 --------------------
1221 -- In_VMS_Section --
1222 --------------------
1223
1224 function In_VMS_Section return Boolean is
1225 begin
1226 for J in 1 .. Conditional_TOS loop
1227 if Conditional_Stack (J).Flag = VMS then
1228 return Conditional_Stack (J).Cond = Set;
1229 end if;
1230 end loop;
1231
1232 return False;
1233 end In_VMS_Section;
1234
1235 ----------------------------------
1236 -- Check_No_Pending_Conditional --
1237 ----------------------------------
1238
1239 procedure Check_No_Pending_Conditional is
1240 begin
1241 for J in 1 .. Conditional_TOS loop
1242 case Conditional_Stack (J).Cond is
1243 when Set =>
1244 Error (Source_File, "Missing '@end ifset' for '@ifset' at line"
1245 & Integer'Image (Conditional_Stack (J).Starting_Line));
1246
1247 when Clear =>
1248 Error (Source_File,
1249 "Missing '@end ifclear' for '@ifclear' at line"
1250 & Integer'Image (Conditional_Stack (J).Starting_Line));
1251 end case;
1252 end loop;
1253 end Check_No_Pending_Conditional;
1254
1255 ------------------
1256 -- Main Program --
1257 ------------------
1258
1259 Valid_Command_Line : Boolean;
1260 Output_File_Name : VString;
1261
1262 begin
1263 Initialize_Extensions;
1264
1265 Valid_Command_Line := Argument_Count in 3 .. 5;
1266
1267 -- First argument: Target.
1268
1269 if Valid_Command_Line then
1270 begin
1271 Target := Target_Type'Value (Argument (1));
1272
1273 exception
1274 when Constraint_Error =>
1275 Valid_Command_Line := False;
1276 end;
1277 end if;
1278
1279 -- Second argument: Source_File.
1280
1281 if Valid_Command_Line then
1282 begin
1283 Source_File.Name := V (Argument (2));
1284 Open (Source_File.Data, In_File, Argument (2));
1285
1286 exception
1287 when Name_Error =>
1288 Valid_Command_Line := False;
1289 end;
1290 end if;
1291
1292 -- Third argument: Dictionary_File.
1293
1294 if Valid_Command_Line then
1295 begin
1296 Dictionary_File.Name := V (Argument (3));
1297 Open (Dictionary_File.Data, In_File, Argument (3));
1298
1299 exception
1300 when Name_Error =>
1301 Valid_Command_Line := False;
1302 end;
1303 end if;
1304
1305 -- Fourth argument: Output_File.
1306
1307 if Valid_Command_Line then
1308 if Argument_Count in 4 .. 5 then
1309 Output_File_Name := V (Argument (4));
1310 else
1311 case Target is
1312 when UNW =>
1313 Output_File_Name := V ("gnat_ugn_unw.texi");
1314 when VMS =>
1315 Output_File_Name := V ("gnat_ugn_vms.texi");
1316 end case;
1317 end if;
1318
1319 Warnings_Enabled := Argument_Count = 5;
1320
1321 begin
1322 Create (Output_File, Out_File, S (Output_File_Name));
1323
1324 exception
1325 when Name_Error | Use_Error =>
1326 Valid_Command_Line := False;
1327 end;
1328 end if;
1329
1330 if not Valid_Command_Line then
1331 Usage;
1332 Set_Exit_Status (Failure);
1333
1334 else
1335 Read_Dictionary_File;
1336 Close (Dictionary_File.Data);
1337
1338 -- Main processing starts here.
1339
1340 Process_Source_File;
1341 Close (Output_File);
1342 Close (Source_File.Data);
1343
1344 New_Line (Standard_Error);
1345
1346 if Number_Of_Warnings = 0 then
1347 Put_Line (Standard_Error, " NO Warnings");
1348
1349 else
1350 Put (Standard_Error, Integer'Image (Number_Of_Warnings));
1351 Put (Standard_Error, " Warning");
1352
1353 if Number_Of_Warnings > 1 then
1354 Put (Standard_Error, "s");
1355 end if;
1356
1357 New_Line (Standard_Error);
1358 end if;
1359
1360 if Number_Of_Errors = 0 then
1361 Put_Line (Standard_Error, " NO Errors");
1362
1363 else
1364 Put (Standard_Error, Integer'Image (Number_Of_Errors));
1365 Put (Standard_Error, " Error");
1366
1367 if Number_Of_Errors > 1 then
1368 Put (Standard_Error, "s");
1369 end if;
1370
1371 New_Line (Standard_Error);
1372 end if;
1373
1374 if Number_Of_Errors /= 0 then
1375 Set_Exit_Status (Failure);
1376 else
1377 Set_Exit_Status (Success);
1378 end if;
1379 end if;
1380 end Xgnatugn;
Mirror of the offical gcc git repository hosted at gcc.gnu.org