gcc/ada/xgnatugn.adb

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