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