gcc/ada/xgnatugn.adb

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