?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* libgfortran.h (support_fpu_underflow_control,
[official-gcc.git] / gcc / ada / xgnatugn.adb
blob4706701e9b1081357842750aa50cd241b2d566a8
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-2013, 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. 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 COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
20 -- --
21 ------------------------------------------------------------------------------
22
23 -- This utility is used to process the source of gnat_ugn.texi to make a
24 -- version suitable for running through standard Texinfo processor. It is
25 -- invoked as follows:
26
27 -- xgnatugn <target> <in-file> <word-list> [ <out-file> [ <warnings> ] ]
28
29 -- 1. <target> is the target type of the manual, which is one of:
30
31 -- unw Unix and Windows platforms
32 -- vms OpenVMS
33
34 -- 2. <in-file> is the file name of the Texinfo file to be
35 -- preprocessed.
36
37 -- 3. <word-list> is the name of the word list file. This file is used for
38 -- rewriting the VMS edition. Each line contains a word mapping: The source
39 -- word in the first column, the target word in the second column. The
40 -- columns are separated by a '^' character. When preprocessing for VMS, the
41 -- first word is replaced with the second. (Words consist of letters,
42 -- digits, and the four characters "?-_~". A sequence of multiple words can
43 -- be replaced if they are listed in the first column, separated by a single
44 -- space character. If multiple words are to be replaced, there must be a
45 -- replacement for each prefix.)
46
47 -- 4. <out-file> (optional) is the name of the output file. It defaults to
48 -- gnat_ugn_unw.texi or gnat_ugn_vms.texi, depending on the target.
49
50 -- 5. <warnings> (optional, and allowed only if <out-file> is explicit)
51 -- can be any string. If present, it indicates that warning messages are
52 -- to be output to Standard_Error. If absent, no warning messages are
53 -- generated.
54
55 -- The following steps are performed:
56
57 -- In VMS mode
58
59 -- Any occurrences of ^alpha^beta^ are replaced by beta. The sequence
60 -- must fit on a single line, and there can only be one occurrence on a
61 -- line.
62
63 -- Any occurrences of a word in the Ug_Words list are replaced by the
64 -- appropriate vms equivalents. Note that replacements do not occur
65 -- within ^alpha^beta^ sequences.
66
67 -- Any occurrence of [filename].extension, where extension one of the
68 -- following:
69
70 -- "o", "ads", "adb", "ali", "ada", "atb", "ats", "adc", "c"
71
72 -- replaced by the appropriate VMS names (all upper case with .o
73 -- replaced .OBJ). Note that replacements do not occur within
74 -- ^alpha^beta^ sequences.
75
76 -- In UNW mode
77
78 -- Any occurrences of ^alpha^beta^ are replaced by alpha. The sequence
79 -- must fit on a single line.
80
81 -- In both modes
82
83 -- The sequence ^^^ is replaced by a single ^. This escape sequence
84 -- must be used if the literal character ^ is to appear in the
85 -- output. A line containing this escape sequence may not also contain
86 -- a ^alpha^beta^ sequence.
87
88 with Ada.Command_Line; use Ada.Command_Line;
89 with Ada.Strings; use Ada.Strings;
90 with Ada.Strings.Fixed; use Ada.Strings.Fixed;
91 with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
92 with Ada.Strings.Maps; use Ada.Strings.Maps;
93 with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants;
94 with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO;
95 with Ada.Text_IO; use Ada.Text_IO;
96
97 with GNAT.Spitbol; use GNAT.Spitbol;
98 with GNAT.Spitbol.Table_VString; use GNAT.Spitbol.Table_VString;
99
100 procedure Xgnatugn is
101
102 procedure Usage;
103 -- Print usage information. Invoked if an invalid command line is
104 -- encountered.
105
106 subtype Sfile is Ada.Streams.Stream_IO.File_Type;
107
108 Output_File : Sfile;
109 -- The preprocessed output is written to this file
110
111 type Input_File is record
112 Name : VString;
113 Data : Ada.Text_IO.File_Type;
114 Line : Natural := 0;
115 end record;
116 -- Records information on an input file. Name and Line are used
117 -- in error messages, Line is updated automatically by Get_Line.
118
119 function Get_Line (Input : access Input_File) return String;
120 -- Returns a line from Input and performs the necessary
121 -- line-oriented checks (length, character set, trailing spaces).
122
123 procedure Put_Line (F : Sfile; S : String);
124 -- Local version of Put_Line ensures Unix style line endings
125
126 First_Time : Boolean := True;
127 Number_Of_Warnings : Natural := 0;
128 Number_Of_Errors : Natural := 0;
129 Warnings_Enabled : Boolean;
130
131 procedure Error
132 (Input : Input_File;
133 At_Character : Natural;
134 Message : String);
135 procedure Error
136 (Input : Input_File;
137 Message : String);
138 -- Prints a message reporting an error on line Input.Line. If
139 -- At_Character is not 0, indicate the exact character at which
140 -- the error occurs.
141
142 procedure Warning
143 (Input : Input_File;
144 At_Character : Natural;
145 Message : String);
146
147 Dictionary_File : aliased Input_File;
148 procedure Read_Dictionary_File;
149 -- Dictionary_File is opened using the name given on the command
150 -- line. It contains the replacements for the Ug_Words list.
151 -- Read_Dictionary_File reads Dictionary_File and fills the
152 -- Ug_Words table.
153
154 Source_File : aliased Input_File;
155 procedure Process_Source_File;
156 -- Source_File is opened using the name given on the command line.
157 -- It contains the Texinfo source code. Process_Source_File
158 -- performs the necessary replacements.
159
160 type Flag_Type is (UNW, VMS, FSFEDITION, PROEDITION, GPLEDITION);
161 -- The flags permitted in @ifset or @ifclear commands:
162 --
163 -- Targets for preprocessing
164 -- UNW (Unix and Windows) or VMS
165 --
166 -- Editions of the manual
167 -- FSFEDITION, PROEDITION, or GPLEDITION
168 --
169 -- Conditional commands for target are processed by xgnatugn
170 --
171 -- Conditional commands for edition are passed through unchanged
172
173 subtype Target_Type is Flag_Type range UNW .. VMS;
174
175 Target : Target_Type;
176 -- The Target variable is initialized using the command line
177
178 Valid_Characters : constant Character_Set := To_Set (Span => (' ', '~'));
179 -- This array controls which characters are permitted in the input
180 -- file (after line breaks have been removed). Valid characters
181 -- are all printable ASCII characters and the space character.
182
183 Word_Characters : constant Character_Set :=
184 (To_Set (Ranges =>
185 (('0', '9'), ('a', 'z'), ('A', 'Z')))
186 or To_Set ("?-_~"));
187 -- The characters which are permitted in words. Other (valid)
188 -- characters are assumed to be delimiters between words. Note that
189 -- this set has to include all characters of the source words of the
190 -- Ug_Words dictionary.
191
192 Reject_Trailing_Spaces : constant Boolean := True;
193 -- Controls whether Xgnatug rejects superfluous space characters
194 -- at the end of lines.
195
196 Maximum_Line_Length : constant Positive := 79;
197 Fatal_Line_Length_Limit : constant Positive := 5000;
198 Fatal_Line_Length : exception;
199 -- If Maximum_Line_Length is exceeded in an input file, an error
200 -- message is printed. If Fatal_Line_Length is exceeded,
201 -- execution terminates with a Fatal_Line_Length exception.
202
203 VMS_Escape_Character : constant Character := '^';
204 -- The character used to mark VMS alternatives (^alpha^beta^)
205
206 Extensions : GNAT.Spitbol.Table_VString.Table (20);
207 procedure Initialize_Extensions;
208 -- This table records extensions and their replacement for
209 -- rewriting filenames in the VMS version of the manual.
210
211 function Is_Extension (Extension : String) return Boolean;
212 function Get_Replacement_Extension (Extension : String) return String;
213 -- These functions query the replacement table. Is_Extension
214 -- checks if the given string is a known extension.
215 -- Get_Replacement returns the replacement extension.
216
217 Ug_Words : GNAT.Spitbol.Table_VString.Table (200);
218 function Is_Known_Word (Word : String) return Boolean;
219 function Get_Replacement_Word (Word : String) return String;
220 -- The Ug_Words table lists replacement words for the VMS version
221 -- of the manual. Is_Known_Word and Get_Replacement_Word query
222 -- this table. The table is filled using Read_Dictionary_File.
223
224 function Rewrite_Source_Line (Line : String) return String;
225 -- This subprogram takes a line and rewrites it according to Target.
226 -- It relies on information in Source_File to generate error messages.
227
228 -----------
229 -- Usage --
230 -----------
231
232 procedure Usage is
233 begin
234 Put_Line (Standard_Error,
235 "usage: xgnatugn TARGET SOURCE DICTIONARY [OUTFILE [WARNINGS]]");
236 New_Line;
237 Put_Line (Standard_Error, "TARGET is one of:");
238
239 for T in Target_Type'Range loop
240 Put_Line (Standard_Error, " " & Target_Type'Image (T));
241 end loop;
242
243 New_Line;
244 Put_Line (Standard_Error, "SOURCE is the source file to process.");
245 New_Line;
246 Put_Line (Standard_Error, "DICTIONARY is the name of a file "
247 & "that contains word replacements");
248 Put_Line (Standard_Error, "for the VMS version.");
249 New_Line;
250 Put_Line (Standard_Error,
251 "OUT-FILE, if present, is the output file to be created;");
252 Put_Line (Standard_Error,
253 "If OUT-FILE is absent, the output file is either " &
254 "gnat_ugn_unw.texi, ");
255 Put_Line (Standard_Error,
256 "or gnat_ugn_vms.texi, depending on TARGET.");
257 New_Line;
258 Put_Line (Standard_Error,
259 "WARNINGS, if present, is any string;");
260 Put_Line (Standard_Error,
261 "it will result in warning messages (e.g., line too long))");
262 Put_Line (Standard_Error,
263 "being output to Standard_Error.");
264 end Usage;
265
266 --------------
267 -- Get_Line --
268 --------------
269
270 function Get_Line (Input : access Input_File) return String is
271 Line_Buffer : String (1 .. Fatal_Line_Length_Limit);
272 Last : Natural;
273
274 begin
275 Input.Line := Input.Line + 1;
276 Get_Line (Input.Data, Line_Buffer, Last);
277
278 if Last = Line_Buffer'Last then
279 Error (Input.all, "line exceeds fatal line length limit");
280 raise Fatal_Line_Length;
281 end if;
282
283 declare
284 Line : String renames Line_Buffer (Line_Buffer'First .. Last);
285
286 begin
287 for J in Line'Range loop
288 if not Is_In (Line (J), Valid_Characters) then
289 Error (Input.all, J, "invalid character");
290 exit;
291 end if;
292 end loop;
293
294 if Line'Length > Maximum_Line_Length then
295 Warning (Input.all, Maximum_Line_Length + 1, "line too long");
296 end if;
297
298 if Reject_Trailing_Spaces
299 and then Line'Length > 0
300 and then Line (Line'Last) = ' '
301 then
302 Error (Input.all, Line'Last, "trailing space character");
303 end if;
304
305 return Trim (Line, Right);
306 end;
307 end Get_Line;
308
309 --------------
310 -- Put_Line --
311 --------------
312
313 procedure Put_Line (F : Sfile; S : String) is
314 begin
315 String'Write (Stream (F), S);
316 Character'Write (Stream (F), ASCII.LF);
317 end Put_Line;
318
319 -----------
320 -- Error --
321 -----------
322
323 procedure Error
324 (Input : Input_File;
325 Message : String)
326 is
327 begin
328 Error (Input, 0, Message);
329 end Error;
330
331 procedure Error
332 (Input : Input_File;
333 At_Character : Natural;
334 Message : String)
335 is
336 Line_Image : constant String := Integer'Image (Input.Line);
337 At_Character_Image : constant String := Integer'Image (At_Character);
338 -- These variables are required because we have to drop the leading
339 -- space character.
340
341 begin
342 Number_Of_Errors := Number_Of_Errors + 1;
343
344 if At_Character > 0 then
345 Put_Line (Standard_Error,
346 S (Input.Name) & ':'
347 & Line_Image (Line_Image'First + 1 .. Line_Image'Last) & ':'
348 & At_Character_Image (At_Character_Image'First + 1
349 .. At_Character_Image'Last)
350 & ": "
351 & Message);
352 else
353 Put_Line (Standard_Error,
354 S (Input.Name) & ':'
355 & Line_Image (Line_Image'First + 1 .. Line_Image'Last)
356 & ": "
357 & Message);
358 end if;
359 end Error;
360
361 -------------
362 -- Warning --
363 -------------
364
365 procedure Warning
366 (Input : Input_File;
367 At_Character : Natural;
368 Message : String)
369 is
370 Line_Image : constant String := Integer'Image (Input.Line);
371 At_Character_Image : constant String := Integer'Image (At_Character);
372 -- These variables are required because we have to drop the leading
373 -- space character.
374
375 begin
376 if not Warnings_Enabled then
377 return;
378 end if;
379
380 Number_Of_Warnings := Number_Of_Warnings + 1;
381
382 if At_Character > 0 then
383 Put_Line (Standard_Error,
384 S (Input.Name) & ':'
385 & Line_Image (Line_Image'First + 1 .. Line_Image'Last) & ':'
386 & At_Character_Image (At_Character_Image'First + 1
387 .. At_Character_Image'Last)
388 & ": warning: "
389 & Message);
390 else
391 Put_Line (Standard_Error,
392 S (Input.Name) & ':'
393 & Line_Image (Line_Image'First + 1 .. Line_Image'Last)
394 & ": warning: "
395 & Message);
396 end if;
397 end Warning;
398
399 --------------------------
400 -- Read_Dictionary_File --
401 --------------------------
402
403 procedure Read_Dictionary_File is
404 begin
405 while not End_Of_File (Dictionary_File.Data) loop
406 declare
407 Line : constant String :=
408 Get_Line (Dictionary_File'Access);
409 Split : constant Natural :=
410 Index (Line, (1 => VMS_Escape_Character));
411
412 begin
413 if Line'Length = 0 then
414 Error (Dictionary_File, "empty line in dictionary file");
415
416 elsif Line (Line'First) = ' ' then
417 Error (Dictionary_File, 1, "line starts with space character");
418
419 elsif Split = 0 then
420 Error (Dictionary_File, "line does not contain "
421 & VMS_Escape_Character & " character");
422 else
423 declare
424 Source : constant String :=
425 Trim (Line (1 .. Split - 1), Both);
426 Target : constant String :=
427 Trim (Line (Split + 1 .. Line'Last), Both);
428
429 Two_Spaces : constant Natural := Index (Source, " ");
430
431 Non_Word_Character : constant Natural :=
432 Index (Source,
433 Word_Characters or
434 To_Set (" ."),
435 Outside);
436
437 begin
438 if Two_Spaces /= 0 then
439 Error (Dictionary_File, Two_Spaces,
440 "multiple space characters in source word");
441 end if;
442
443 if Non_Word_Character /= 0 then
444 Error (Dictionary_File, Non_Word_Character,
445 "illegal character in source word");
446 end if;
447
448 if Source'Length = 0 then
449 Error (Dictionary_File, "source is empty");
450
451 elsif Target'Length = 0 then
452 Error (Dictionary_File, "target is empty");
453
454 else
455 Set (Ug_Words, Source, V (Target));
456
457 -- Ensure that if Source is a sequence of words
458 -- "WORD1 WORD2 ...", we already have a mapping for
459 -- "WORD1".
460
461 for J in Source'Range loop
462 if Source (J) = ' ' then
463 declare
464 Prefix : String renames
465 Source (Source'First .. J - 1);
466 begin
467 if not Is_Known_Word (Prefix) then
468 Error (Dictionary_File,
469 "prefix '" & Prefix
470 & "' not known at this point");
471 end if;
472 end;
473 end if;
474 end loop;
475 end if;
476 end;
477 end if;
478 end;
479 end loop;
480 end Read_Dictionary_File;
481
482 -------------------------
483 -- Rewrite_Source_Line --
484 -------------------------
485
486 function Rewrite_Source_Line (Line : String) return String is
487
488 -- We use a simple lexer to split the line into tokens:
489
490 -- Word consisting entirely of Word_Characters
491 -- VMS_Alternative ^alpha^beta^ replacement (but not ^^^)
492 -- Space a space character
493 -- Other everything else (sequence of non-word characters)
494 -- VMS_Error incomplete VMS alternative
495 -- End_Of_Line no more characters on this line
496
497 -- A sequence of three VMS_Escape_Characters is automatically
498 -- collapsed to an Other token.
499
500 type Token_Span is record
501 First, Last : Positive;
502 end record;
503 -- The character range covered by a token in Line
504
505 type Token_Kind is (End_Of_Line, Word, Other,
506 VMS_Alternative, VMS_Error);
507 type Token_Record (Kind : Token_Kind := End_Of_Line) is record
508 First : Positive;
509 case Kind is
510 when Word | Other =>
511 Span : Token_Span;
512 when VMS_Alternative =>
513 Non_VMS, VMS : Token_Span;
514 when VMS_Error | End_Of_Line =>
515 null;
516 end case;
517 end record;
518
519 Input_Position : Positive := Line'First;
520 Token : Token_Record;
521 -- The position of the next character to be processed by Next_Token
522
523 procedure Next_Token;
524 -- Returns the next token in Line, starting at Input_Position
525
526 Rewritten_Line : VString;
527 -- Collects the line as it is rewritten
528
529 procedure Rewrite_Word;
530 -- The current token is assumed to be a Word. When processing the VMS
531 -- version of the manual, additional tokens are gathered to check if
532 -- we have a file name or a sequence of known words.
533
534 procedure Maybe_Rewrite_Extension;
535 -- The current token is assumed to be Other. When processing the VMS
536 -- version of the manual and the token represents a single dot ".",
537 -- the following word is rewritten according to the rules for
538 -- extensions.
539
540 VMS_Token_Seen : Boolean := False;
541 -- This is set to true if a VMS_Alternative has been encountered, or a
542 -- ^^^ token.
543
544 ----------------
545 -- Next_Token --
546 ----------------
547
548 procedure Next_Token is
549 Remaining_Line : String renames Line (Input_Position .. Line'Last);
550 Last_Character : Natural;
551
552 begin
553 if Remaining_Line'Length = 0 then
554 Token := (End_Of_Line, Remaining_Line'First);
555 return;
556 end if;
557
558 -- ^alpha^beta^, the VMS_Alternative case
559
560 if Remaining_Line (Remaining_Line'First) = VMS_Escape_Character then
561 declare
562 VMS_Second_Character, VMS_Third_Character : Natural;
563
564 begin
565 if VMS_Token_Seen then
566 Error (Source_File, Remaining_Line'First,
567 "multiple " & VMS_Escape_Character
568 & " characters on a single line");
569 else
570 VMS_Token_Seen := True;
571 end if;
572
573 -- Find the second and third escape character. If one of
574 -- them is not present, generate an error token.
575
576 VMS_Second_Character :=
577 Index (Remaining_Line (Remaining_Line'First + 1
578 .. Remaining_Line'Last),
579 (1 => VMS_Escape_Character));
580
581 if VMS_Second_Character = 0 then
582 Input_Position := Remaining_Line'Last + 1;
583 Token := (VMS_Error, Remaining_Line'First);
584 return;
585 end if;
586
587 VMS_Third_Character :=
588 Index (Remaining_Line (VMS_Second_Character + 1
589 .. Remaining_Line'Last),
590 (1 => VMS_Escape_Character));
591
592 if VMS_Third_Character = 0 then
593 Input_Position := Remaining_Line'Last + 1;
594 Token := (VMS_Error, Remaining_Line'First);
595 return;
596 end if;
597
598 -- Consume all the characters we are about to include in
599 -- the token.
600
601 Input_Position := VMS_Third_Character + 1;
602
603 -- Check if we are in a ^^^ situation, and return an Other
604 -- token in this case.
605
606 if Remaining_Line'First + 1 = VMS_Second_Character
607 and then Remaining_Line'First + 2 = VMS_Third_Character
608 then
609 Token := (Other, Remaining_Line'First,
610 (Remaining_Line'First, Remaining_Line'First));
611 return;
612 end if;
613
614 Token := (VMS_Alternative, Remaining_Line'First,
615 (Remaining_Line'First + 1, VMS_Second_Character - 1),
616 (VMS_Second_Character + 1, VMS_Third_Character - 1));
617 return;
618 end;
619 end if;
620
621 -- The Word case. Search for characters not in Word_Characters.
622 -- We have found a word if the first non-word character is not
623 -- the first character in Remaining_Line, i.e. if Remaining_Line
624 -- starts with a word character.
625
626 Last_Character := Index (Remaining_Line, Word_Characters, Outside);
627 if Last_Character /= Remaining_Line'First then
628
629 -- If we haven't found a character which is not in
630 -- Word_Characters, all remaining characters are part of the
631 -- current Word token.
632
633 if Last_Character = 0 then
634 Last_Character := Remaining_Line'Last + 1;
635 end if;
636
637 Input_Position := Last_Character;
638 Token := (Word, Remaining_Line'First,
639 (Remaining_Line'First, Last_Character - 1));
640 return;
641 end if;
642
643 -- Remaining characters are in the Other category. To speed
644 -- up processing, we collect them together if there are several
645 -- of them.
646
647 Input_Position := Last_Character + 1;
648 Token := (Other,
649 Remaining_Line'First,
650 (Remaining_Line'First, Last_Character));
651 end Next_Token;
652
653 ------------------
654 -- Rewrite_Word --
655 ------------------
656
657 procedure Rewrite_Word is
658 First_Word : String
659 renames Line (Token.Span.First .. Token.Span.Last);
660
661 begin
662 -- We do not perform any error checking below, so we can just skip
663 -- all processing for the non-VMS version.
664
665 if Target /= VMS then
666 Append (Rewritten_Line, First_Word);
667 Next_Token;
668 return;
669 end if;
670
671 if Is_Known_Word (First_Word) then
672
673 -- If we have a word from the dictionary, we look for the
674 -- longest possible sequence we can rewrite.
675
676 declare
677 Seq : Token_Span := Token.Span;
678 Lost_Space : Boolean := False;
679
680 begin
681 Next_Token;
682 loop
683 if Token.Kind = Other
684 and then Line (Token.Span.First .. Token.Span.Last) = " "
685 then
686 Next_Token;
687
688 if Token.Kind /= Word
689 or else not Is_Known_Word (Line (Seq.First
690 .. Token.Span.Last))
691 then
692 -- When we reach this point, the following conditions
693 -- are true:
694
695 -- Seq is a known word
696
697 -- The previous token was a space character
698
699 -- Seq extended to the current token is not a
700 -- known word.
701
702 Lost_Space := True;
703 exit;
704
705 else
706 -- Extend Seq to cover the current (known) word
707
708 Seq.Last := Token.Span.Last;
709 Next_Token;
710 end if;
711
712 else
713 -- When we reach this point, the following conditions
714 -- are true:
715
716 -- Seq is a known word
717
718 -- The previous token was a word
719
720 -- The current token is not a space character.
721
722 exit;
723 end if;
724 end loop;
725
726 -- Rewrite Seq, and add the lost space if necessary
727
728 Append (Rewritten_Line,
729 Get_Replacement_Word (Line (Seq.First .. Seq.Last)));
730 if Lost_Space then
731 Append (Rewritten_Line, ' ');
732 end if;
733
734 -- The unknown token will be processed during the
735 -- next iteration of the main loop.
736 return;
737 end;
738 end if;
739
740 Next_Token;
741
742 if Token.Kind = Other
743 and then Line (Token.Span.First .. Token.Span.Last) = "."
744 then
745 -- Deal with extensions
746
747 Next_Token;
748 if Token.Kind = Word
749 and then
750 Is_Extension (Line (Token.Span.First .. Token.Span.Last))
751 then
752 -- We have discovered a file extension. Convert the file
753 -- name to upper case.
754
755 Append (Rewritten_Line,
756 Translate (First_Word, Upper_Case_Map) & '.');
757 Append (Rewritten_Line,
758 Get_Replacement_Extension
759 (Line (Token.Span.First .. Token.Span.Last)));
760 Next_Token;
761 else
762 -- We already have: Word ".", followed by an unknown token
763
764 Append (Rewritten_Line, First_Word & '.');
765
766 -- The unknown token will be processed during the next
767 -- iteration of the main loop.
768 end if;
769
770 else
771 -- We have an unknown Word, followed by an unknown token.
772 -- The unknown token will be processed by the outer loop.
773
774 Append (Rewritten_Line, First_Word);
775 end if;
776 end Rewrite_Word;
777
778 -----------------------------
779 -- Maybe_Rewrite_Extension --
780 -----------------------------
781
782 procedure Maybe_Rewrite_Extension is
783 begin
784 -- Again, we need no special processing in the non-VMS case
785
786 if Target = VMS
787 and then Line (Token.Span.First .. Token.Span.Last) = "."
788 then
789 -- This extension is not preceded by a word, otherwise
790 -- Rewrite_Word would have handled it.
791
792 Next_Token;
793
794 if Token.Kind = Word
795 and then Is_Extension (Line (Token.Span.First
796 .. Token.Span.Last))
797 then
798 Append (Rewritten_Line, '.' & Get_Replacement_Extension
799 (Line (Token.Span.First .. Token.Span.Last)));
800 Next_Token;
801 else
802 Append (Rewritten_Line, '.');
803 end if;
804
805 else
806 Append (Rewritten_Line, Line (Token.Span.First
807 .. Token.Span.Last));
808 Next_Token;
809 end if;
810 end Maybe_Rewrite_Extension;
811
812 -- Start of processing for Process_Source_Line
813
814 begin
815 -- The following parser recognizes the following special token
816 -- sequences:
817
818 -- Word "." Word rewrite as file name if second word is extension
819 -- Word " " Word rewrite as a single word using Ug_Words table
820
821 Next_Token;
822 loop
823 case Token.Kind is
824 when End_Of_Line =>
825 exit;
826
827 when Word =>
828 Rewrite_Word;
829
830 when Other =>
831 Maybe_Rewrite_Extension;
832
833 when VMS_Alternative =>
834 if Target = VMS then
835 Append (Rewritten_Line, Line (Token.VMS.First
836 .. Token.VMS.Last));
837 else
838 Append (Rewritten_Line, Line (Token.Non_VMS.First
839 .. Token.Non_VMS.Last));
840 end if;
841
842 Next_Token;
843
844 when VMS_Error =>
845 Error (Source_File, Token.First, "invalid VMS alternative");
846 Next_Token;
847 end case;
848 end loop;
849
850 return S (Rewritten_Line);
851 end Rewrite_Source_Line;
852
853 -------------------------
854 -- Process_Source_File --
855 -------------------------
856
857 procedure Process_Source_File is
858 begin
859 while not End_Of_File (Source_File.Data) loop
860 declare
861 Line : constant String := Get_Line (Source_File'Access);
862
863 Rewritten : constant String := Rewrite_Source_Line (Line);
864 -- We unconditionally rewrite the line so that we can check the
865 -- syntax of all lines, and not only those which are actually
866 -- included in the output.
867
868 begin
869 if First_Time
870 and then Line'Length > 3 and then Line (1 .. 3) = "@if"
871 then
872 Put_Line (Output_File, "@set " & Argument (1));
873 First_Time := False;
874 end if;
875
876 Put_Line (Output_File, Rewritten);
877 end;
878 end loop;
879 end Process_Source_File;
880
881 ---------------------------
882 -- Initialize_Extensions --
883 ---------------------------
884
885 procedure Initialize_Extensions is
886
887 procedure Add (Extension : String);
888 -- Adds an extension which is replaced with itself (in upper case)
889
890 procedure Add (Extension, Replacement : String);
891 -- Adds an extension with a custom replacement
892
893 ---------
894 -- Add --
895 ---------
896
897 procedure Add (Extension : String) is
898 begin
899 Add (Extension, Translate (Extension, Upper_Case_Map));
900 end Add;
901
902 procedure Add (Extension, Replacement : String) is
903 begin
904 Set (Extensions, Extension, V (Replacement));
905 end Add;
906
907 -- Start of processing for Initialize_Extensions
908
909 begin
910 -- To avoid performance degradation, increase the constant in the
911 -- definition of Extensions above if you add more extensions here.
912
913 Add ("o", "OBJ");
914 Add ("ads");
915 Add ("adb");
916 Add ("ali");
917 Add ("ada");
918 Add ("atb");
919 Add ("ats");
920 Add ("adc");
921 Add ("c");
922 end Initialize_Extensions;
923
924 ------------------
925 -- Is_Extension --
926 ------------------
927
928 function Is_Extension (Extension : String) return Boolean is
929 begin
930 return Present (Extensions, Extension);
931 end Is_Extension;
932
933 -------------------------------
934 -- Get_Replacement_Extension --
935 -------------------------------
936
937 function Get_Replacement_Extension (Extension : String) return String is
938 begin
939 return S (Get (Extensions, Extension));
940 end Get_Replacement_Extension;
941
942 -------------------
943 -- Is_Known_Word --
944 -------------------
945
946 function Is_Known_Word (Word : String) return Boolean is
947 begin
948 return Present (Ug_Words, Word);
949 end Is_Known_Word;
950
951 --------------------------
952 -- Get_Replacement_Word --
953 --------------------------
954
955 function Get_Replacement_Word (Word : String) return String is
956 begin
957 return S (Get (Ug_Words, Word));
958 end Get_Replacement_Word;
959
960 -- Start of processing for Xgnatugn
961
962 Valid_Command_Line : Boolean;
963 Output_File_Name : VString;
964
965 begin
966 Initialize_Extensions;
967 Valid_Command_Line := Argument_Count in 3 .. 5;
968
969 -- First argument: Target
970
971 if Valid_Command_Line then
972 begin
973 Target := Flag_Type'Value (Argument (1));
974
975 if not Target'Valid then
976 Valid_Command_Line := False;
977 end if;
978
979 exception
980 when Constraint_Error =>
981 Valid_Command_Line := False;
982 end;
983 end if;
984
985 -- Second argument: Source_File
986
987 if Valid_Command_Line then
988 begin
989 Source_File.Name := V (Argument (2));
990 Open (Source_File.Data, In_File, Argument (2));
991
992 exception
993 when Ada.Text_IO.Name_Error =>
994 Valid_Command_Line := False;
995 end;
996 end if;
997
998 -- Third argument: Dictionary_File
999
1000 if Valid_Command_Line then
1001 begin
1002 Dictionary_File.Name := V (Argument (3));
1003 Open (Dictionary_File.Data, In_File, Argument (3));
1004
1005 exception
1006 when Ada.Text_IO.Name_Error =>
1007 Valid_Command_Line := False;
1008 end;
1009 end if;
1010
1011 -- Fourth argument: Output_File
1012
1013 if Valid_Command_Line then
1014 if Argument_Count in 4 .. 5 then
1015 Output_File_Name := V (Argument (4));
1016 else
1017 case Target is
1018 when UNW =>
1019 Output_File_Name := V ("gnat_ugn_unw.texi");
1020 when VMS =>
1021 Output_File_Name := V ("gnat_ugn_vms.texi");
1022 end case;
1023 end if;
1024
1025 Warnings_Enabled := Argument_Count = 5;
1026
1027 begin
1028 Create (Output_File, Out_File, S (Output_File_Name));
1029
1030 exception
1031 when Ada.Text_IO.Name_Error | Ada.Text_IO.Use_Error =>
1032 Valid_Command_Line := False;
1033 end;
1034 end if;
1035
1036 if not Valid_Command_Line then
1037 Usage;
1038 Set_Exit_Status (Failure);
1039
1040 else
1041 Read_Dictionary_File;
1042 Close (Dictionary_File.Data);
1043
1044 -- Main processing starts here
1045
1046 Process_Source_File;
1047 Close (Output_File);
1048 Close (Source_File.Data);
1049
1050 New_Line (Standard_Error);
1051
1052 if Number_Of_Warnings = 0 then
1053 Put_Line (Standard_Error, " NO Warnings");
1054
1055 else
1056 Put (Standard_Error, Integer'Image (Number_Of_Warnings));
1057 Put (Standard_Error, " Warning");
1058
1059 if Number_Of_Warnings > 1 then
1060 Put (Standard_Error, "s");
1061 end if;
1062
1063 New_Line (Standard_Error);
1064 end if;
1065
1066 if Number_Of_Errors = 0 then
1067 Put_Line (Standard_Error, " NO Errors");
1068
1069 else
1070 Put (Standard_Error, Integer'Image (Number_Of_Errors));
1071 Put (Standard_Error, " Error");
1072
1073 if Number_Of_Errors > 1 then
1074 Put (Standard_Error, "s");
1075 end if;
1076
1077 New_Line (Standard_Error);
1078 end if;
1079
1080 if Number_Of_Errors /= 0 then
1081 Set_Exit_Status (Failure);
1082 else
1083 Set_Exit_Status (Success);
1084 end if;
1085 end if;
1086 end Xgnatugn;
Mirror of the offical gcc git repository hosted at gcc.gnu.org