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