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