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