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