gcc/ada/xgnatug.adb

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