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