gcc/ada/vms_conv.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                            V M S _ C O N V                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1996-2005 Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Gnatvsn;
  28 with Hostparm;
  29 with Opt;
  30 with Osint; use Osint;
  31
  32 with Ada.Characters.Handling; use Ada.Characters.Handling;
  33 with Ada.Command_Line;        use Ada.Command_Line;
  34 with Ada.Text_IO;             use Ada.Text_IO;
  35
  36 package body VMS_Conv is
  37
  38    Keep_Temps_Option : constant Item_Ptr :=
  39                          new Item'
  40                            (Id          => Id_Option,
  41                             Name        =>
  42                               new String'("/KEEP_TEMPORARY_FILES"),
  43                             Next        => null,
  44                             Command     => Undefined,
  45                             Unix_String => null);
  46
  47    Param_Count : Natural := 0;
  48    --  Number of parameter arguments so far
  49
  50    Arg_Num : Natural;
  51    --  Argument number
  52
  53    Arg_File : Ada.Text_IO.File_Type;
  54    --  A file where arguments are read from
  55
  56    Commands : Item_Ptr;
  57    --  Pointer to head of list of command items, one for each command, with
  58    --  the end of the list marked by a null pointer.
  59
  60    Last_Command : Item_Ptr;
  61    --  Pointer to last item in Commands list
  62
  63    Command : Item_Ptr;
  64    --  Pointer to command item for current command
  65
  66    Make_Commands_Active : Item_Ptr := null;
  67    --  Set to point to Command entry for COMPILE, BIND, or LINK as appropriate
  68    --  if a COMMANDS_TRANSLATION switch has been encountered while processing
  69    --  a MAKE Command.
  70
  71    Output_File_Expected : Boolean := False;
  72    --  True for GNAT LINK after -o switch, so that the ".ali" extension is
  73    --  not added to the executable file name.
  74
  75    package Buffer is new Table.Table
  76      (Table_Component_Type => Character,
  77       Table_Index_Type     => Integer,
  78       Table_Low_Bound      => 1,
  79       Table_Initial        => 4096,
  80       Table_Increment      => 2,
  81       Table_Name           => "Buffer");
  82
  83    function Init_Object_Dirs return Argument_List;
  84    --  Get the list of the object directories
  85
  86    function Invert_Sense (S : String) return VMS_Data.String_Ptr;
  87    --  Given a unix switch string S, computes the inverse (adding or
  88    --  removing ! characters as required), and returns a pointer to
  89    --  the allocated result on the heap.
  90
  91    function Is_Extensionless (F : String) return Boolean;
  92    --  Returns true if the filename has no extension
  93
  94    function Match (S1, S2 : String) return Boolean;
  95    --  Determines whether S1 and S2 match (this is a case insensitive match)
  96
  97    function Match_Prefix (S1, S2 : String) return Boolean;
  98    --  Determines whether S1 matches a prefix of S2. This is also a case
  99    --  insensitive match (for example Match ("AB","abc") is True).
 100
 101    function Matching_Name
 102      (S     : String;
 103       Itm   : Item_Ptr;
 104       Quiet : Boolean := False) return Item_Ptr;
 105    --  Determines if the item list headed by Itm and threaded through the
 106    --  Next fields (with null marking the end of the list), contains an
 107    --  entry that uniquely matches the given string. The match is case
 108    --  insensitive and permits unique abbreviation. If the match succeeds,
 109    --  then a pointer to the matching item is returned. Otherwise, an
 110    --  appropriate error message is written. Note that the discriminant
 111    --  of Itm is used to determine the appropriate form of this message.
 112    --  Quiet is normally False as shown, if it is set to True, then no
 113    --  error message is generated in a not found situation (null is still
 114    --  returned to indicate the not-found situation).
 115
 116    function OK_Alphanumerplus (S : String) return Boolean;
 117    --  Checks that S is a string of alphanumeric characters,
 118    --  returning True if all alphanumeric characters,
 119    --  False if empty or a non-alphanumeric character is present.
 120
 121    function OK_Integer (S : String) return Boolean;
 122    --  Checks that S is a string of digits, returning True if all digits,
 123    --  False if empty or a non-digit is present.
 124
 125    procedure Place (C : Character);
 126    --  Place a single character in the buffer, updating Ptr
 127
 128    procedure Place (S : String);
 129    --  Place a string character in the buffer, updating Ptr
 130
 131    procedure Place_Lower (S : String);
 132    --  Place string in buffer, forcing letters to lower case, updating Ptr
 133
 134    procedure Place_Unix_Switches (S : VMS_Data.String_Ptr);
 135    --  Given a unix switch string, place corresponding switches in Buffer,
 136    --  updating Ptr appropriatelly. Note that in the case of use of ! the
 137    --  result may be to remove a previously placed switch.
 138
 139    procedure Preprocess_Command_Data;
 140    --  Preprocess the string form of the command and options list into the
 141    --  internal form.
 142
 143    procedure Process_Argument (The_Command : in out Command_Type);
 144    --  Process one argument from the command line, or one line from
 145    --  from a command line file. For the first call, set The_Command.
 146
 147    procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr);
 148    --  Check that N is a valid command or option name, i.e. that it is of the
 149    --  form of an Ada identifier with upper case letters and underscores.
 150
 151    procedure Validate_Unix_Switch (S : VMS_Data.String_Ptr);
 152    --  Check that S is a valid switch string as described in the syntax for
 153    --  the switch table item UNIX_SWITCH or else begins with a backquote.
 154
 155    ----------------------
 156    -- Init_Object_Dirs --
 157    ----------------------
 158
 159    function Init_Object_Dirs return Argument_List is
 160       Object_Dirs     : Integer;
 161       Object_Dir      : Argument_List (1 .. 256);
 162       Object_Dir_Name : String_Access;
 163
 164    begin
 165       Object_Dirs := 0;
 166       Object_Dir_Name := new String'(Object_Dir_Default_Prefix);
 167       Get_Next_Dir_In_Path_Init (Object_Dir_Name);
 168
 169       loop
 170          declare
 171             Dir : constant String_Access :=
 172                     String_Access (Get_Next_Dir_In_Path (Object_Dir_Name));
 173          begin
 174             exit when Dir = null;
 175             Object_Dirs := Object_Dirs + 1;
 176             Object_Dir (Object_Dirs) :=
 177               new String'("-L" &
 178                           To_Canonical_Dir_Spec
 179                           (To_Host_Dir_Spec
 180                            (Normalize_Directory_Name (Dir.all).all,
 181                             True).all, True).all);
 182          end;
 183       end loop;
 184
 185       Object_Dirs := Object_Dirs + 1;
 186       Object_Dir (Object_Dirs) := new String'("-lgnat");
 187
 188       if Hostparm.OpenVMS then
 189          Object_Dirs := Object_Dirs + 1;
 190          Object_Dir (Object_Dirs) := new String'("-ldecgnat");
 191       end if;
 192
 193       return Object_Dir (1 .. Object_Dirs);
 194    end Init_Object_Dirs;
 195
 196    ----------------
 197    -- Initialize --
 198    ----------------
 199
 200    procedure Initialize is
 201    begin
 202       Command_List :=
 203         (Bind =>
 204            (Cname    => new S'("BIND"),
 205             Usage    => new S'("GNAT BIND file[.ali] /qualifiers"),
 206             VMS_Only => False,
 207             Unixcmd  => new S'("gnatbind"),
 208             Unixsws  => null,
 209             Switches => Bind_Switches'Access,
 210             Params   => new Parameter_Array'(1 => Unlimited_Files),
 211             Defext   => "ali"),
 212
 213          Chop =>
 214            (Cname    => new S'("CHOP"),
 215             Usage    => new S'("GNAT CHOP file [directory] /qualifiers"),
 216             VMS_Only => False,
 217             Unixcmd  => new S'("gnatchop"),
 218             Unixsws  => null,
 219             Switches => Chop_Switches'Access,
 220             Params   => new Parameter_Array'(1 => File, 2 => Optional_File),
 221             Defext   => "   "),
 222
 223          Clean =>
 224            (Cname    => new S'("CLEAN"),
 225             Usage    => new S'("GNAT CLEAN /qualifiers files"),
 226             VMS_Only => False,
 227             Unixcmd  => new S'("gnatclean"),
 228             Unixsws  => null,
 229             Switches => Clean_Switches'Access,
 230             Params   => new Parameter_Array'(1 => File),
 231             Defext   => "   "),
 232
 233          Compile =>
 234            (Cname    => new S'("COMPILE"),
 235             Usage    => new S'("GNAT COMPILE filespec[,...] /qualifiers"),
 236             VMS_Only => False,
 237             Unixcmd  => new S'("gnatmake"),
 238             Unixsws  => new Argument_List'(1 => new String'("-f"),
 239                                            2 => new String'("-u"),
 240                                            3 => new String'("-c")),
 241             Switches => GCC_Switches'Access,
 242             Params   => new Parameter_Array'(1 => Files_Or_Wildcard),
 243             Defext   => "   "),
 244
 245          Elim =>
 246            (Cname    => new S'("ELIM"),
 247             Usage    => new S'("GNAT ELIM name /qualifiers"),
 248             VMS_Only => False,
 249             Unixcmd  => new S'("gnatelim"),
 250             Unixsws  => null,
 251             Switches => Elim_Switches'Access,
 252             Params   => new Parameter_Array'(1 => Other_As_Is),
 253             Defext   => "ali"),
 254
 255          Find =>
 256            (Cname    => new S'("FIND"),
 257             Usage    => new S'("GNAT FIND pattern[:sourcefile[:line"
 258                                & "[:column]]] filespec[,...] /qualifiers"),
 259             VMS_Only => False,
 260             Unixcmd  => new S'("gnatfind"),
 261             Unixsws  => null,
 262             Switches => Find_Switches'Access,
 263             Params   => new Parameter_Array'(1 => Other_As_Is,
 264                                              2 => Files_Or_Wildcard),
 265             Defext   => "ali"),
 266
 267          Krunch =>
 268            (Cname    => new S'("KRUNCH"),
 269             Usage    => new S'("GNAT KRUNCH file [/COUNT=nnn]"),
 270             VMS_Only => False,
 271             Unixcmd  => new S'("gnatkr"),
 272             Unixsws  => null,
 273             Switches => Krunch_Switches'Access,
 274             Params   => new Parameter_Array'(1 => File),
 275             Defext   => "   "),
 276
 277          Link =>
 278            (Cname    => new S'("LINK"),
 279             Usage    => new S'("GNAT LINK file[.ali]"
 280                                & " [extra obj_&_lib_&_exe_&_opt files]"
 281                                & " /qualifiers"),
 282             VMS_Only => False,
 283             Unixcmd  => new S'("gnatlink"),
 284             Unixsws  => null,
 285             Switches => Link_Switches'Access,
 286             Params   => new Parameter_Array'(1 => Unlimited_Files),
 287             Defext   => "ali"),
 288
 289          List =>
 290            (Cname    => new S'("LIST"),
 291             Usage    => new S'("GNAT LIST /qualifiers object_or_ali_file"),
 292             VMS_Only => False,
 293             Unixcmd  => new S'("gnatls"),
 294             Unixsws  => null,
 295             Switches => List_Switches'Access,
 296             Params   => new Parameter_Array'(1 => Unlimited_Files),
 297             Defext   => "ali"),
 298
 299          Make =>
 300            (Cname    => new S'("MAKE"),
 301             Usage    => new S'("GNAT MAKE file(s) /qualifiers (includes "
 302                                & "COMPILE /qualifiers)"),
 303             VMS_Only => False,
 304             Unixcmd  => new S'("gnatmake"),
 305             Unixsws  => null,
 306             Switches => Make_Switches'Access,
 307             Params   => new Parameter_Array'(1 => Unlimited_Files),
 308             Defext   => "   "),
 309
 310          Metric =>
 311            (Cname    => new S'("METRIC"),
 312             Usage    => new S'("GNAT METRIC /qualifiers source_file"),
 313             VMS_Only => False,
 314             Unixcmd  => new S'("gnatmetric"),
 315             Unixsws  => null,
 316             Switches => Metric_Switches'Access,
 317             Params   => new Parameter_Array'(1 => Unlimited_Files),
 318             Defext   => "   "),
 319
 320          Name =>
 321            (Cname    => new S'("NAME"),
 322             Usage    => new S'("GNAT NAME /qualifiers naming-pattern "
 323                                & "[naming-patterns]"),
 324             VMS_Only => False,
 325             Unixcmd  => new S'("gnatname"),
 326             Unixsws  => null,
 327             Switches => Name_Switches'Access,
 328             Params   => new Parameter_Array'(1 => Unlimited_As_Is),
 329             Defext   => "   "),
 330
 331          Preprocess =>
 332            (Cname    => new S'("PREPROCESS"),
 333             Usage    =>
 334               new S'("GNAT PREPROCESS ifile ofile dfile /qualifiers"),
 335             VMS_Only => False,
 336             Unixcmd  => new S'("gnatprep"),
 337             Unixsws  => null,
 338             Switches => Prep_Switches'Access,
 339             Params   => new Parameter_Array'(1 .. 3 => File),
 340             Defext   => "   "),
 341
 342          Pretty =>
 343            (Cname    => new S'("PRETTY"),
 344             Usage    => new S'("GNAT PRETTY /qualifiers source_file"),
 345             VMS_Only => False,
 346             Unixcmd  => new S'("gnatpp"),
 347             Unixsws  => null,
 348             Switches => Pretty_Switches'Access,
 349             Params   => new Parameter_Array'(1 => Unlimited_Files),
 350             Defext   => "   "),
 351
 352          Setup =>
 353            (Cname    => new S'("SETUP"),
 354             Usage    => new S'("GNAT SETUP /qualifiers"),
 355             VMS_Only => False,
 356             Unixcmd  => new S'(""),
 357             Unixsws  => null,
 358             Switches => Setup_Switches'Access,
 359             Params   => new Parameter_Array'(1 => Unlimited_Files),
 360             Defext   => "   "),
 361
 362          Shared =>
 363            (Cname    => new S'("SHARED"),
 364             Usage    => new S'("GNAT SHARED [obj_&_lib_&_exe_&_opt"
 365                                & "files] /qualifiers"),
 366             VMS_Only => True,
 367             Unixcmd  => new S'("gcc"),
 368             Unixsws  =>
 369             new Argument_List'(new String'("-shared") & Init_Object_Dirs),
 370             Switches => Shared_Switches'Access,
 371             Params   => new Parameter_Array'(1 => Unlimited_Files),
 372             Defext   => "   "),
 373
 374          Stub =>
 375            (Cname    => new S'("STUB"),
 376             Usage    => new S'("GNAT STUB file [directory]/qualifiers"),
 377             VMS_Only => False,
 378             Unixcmd  => new S'("gnatstub"),
 379             Unixsws  => null,
 380             Switches => Stub_Switches'Access,
 381             Params   => new Parameter_Array'(1 => File, 2 => Optional_File),
 382             Defext   => "   "),
 383
 384          Xref =>
 385            (Cname    => new S'("XREF"),
 386             Usage    => new S'("GNAT XREF filespec[,...] /qualifiers"),
 387             VMS_Only => False,
 388             Unixcmd  => new S'("gnatxref"),
 389             Unixsws  => null,
 390             Switches => Xref_Switches'Access,
 391             Params   => new Parameter_Array'(1 => Files_Or_Wildcard),
 392             Defext   => "ali")
 393         );
 394    end Initialize;
 395
 396    ------------------
 397    -- Invert_Sense --
 398    ------------------
 399
 400    function Invert_Sense (S : String) return VMS_Data.String_Ptr is
 401       Sinv : String (1 .. S'Length * 2);
 402       --  Result (for sure long enough)
 403
 404       Sinvp : Natural := 0;
 405       --  Pointer to output string
 406
 407    begin
 408       for Sp in S'Range loop
 409          if Sp = S'First or else S (Sp - 1) = ',' then
 410             if S (Sp) = '!' then
 411                null;
 412             else
 413                Sinv (Sinvp + 1) := '!';
 414                Sinv (Sinvp + 2) := S (Sp);
 415                Sinvp := Sinvp + 2;
 416             end if;
 417
 418          else
 419             Sinv (Sinvp + 1) := S (Sp);
 420             Sinvp := Sinvp + 1;
 421          end if;
 422       end loop;
 423
 424       return new String'(Sinv (1 .. Sinvp));
 425    end Invert_Sense;
 426
 427    ----------------------
 428    -- Is_Extensionless --
 429    ----------------------
 430
 431    function Is_Extensionless (F : String) return Boolean is
 432    begin
 433       for J in reverse F'Range loop
 434          if F (J) = '.' then
 435             return False;
 436          elsif F (J) = '/' or else F (J) = ']' or else F (J) = ':' then
 437             return True;
 438          end if;
 439       end loop;
 440
 441       return True;
 442    end Is_Extensionless;
 443
 444    -----------
 445    -- Match --
 446    -----------
 447
 448    function Match (S1, S2 : String) return Boolean is
 449       Dif : constant Integer := S2'First - S1'First;
 450
 451    begin
 452
 453       if S1'Length /= S2'Length then
 454          return False;
 455
 456       else
 457          for J in S1'Range loop
 458             if To_Lower (S1 (J)) /= To_Lower (S2 (J + Dif)) then
 459                return False;
 460             end if;
 461          end loop;
 462
 463          return True;
 464       end if;
 465    end Match;
 466
 467    ------------------
 468    -- Match_Prefix --
 469    ------------------
 470
 471    function Match_Prefix (S1, S2 : String) return Boolean is
 472    begin
 473       if S1'Length > S2'Length then
 474          return False;
 475       else
 476          return Match (S1, S2 (S2'First .. S2'First + S1'Length - 1));
 477       end if;
 478    end Match_Prefix;
 479
 480    -------------------
 481    -- Matching_Name --
 482    -------------------
 483
 484    function Matching_Name
 485      (S     : String;
 486       Itm   : Item_Ptr;
 487       Quiet : Boolean := False) return Item_Ptr
 488    is
 489       P1, P2 : Item_Ptr;
 490
 491       procedure Err;
 492       --  Little procedure to output command/qualifier/option as appropriate
 493       --  and bump error count.
 494
 495       ---------
 496       -- Err --
 497       ---------
 498
 499       procedure Err is
 500       begin
 501          if Quiet then
 502             return;
 503          end if;
 504
 505          Errors := Errors + 1;
 506
 507          if Itm /= null then
 508             case Itm.Id is
 509                when Id_Command =>
 510                   Put (Standard_Error, "command");
 511
 512                when Id_Switch =>
 513                   if Hostparm.OpenVMS then
 514                      Put (Standard_Error, "qualifier");
 515                   else
 516                      Put (Standard_Error, "switch");
 517                   end if;
 518
 519                when Id_Option =>
 520                   Put (Standard_Error, "option");
 521
 522             end case;
 523          else
 524             Put (Standard_Error, "input");
 525
 526          end if;
 527
 528          Put (Standard_Error, ": ");
 529          Put (Standard_Error, S);
 530       end Err;
 531
 532    --  Start of processing for Matching_Name
 533
 534    begin
 535       --  If exact match, that's the one we want
 536
 537       P1 := Itm;
 538       while P1 /= null loop
 539          if Match (S, P1.Name.all) then
 540             return P1;
 541          else
 542             P1 := P1.Next;
 543          end if;
 544       end loop;
 545
 546       --  Now check for prefix matches
 547
 548       P1 := Itm;
 549       while P1 /= null loop
 550          if P1.Name.all = "/<other>" then
 551             return P1;
 552
 553          elsif not Match_Prefix (S, P1.Name.all) then
 554             P1 := P1.Next;
 555
 556          else
 557             --  Here we have found one matching prefix, so see if there is
 558             --  another one (which is an ambiguity)
 559
 560             P2 := P1.Next;
 561             while P2 /= null loop
 562                if Match_Prefix (S, P2.Name.all) then
 563                   if not Quiet then
 564                      Put (Standard_Error, "ambiguous ");
 565                      Err;
 566                      Put (Standard_Error, " (matches ");
 567                      Put (Standard_Error, P1.Name.all);
 568
 569                      while P2 /= null loop
 570                         if Match_Prefix (S, P2.Name.all) then
 571                            Put (Standard_Error, ',');
 572                            Put (Standard_Error, P2.Name.all);
 573                         end if;
 574
 575                         P2 := P2.Next;
 576                      end loop;
 577
 578                      Put_Line (Standard_Error, ")");
 579                   end if;
 580
 581                   return null;
 582                end if;
 583
 584                P2 := P2.Next;
 585             end loop;
 586
 587             --  If we fall through that loop, then there was only one match
 588
 589             return P1;
 590          end if;
 591       end loop;
 592
 593       --  If we fall through outer loop, there was no match
 594
 595       if not Quiet then
 596          Put (Standard_Error, "unrecognized ");
 597          Err;
 598          New_Line (Standard_Error);
 599       end if;
 600
 601       return null;
 602    end Matching_Name;
 603
 604    -----------------------
 605    -- OK_Alphanumerplus --
 606    -----------------------
 607
 608    function OK_Alphanumerplus (S : String) return Boolean is
 609    begin
 610       if S'Length = 0 then
 611          return False;
 612
 613       else
 614          for J in S'Range loop
 615             if not (Is_Alphanumeric (S (J)) or else
 616                     S (J) = '_' or else S (J) = '$')
 617             then
 618                return False;
 619             end if;
 620          end loop;
 621
 622          return True;
 623       end if;
 624    end OK_Alphanumerplus;
 625
 626    ----------------
 627    -- OK_Integer --
 628    ----------------
 629
 630    function OK_Integer (S : String) return Boolean is
 631    begin
 632       if S'Length = 0 then
 633          return False;
 634
 635       else
 636          for J in S'Range loop
 637             if not Is_Digit (S (J)) then
 638                return False;
 639             end if;
 640          end loop;
 641
 642          return True;
 643       end if;
 644    end OK_Integer;
 645
 646    --------------------
 647    -- Output_Version --
 648    --------------------
 649
 650    procedure Output_Version is
 651    begin
 652       Put ("GNAT ");
 653       Put_Line (Gnatvsn.Gnat_Version_String);
 654       Put_Line ("Copyright 1996-2005 Free Software Foundation, Inc.");
 655    end Output_Version;
 656
 657    -----------
 658    -- Place --
 659    -----------
 660
 661    procedure Place (C : Character) is
 662    begin
 663       Buffer.Increment_Last;
 664       Buffer.Table (Buffer.Last) := C;
 665    end Place;
 666
 667    procedure Place (S : String) is
 668    begin
 669       for J in S'Range loop
 670          Place (S (J));
 671       end loop;
 672    end Place;
 673
 674    -----------------
 675    -- Place_Lower --
 676    -----------------
 677
 678    procedure Place_Lower (S : String) is
 679    begin
 680       for J in S'Range loop
 681          Place (To_Lower (S (J)));
 682       end loop;
 683    end Place_Lower;
 684
 685    -------------------------
 686    -- Place_Unix_Switches --
 687    -------------------------
 688
 689    procedure Place_Unix_Switches (S : VMS_Data.String_Ptr) is
 690       P1, P2, P3 : Natural;
 691       Remove     : Boolean;
 692       Slen, Sln2 : Natural;
 693       Wild_Card  : Boolean := False;
 694
 695    begin
 696       P1 := S'First;
 697       while P1 <= S'Last loop
 698          if S (P1) = '!' then
 699             P1 := P1 + 1;
 700             Remove := True;
 701          else
 702             Remove := False;
 703          end if;
 704
 705          P2 := P1;
 706          pragma Assert (S (P1) = '-' or else S (P1) = '`');
 707
 708          while P2 < S'Last and then S (P2 + 1) /= ',' loop
 709             P2 := P2 + 1;
 710          end loop;
 711
 712          --  Switch is now in S (P1 .. P2)
 713
 714          Slen := P2 - P1 + 1;
 715
 716          if Remove then
 717             Wild_Card := S (P2) = '*';
 718
 719             if Wild_Card then
 720                Slen := Slen - 1;
 721                P2   := P2 - 1;
 722             end if;
 723
 724             P3 := 1;
 725             while P3 <= Buffer.Last - Slen loop
 726                if Buffer.Table (P3) = ' '
 727                  and then String (Buffer.Table (P3 + 1 .. P3 + Slen)) =
 728                                                              S (P1 .. P2)
 729                  and then (Wild_Card
 730                              or else
 731                            P3 + Slen = Buffer.Last
 732                              or else
 733                            Buffer.Table (P3 + Slen + 1) = ' ')
 734                then
 735                   Sln2 := Slen;
 736
 737                   if Wild_Card then
 738                      while P3 + Sln2 /= Buffer.Last
 739                        and then Buffer.Table (P3 + Sln2 + 1) /= ' '
 740                      loop
 741                         Sln2 := Sln2 + 1;
 742                      end loop;
 743                   end if;
 744
 745                   Buffer.Table (P3 .. Buffer.Last - Sln2 - 1) :=
 746                     Buffer.Table (P3 + Sln2 + 1 .. Buffer.Last);
 747                   Buffer.Set_Last (Buffer.Last - Sln2 - 1);
 748
 749                else
 750                   P3 := P3 + 1;
 751                end if;
 752             end loop;
 753
 754             if Wild_Card then
 755                P2 := P2 + 1;
 756             end if;
 757
 758          else
 759             pragma Assert (S (P2) /= '*');
 760             Place (' ');
 761
 762             if S (P1) = '`' then
 763                P1 := P1 + 1;
 764             end if;
 765
 766             Place (S (P1 .. P2));
 767          end if;
 768
 769          P1 := P2 + 2;
 770       end loop;
 771    end Place_Unix_Switches;
 772
 773    -----------------------------
 774    -- Preprocess_Command_Data --
 775    -----------------------------
 776
 777    procedure Preprocess_Command_Data is
 778    begin
 779       for C in Real_Command_Type loop
 780          declare
 781             Command : constant Item_Ptr := new Command_Item;
 782
 783             Last_Switch : Item_Ptr;
 784             --  Last switch in list
 785
 786          begin
 787             --  Link new command item into list of commands
 788
 789             if Last_Command = null then
 790                Commands := Command;
 791             else
 792                Last_Command.Next := Command;
 793             end if;
 794
 795             Last_Command := Command;
 796
 797             --  Fill in fields of new command item
 798
 799             Command.Name    := Command_List (C).Cname;
 800             Command.Usage   := Command_List (C).Usage;
 801             Command.Command := C;
 802
 803             if Command_List (C).Unixsws = null then
 804                Command.Unix_String := Command_List (C).Unixcmd;
 805             else
 806                declare
 807                   Cmd  : String (1 .. 5_000);
 808                   Last : Natural := 0;
 809                   Sws  : constant Argument_List_Access :=
 810                            Command_List (C).Unixsws;
 811
 812                begin
 813                   Cmd (1 .. Command_List (C).Unixcmd'Length) :=
 814                     Command_List (C).Unixcmd.all;
 815                   Last := Command_List (C).Unixcmd'Length;
 816
 817                   for J in Sws'Range loop
 818                      Last := Last + 1;
 819                      Cmd (Last) := ' ';
 820                      Cmd (Last + 1 .. Last + Sws (J)'Length) :=
 821                        Sws (J).all;
 822                      Last := Last + Sws (J)'Length;
 823                   end loop;
 824
 825                   Command.Unix_String := new String'(Cmd (1 .. Last));
 826                end;
 827             end if;
 828
 829             Command.Params := Command_List (C).Params;
 830             Command.Defext := Command_List (C).Defext;
 831
 832             Validate_Command_Or_Option (Command.Name);
 833
 834             --  Process the switch list
 835
 836             for S in Command_List (C).Switches'Range loop
 837                declare
 838                   SS : constant VMS_Data.String_Ptr :=
 839                          Command_List (C).Switches (S);
 840                   P  : Natural := SS'First;
 841                   Sw : Item_Ptr := new Switch_Item;
 842
 843                   Last_Opt : Item_Ptr;
 844                   --  Pointer to last option
 845
 846                begin
 847                   --  Link new switch item into list of switches
 848
 849                   if Last_Switch = null then
 850                      Command.Switches := Sw;
 851                   else
 852                      Last_Switch.Next := Sw;
 853                   end if;
 854
 855                   Last_Switch := Sw;
 856
 857                   --  Process switch string, first get name
 858
 859                   while SS (P) /= ' ' and SS (P) /= '=' loop
 860                      P := P + 1;
 861                   end loop;
 862
 863                   Sw.Name := new String'(SS (SS'First .. P - 1));
 864
 865                   --  Direct translation case
 866
 867                   if SS (P) = ' ' then
 868                      Sw.Translation := T_Direct;
 869                      Sw.Unix_String := new String'(SS (P + 1 .. SS'Last));
 870                      Validate_Unix_Switch (Sw.Unix_String);
 871
 872                      if SS (P - 1) = '>' then
 873                         Sw.Translation := T_Other;
 874
 875                      elsif SS (P + 1) = '`' then
 876                         null;
 877
 878                         --  Create the inverted case (/NO ..)
 879
 880                      elsif SS (SS'First + 1 .. SS'First + 2) /= "NO" then
 881                         Sw := new Switch_Item;
 882                         Last_Switch.Next := Sw;
 883                         Last_Switch := Sw;
 884
 885                         Sw.Name :=
 886                           new String'("/NO" & SS (SS'First + 1 .. P - 1));
 887                         Sw.Translation := T_Direct;
 888                         Sw.Unix_String := Invert_Sense (SS (P + 1 .. SS'Last));
 889                         Validate_Unix_Switch (Sw.Unix_String);
 890                      end if;
 891
 892                   --  Directories translation case
 893
 894                   elsif SS (P + 1) = '*' then
 895                      pragma Assert (SS (SS'Last) = '*');
 896                      Sw.Translation := T_Directories;
 897                      Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
 898                      Validate_Unix_Switch (Sw.Unix_String);
 899
 900                   --  Directory translation case
 901
 902                   elsif SS (P + 1) = '%' then
 903                      pragma Assert (SS (SS'Last) = '%');
 904                      Sw.Translation := T_Directory;
 905                      Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
 906                      Validate_Unix_Switch (Sw.Unix_String);
 907
 908                   --  File translation case
 909
 910                   elsif SS (P + 1) = '@' then
 911                      pragma Assert (SS (SS'Last) = '@');
 912                      Sw.Translation := T_File;
 913                      Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
 914                      Validate_Unix_Switch (Sw.Unix_String);
 915
 916                   --  No space file translation case
 917
 918                   elsif SS (P + 1) = '<' then
 919                      pragma Assert (SS (SS'Last) = '>');
 920                      Sw.Translation := T_No_Space_File;
 921                      Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
 922                      Validate_Unix_Switch (Sw.Unix_String);
 923
 924                   --  Numeric translation case
 925
 926                   elsif SS (P + 1) = '#' then
 927                      pragma Assert (SS (SS'Last) = '#');
 928                      Sw.Translation := T_Numeric;
 929                      Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
 930                      Validate_Unix_Switch (Sw.Unix_String);
 931
 932                   --  Alphanumerplus translation case
 933
 934                   elsif SS (P + 1) = '|' then
 935                      pragma Assert (SS (SS'Last) = '|');
 936                      Sw.Translation := T_Alphanumplus;
 937                      Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
 938                      Validate_Unix_Switch (Sw.Unix_String);
 939
 940                   --  String translation case
 941
 942                   elsif SS (P + 1) = '"' then
 943                      pragma Assert (SS (SS'Last) = '"');
 944                      Sw.Translation := T_String;
 945                      Sw.Unix_String := new String'(SS (P + 2 .. SS'Last - 1));
 946                      Validate_Unix_Switch (Sw.Unix_String);
 947
 948                   --  Commands translation case
 949
 950                   elsif SS (P + 1) = '?' then
 951                      Sw.Translation := T_Commands;
 952                      Sw.Unix_String := new String'(SS (P + 2 .. SS'Last));
 953
 954                   --  Options translation case
 955
 956                   else
 957                      Sw.Translation := T_Options;
 958                      Sw.Unix_String := new String'("");
 959
 960                      P := P + 1; -- bump past =
 961                      while P <= SS'Last loop
 962                         declare
 963                            Opt : constant Item_Ptr := new Option_Item;
 964                            Q   : Natural;
 965
 966                         begin
 967                            --  Link new option item into options list
 968
 969                            if Last_Opt = null then
 970                               Sw.Options := Opt;
 971                            else
 972                               Last_Opt.Next := Opt;
 973                            end if;
 974
 975                            Last_Opt := Opt;
 976
 977                            --  Fill in fields of new option item
 978
 979                            Q := P;
 980                            while SS (Q) /= ' ' loop
 981                               Q := Q + 1;
 982                            end loop;
 983
 984                            Opt.Name := new String'(SS (P .. Q - 1));
 985                            Validate_Command_Or_Option (Opt.Name);
 986
 987                            P := Q + 1;
 988                            Q := P;
 989
 990                            while Q <= SS'Last and then SS (Q) /= ' ' loop
 991                               Q := Q + 1;
 992                            end loop;
 993
 994                            Opt.Unix_String := new String'(SS (P .. Q - 1));
 995                            Validate_Unix_Switch (Opt.Unix_String);
 996                            P := Q + 1;
 997                         end;
 998                      end loop;
 999                   end if;
1000                end;
1001             end loop;
1002          end;
1003       end loop;
1004    end Preprocess_Command_Data;
1005
1006    ----------------------
1007    -- Process_Argument --
1008    ----------------------
1009
1010    procedure Process_Argument (The_Command : in out Command_Type) is
1011       Argv    : String_Access;
1012       Arg_Idx : Integer;
1013
1014       function Get_Arg_End
1015         (Argv    : String;
1016          Arg_Idx : Integer) return Integer;
1017       --  Begins looking at Arg_Idx + 1 and returns the index of the
1018       --  last character before a slash or else the index of the last
1019       --  character in the string Argv.
1020
1021       -----------------
1022       -- Get_Arg_End --
1023       -----------------
1024
1025       function Get_Arg_End
1026         (Argv    : String;
1027          Arg_Idx : Integer) return Integer
1028       is
1029       begin
1030          for J in Arg_Idx + 1 .. Argv'Last loop
1031             if Argv (J) = '/' then
1032                return J - 1;
1033             end if;
1034          end loop;
1035
1036          return Argv'Last;
1037       end Get_Arg_End;
1038
1039       --  Start of processing for Process_Argument
1040
1041    begin
1042       --  If an argument file is open, read the next non empty line
1043
1044       if Is_Open (Arg_File) then
1045          declare
1046             Line : String (1 .. 256);
1047             Last : Natural;
1048          begin
1049             loop
1050                Get_Line (Arg_File, Line, Last);
1051                exit when Last /= 0 or else End_Of_File (Arg_File);
1052             end loop;
1053
1054             --  If the end of the argument file has been reached, close it
1055
1056             if End_Of_File (Arg_File) then
1057                Close (Arg_File);
1058
1059                --  If the last line was empty, return after increasing Arg_Num
1060                --  to go to the next argument on the comment line.
1061
1062                if Last = 0 then
1063                   Arg_Num := Arg_Num + 1;
1064                   return;
1065                end if;
1066             end if;
1067
1068             Argv := new String'(Line (1 .. Last));
1069             Arg_Idx := 1;
1070
1071             if Argv (1) = '@' then
1072                Put_Line (Standard_Error, "argument file cannot contain @cmd");
1073                raise Error_Exit;
1074             end if;
1075          end;
1076
1077       else
1078          --  No argument file is open, get the argument on the command line
1079
1080          Argv := new String'(Argument (Arg_Num));
1081          Arg_Idx := Argv'First;
1082
1083          --  Check if this is the specification of an argument file
1084
1085          if Argv (Arg_Idx) = '@' then
1086             --  The first argument on the command line cannot be an argument
1087             --  file.
1088
1089             if Arg_Num = 1 then
1090                Put_Line
1091                  (Standard_Error,
1092                   "Cannot specify argument line before command");
1093                raise Error_Exit;
1094             end if;
1095
1096             --  Open the file, after conversion of the name to canonical form.
1097             --  Fail if file is not found.
1098
1099             declare
1100                Canonical_File_Name : String_Access :=
1101                  To_Canonical_File_Spec (Argv (Arg_Idx + 1 .. Argv'Last));
1102             begin
1103                Open (Arg_File, In_File, Canonical_File_Name.all);
1104                Free (Canonical_File_Name);
1105                return;
1106
1107             exception
1108                when others =>
1109                   Put (Standard_Error, "Cannot open argument file """);
1110                   Put (Standard_Error, Argv (Arg_Idx + 1 .. Argv'Last));
1111                   Put_Line (Standard_Error, """");
1112                   raise Error_Exit;
1113             end;
1114          end if;
1115       end if;
1116
1117       <<Tryagain_After_Coalesce>>
1118       loop
1119          declare
1120             Next_Arg_Idx : Integer;
1121             Arg          : String_Access;
1122
1123          begin
1124             Next_Arg_Idx := Get_Arg_End (Argv.all, Arg_Idx);
1125             Arg := new String'(Argv (Arg_Idx .. Next_Arg_Idx));
1126
1127             --  The first one must be a command name
1128
1129             if Arg_Num = 1 and then Arg_Idx = Argv'First then
1130                Command := Matching_Name (Arg.all, Commands);
1131
1132                if Command = null then
1133                   raise Error_Exit;
1134                end if;
1135
1136                The_Command := Command.Command;
1137                Output_File_Expected := False;
1138
1139                --  Give usage information if only command given
1140
1141                if Argument_Count = 1
1142                  and then Next_Arg_Idx = Argv'Last
1143                then
1144                   Output_Version;
1145                   New_Line;
1146                   Put_Line
1147                     ("List of available qualifiers and options");
1148                   New_Line;
1149
1150                   Put (Command.Usage.all);
1151                   Set_Col (53);
1152                   Put_Line (Command.Unix_String.all);
1153
1154                   declare
1155                      Sw : Item_Ptr := Command.Switches;
1156
1157                   begin
1158                      while Sw /= null loop
1159                         Put ("   ");
1160                         Put (Sw.Name.all);
1161
1162                         case Sw.Translation is
1163
1164                            when T_Other =>
1165                               Set_Col (53);
1166                               Put_Line (Sw.Unix_String.all &
1167                                         "/<other>");
1168
1169                            when T_Direct =>
1170                               Set_Col (53);
1171                               Put_Line (Sw.Unix_String.all);
1172
1173                            when T_Directories =>
1174                               Put ("=(direc,direc,..direc)");
1175                               Set_Col (53);
1176                               Put (Sw.Unix_String.all);
1177                               Put (" direc ");
1178                               Put (Sw.Unix_String.all);
1179                               Put_Line (" direc ...");
1180
1181                            when T_Directory =>
1182                               Put ("=directory");
1183                               Set_Col (53);
1184                               Put (Sw.Unix_String.all);
1185
1186                               if Sw.Unix_String (Sw.Unix_String'Last)
1187                               /= '='
1188                               then
1189                                  Put (' ');
1190                               end if;
1191
1192                               Put_Line ("directory ");
1193
1194                            when T_File | T_No_Space_File =>
1195                               Put ("=file");
1196                               Set_Col (53);
1197                               Put (Sw.Unix_String.all);
1198
1199                               if Sw.Translation = T_File
1200                                 and then Sw.Unix_String
1201                                   (Sw.Unix_String'Last) /= '='
1202                               then
1203                                  Put (' ');
1204                               end if;
1205
1206                               Put_Line ("file ");
1207
1208                            when T_Numeric =>
1209                               Put ("=nnn");
1210                               Set_Col (53);
1211
1212                               if Sw.Unix_String
1213                                 (Sw.Unix_String'First) = '`'
1214                               then
1215                                  Put (Sw.Unix_String
1216                                         (Sw.Unix_String'First + 1
1217                                          .. Sw.Unix_String'Last));
1218                               else
1219                                  Put (Sw.Unix_String.all);
1220                               end if;
1221
1222                               Put_Line ("nnn");
1223
1224                            when T_Alphanumplus =>
1225                               Put ("=xyz");
1226                               Set_Col (53);
1227
1228                               if Sw.Unix_String
1229                                 (Sw.Unix_String'First) = '`'
1230                               then
1231                                  Put (Sw.Unix_String
1232                                         (Sw.Unix_String'First + 1
1233                                          .. Sw.Unix_String'Last));
1234                               else
1235                                  Put (Sw.Unix_String.all);
1236                               end if;
1237
1238                               Put_Line ("xyz");
1239
1240                            when T_String =>
1241                               Put ("=");
1242                               Put ('"');
1243                               Put ("<string>");
1244                               Put ('"');
1245                               Set_Col (53);
1246
1247                               Put (Sw.Unix_String.all);
1248
1249                               if Sw.Unix_String
1250                                 (Sw.Unix_String'Last) /= '='
1251                               then
1252                                  Put (' ');
1253                               end if;
1254
1255                               Put ("<string>");
1256                               New_Line;
1257
1258                            when T_Commands =>
1259                               Put (" (switches for ");
1260                               Put (Sw.Unix_String
1261                                      (Sw.Unix_String'First + 7
1262                                       .. Sw.Unix_String'Last));
1263                               Put (')');
1264                               Set_Col (53);
1265                               Put (Sw.Unix_String
1266                                      (Sw.Unix_String'First
1267                                       .. Sw.Unix_String'First + 5));
1268                               Put_Line (" switches");
1269
1270                            when T_Options =>
1271                               declare
1272                                  Opt : Item_Ptr := Sw.Options;
1273
1274                               begin
1275                                  Put_Line ("=(option,option..)");
1276
1277                                  while Opt /= null loop
1278                                     Put ("      ");
1279                                     Put (Opt.Name.all);
1280
1281                                     if Opt = Sw.Options then
1282                                        Put (" (D)");
1283                                     end if;
1284
1285                                     Set_Col (53);
1286                                     Put_Line (Opt.Unix_String.all);
1287                                     Opt := Opt.Next;
1288                                  end loop;
1289                               end;
1290
1291                         end case;
1292
1293                         Sw := Sw.Next;
1294                      end loop;
1295                   end;
1296
1297                   raise Normal_Exit;
1298                end if;
1299
1300             --  Special handling for internal debugging switch /?
1301
1302             elsif Arg.all = "/?" then
1303                Display_Command := True;
1304                Output_File_Expected := False;
1305
1306             --  Special handling of internal option /KEEP_TEMPORARY_FILES
1307
1308             elsif Arg'Length >= 7
1309               and then Matching_Name
1310                          (Arg.all, Keep_Temps_Option, True) /= null
1311             then
1312                Opt.Keep_Temporary_Files := True;
1313
1314             --  Copy -switch unchanged
1315
1316             elsif Arg (Arg'First) = '-' then
1317                Place (' ');
1318                Place (Arg.all);
1319
1320                --  Set Output_File_Expected for the next argument
1321
1322                Output_File_Expected :=
1323                  Arg.all = "-o" and then The_Command = Link;
1324
1325                --  Copy quoted switch with quotes stripped
1326
1327             elsif Arg (Arg'First) = '"' then
1328                if Arg (Arg'Last) /= '"' then
1329                   Put (Standard_Error, "misquoted argument: ");
1330                   Put_Line (Standard_Error, Arg.all);
1331                   Errors := Errors + 1;
1332
1333                else
1334                   Place (' ');
1335                   Place (Arg (Arg'First + 1 .. Arg'Last - 1));
1336                end if;
1337
1338                Output_File_Expected := False;
1339
1340                --  Parameter Argument
1341
1342             elsif Arg (Arg'First) /= '/'
1343               and then Make_Commands_Active = null
1344             then
1345                Param_Count := Param_Count + 1;
1346
1347                if Param_Count <= Command.Params'Length then
1348
1349                   case Command.Params (Param_Count) is
1350
1351                      when File | Optional_File =>
1352                         declare
1353                            Normal_File : constant String_Access :=
1354                              To_Canonical_File_Spec
1355                                (Arg.all);
1356
1357                         begin
1358                            Place (' ');
1359                            Place_Lower (Normal_File.all);
1360
1361                            if Is_Extensionless (Normal_File.all)
1362                              and then Command.Defext /= "   "
1363                            then
1364                               Place ('.');
1365                               Place (Command.Defext);
1366                            end if;
1367                         end;
1368
1369                      when Unlimited_Files =>
1370                         declare
1371                            Normal_File : constant String_Access :=
1372                              To_Canonical_File_Spec
1373                                (Arg.all);
1374
1375                            File_Is_Wild : Boolean := False;
1376                            File_List    : String_Access_List_Access;
1377
1378                         begin
1379                            for J in Arg'Range loop
1380                               if Arg (J) = '*'
1381                                 or else Arg (J) = '%'
1382                               then
1383                                  File_Is_Wild := True;
1384                               end if;
1385                            end loop;
1386
1387                            if File_Is_Wild then
1388                               File_List := To_Canonical_File_List
1389                                 (Arg.all, False);
1390
1391                               for J in File_List.all'Range loop
1392                                  Place (' ');
1393                                  Place_Lower (File_List.all (J).all);
1394                               end loop;
1395
1396                            else
1397                               Place (' ');
1398                               Place_Lower (Normal_File.all);
1399
1400                               --  Add extension if not present, except after
1401                               --  switch -o.
1402
1403                               if Is_Extensionless (Normal_File.all)
1404                                 and then Command.Defext /= "   "
1405                                 and then not Output_File_Expected
1406                               then
1407                                  Place ('.');
1408                                  Place (Command.Defext);
1409                               end if;
1410                            end if;
1411
1412                            Param_Count := Param_Count - 1;
1413                         end;
1414
1415                      when Other_As_Is =>
1416                         Place (' ');
1417                         Place (Arg.all);
1418
1419                      when Unlimited_As_Is =>
1420                         Place (' ');
1421                         Place (Arg.all);
1422                         Param_Count := Param_Count - 1;
1423
1424                      when Files_Or_Wildcard =>
1425
1426                         --  Remove spaces from a comma separated list
1427                         --  of file names and adjust control variables
1428                         --  accordingly.
1429
1430                         while Arg_Num < Argument_Count and then
1431                           (Argv (Argv'Last) = ',' xor
1432                              Argument (Arg_Num + 1)
1433                              (Argument (Arg_Num + 1)'First) = ',')
1434                         loop
1435                            Argv := new String'
1436                              (Argv.all & Argument (Arg_Num + 1));
1437                            Arg_Num := Arg_Num + 1;
1438                            Arg_Idx := Argv'First;
1439                            Next_Arg_Idx :=
1440                              Get_Arg_End (Argv.all, Arg_Idx);
1441                            Arg := new String'
1442                              (Argv (Arg_Idx .. Next_Arg_Idx));
1443                         end loop;
1444
1445                         --  Parse the comma separated list of VMS
1446                         --  filenames and place them on the command
1447                         --  line as space separated Unix style
1448                         --  filenames. Lower case and add default
1449                         --  extension as appropriate.
1450
1451                         declare
1452                            Arg1_Idx : Integer := Arg'First;
1453
1454                            function Get_Arg1_End
1455                              (Arg     : String;
1456                               Arg_Idx : Integer) return Integer;
1457                            --  Begins looking at Arg_Idx + 1 and
1458                            --  returns the index of the last character
1459                            --  before a comma or else the index of the
1460                            --  last character in the string Arg.
1461
1462                            ------------------
1463                            -- Get_Arg1_End --
1464                            ------------------
1465
1466                            function Get_Arg1_End
1467                              (Arg     : String;
1468                               Arg_Idx : Integer) return Integer
1469                            is
1470                            begin
1471                               for J in Arg_Idx + 1 .. Arg'Last loop
1472                                  if Arg (J) = ',' then
1473                                     return J - 1;
1474                                  end if;
1475                               end loop;
1476
1477                               return Arg'Last;
1478                            end Get_Arg1_End;
1479
1480                         begin
1481                            loop
1482                               declare
1483                                  Next_Arg1_Idx :
1484                                  constant Integer :=
1485                                    Get_Arg1_End (Arg.all, Arg1_Idx);
1486
1487                                  Arg1 :
1488                                  constant String :=
1489                                    Arg (Arg1_Idx .. Next_Arg1_Idx);
1490
1491                                  Normal_File :
1492                                  constant String_Access :=
1493                                    To_Canonical_File_Spec (Arg1);
1494
1495                               begin
1496                                  Place (' ');
1497                                  Place_Lower (Normal_File.all);
1498
1499                                  if Is_Extensionless (Normal_File.all)
1500                                    and then Command.Defext /= "   "
1501                                  then
1502                                     Place ('.');
1503                                     Place (Command.Defext);
1504                                  end if;
1505
1506                                  Arg1_Idx := Next_Arg1_Idx + 1;
1507                               end;
1508
1509                               exit when Arg1_Idx > Arg'Last;
1510
1511                               --  Don't allow two or more commas in
1512                               --  a row
1513
1514                               if Arg (Arg1_Idx) = ',' then
1515                                  Arg1_Idx := Arg1_Idx + 1;
1516                                  if Arg1_Idx > Arg'Last or else
1517                                    Arg (Arg1_Idx) = ','
1518                                  then
1519                                     Put_Line
1520                                       (Standard_Error,
1521                                        "Malformed Parameter: " &
1522                                        Arg.all);
1523                                     Put (Standard_Error, "usage: ");
1524                                     Put_Line (Standard_Error,
1525                                               Command.Usage.all);
1526                                     raise Error_Exit;
1527                                  end if;
1528                               end if;
1529
1530                            end loop;
1531                         end;
1532                   end case;
1533                end if;
1534
1535                --  Reset Output_File_Expected, in case it was True
1536
1537                Output_File_Expected := False;
1538
1539                --  Qualifier argument
1540
1541             else
1542                Output_File_Expected := False;
1543
1544                --  This code is too heavily nested, should be
1545                --  separated out as separate subprogram ???
1546
1547                declare
1548                   Sw   : Item_Ptr;
1549                   SwP  : Natural;
1550                   P2   : Natural;
1551                   Endp : Natural := 0; -- avoid warning!
1552                   Opt  : Item_Ptr;
1553
1554                begin
1555                   SwP := Arg'First;
1556                   while SwP < Arg'Last
1557                     and then Arg (SwP + 1) /= '='
1558                   loop
1559                      SwP := SwP + 1;
1560                   end loop;
1561
1562                   --  At this point, the switch name is in
1563                   --  Arg (Arg'First..SwP) and if that is not the
1564                   --  whole switch, then there is an equal sign at
1565                   --  Arg (SwP + 1) and the rest of Arg is what comes
1566                   --  after the equal sign.
1567
1568                   --  If make commands are active, see if we have
1569                   --  another COMMANDS_TRANSLATION switch belonging
1570                   --  to gnatmake.
1571
1572                   if Make_Commands_Active /= null then
1573                      Sw :=
1574                        Matching_Name
1575                          (Arg (Arg'First .. SwP),
1576                           Command.Switches,
1577                           Quiet => True);
1578
1579                      if Sw /= null
1580                        and then Sw.Translation = T_Commands
1581                      then
1582                         null;
1583
1584                      else
1585                         Sw :=
1586                           Matching_Name
1587                             (Arg (Arg'First .. SwP),
1588                              Make_Commands_Active.Switches,
1589                              Quiet => False);
1590                      end if;
1591
1592                      --  For case of GNAT MAKE or CHOP, if we cannot
1593                      --  find the switch, then see if it is a
1594                      --  recognized compiler switch instead, and if
1595                      --  so process the compiler switch.
1596
1597                   elsif Command.Name.all = "MAKE"
1598                     or else Command.Name.all = "CHOP" then
1599                      Sw :=
1600                        Matching_Name
1601                          (Arg (Arg'First .. SwP),
1602                           Command.Switches,
1603                           Quiet => True);
1604
1605                      if Sw = null then
1606                         Sw :=
1607                           Matching_Name
1608                             (Arg (Arg'First .. SwP),
1609                              Matching_Name
1610                                ("COMPILE", Commands).Switches,
1611                              Quiet => False);
1612                      end if;
1613
1614                      --  For all other cases, just search the relevant
1615                      --  command.
1616
1617                   else
1618                      Sw :=
1619                        Matching_Name
1620                          (Arg (Arg'First .. SwP),
1621                           Command.Switches,
1622                           Quiet => False);
1623                   end if;
1624
1625                   if Sw /= null then
1626                      case Sw.Translation is
1627
1628                         when T_Direct =>
1629                            Place_Unix_Switches (Sw.Unix_String);
1630                            if SwP < Arg'Last
1631                              and then Arg (SwP + 1) = '='
1632                            then
1633                               Put (Standard_Error,
1634                                    "qualifier options ignored: ");
1635                               Put_Line (Standard_Error, Arg.all);
1636                            end if;
1637
1638                         when T_Directories =>
1639                            if SwP + 1 > Arg'Last then
1640                               Put (Standard_Error,
1641                                    "missing directories for: ");
1642                               Put_Line (Standard_Error, Arg.all);
1643                               Errors := Errors + 1;
1644
1645                            elsif Arg (SwP + 2) /= '(' then
1646                               SwP := SwP + 2;
1647                               Endp := Arg'Last;
1648
1649                            elsif Arg (Arg'Last) /= ')' then
1650
1651                               --  Remove spaces from a comma separated
1652                               --  list of file names and adjust
1653                               --  control variables accordingly.
1654
1655                               if Arg_Num < Argument_Count and then
1656                                 (Argv (Argv'Last) = ',' xor
1657                                    Argument (Arg_Num + 1)
1658                                    (Argument (Arg_Num + 1)'First) = ',')
1659                               then
1660                                  Argv :=
1661                                    new String'(Argv.all
1662                                                & Argument
1663                                                  (Arg_Num + 1));
1664                                  Arg_Num := Arg_Num + 1;
1665                                  Arg_Idx := Argv'First;
1666                                  Next_Arg_Idx :=
1667                                    Get_Arg_End (Argv.all, Arg_Idx);
1668                                  Arg := new String'
1669                                    (Argv (Arg_Idx .. Next_Arg_Idx));
1670                                  goto Tryagain_After_Coalesce;
1671                               end if;
1672
1673                               Put (Standard_Error,
1674                                    "incorrectly parenthesized " &
1675                                    "or malformed argument: ");
1676                               Put_Line (Standard_Error, Arg.all);
1677                               Errors := Errors + 1;
1678
1679                            else
1680                               SwP := SwP + 3;
1681                               Endp := Arg'Last - 1;
1682                            end if;
1683
1684                            while SwP <= Endp loop
1685                               declare
1686                                  Dir_Is_Wild       : Boolean := False;
1687                                  Dir_Maybe_Is_Wild : Boolean := False;
1688
1689                                  Dir_List : String_Access_List_Access;
1690
1691                               begin
1692                                  P2 := SwP;
1693
1694                                  while P2 < Endp
1695                                    and then Arg (P2 + 1) /= ','
1696                                  loop
1697                                     --  A wildcard directory spec on
1698                                     --  VMS will contain either * or
1699                                     --  % or ...
1700
1701                                     if Arg (P2) = '*' then
1702                                        Dir_Is_Wild := True;
1703
1704                                     elsif Arg (P2) = '%' then
1705                                        Dir_Is_Wild := True;
1706
1707                                     elsif Dir_Maybe_Is_Wild
1708                                       and then Arg (P2) = '.'
1709                                       and then Arg (P2 + 1) = '.'
1710                                     then
1711                                        Dir_Is_Wild := True;
1712                                        Dir_Maybe_Is_Wild := False;
1713
1714                                     elsif Dir_Maybe_Is_Wild then
1715                                        Dir_Maybe_Is_Wild := False;
1716
1717                                     elsif Arg (P2) = '.'
1718                                       and then Arg (P2 + 1) = '.'
1719                                     then
1720                                        Dir_Maybe_Is_Wild := True;
1721
1722                                     end if;
1723
1724                                     P2 := P2 + 1;
1725                                  end loop;
1726
1727                                  if Dir_Is_Wild then
1728                                     Dir_List :=
1729                                       To_Canonical_File_List
1730                                         (Arg (SwP .. P2), True);
1731
1732                                     for J in Dir_List.all'Range loop
1733                                        Place_Unix_Switches
1734                                          (Sw.Unix_String);
1735                                        Place_Lower
1736                                          (Dir_List.all (J).all);
1737                                     end loop;
1738
1739                                  else
1740                                     Place_Unix_Switches
1741                                       (Sw.Unix_String);
1742                                     Place_Lower
1743                                       (To_Canonical_Dir_Spec
1744                                          (Arg (SwP .. P2), False).all);
1745                                  end if;
1746
1747                                  SwP := P2 + 2;
1748                               end;
1749                            end loop;
1750
1751                         when T_Directory =>
1752                            if SwP + 1 > Arg'Last then
1753                               Put (Standard_Error,
1754                                    "missing directory for: ");
1755                               Put_Line (Standard_Error, Arg.all);
1756                               Errors := Errors + 1;
1757
1758                            else
1759                               Place_Unix_Switches (Sw.Unix_String);
1760
1761                               --  Some switches end in "=". No space
1762                               --  here
1763
1764                               if Sw.Unix_String
1765                                 (Sw.Unix_String'Last) /= '='
1766                               then
1767                                  Place (' ');
1768                               end if;
1769
1770                               Place_Lower
1771                                 (To_Canonical_Dir_Spec
1772                                    (Arg (SwP + 2 .. Arg'Last),
1773                                     False).all);
1774                            end if;
1775
1776                         when T_File | T_No_Space_File =>
1777                            if SwP + 1 > Arg'Last then
1778                               Put (Standard_Error,
1779                                    "missing file for: ");
1780                               Put_Line (Standard_Error, Arg.all);
1781                               Errors := Errors + 1;
1782
1783                            else
1784                               Place_Unix_Switches (Sw.Unix_String);
1785
1786                               --  Some switches end in "=". No space
1787                               --  here.
1788
1789                               if Sw.Translation = T_File
1790                                 and then Sw.Unix_String
1791                                   (Sw.Unix_String'Last) /= '='
1792                               then
1793                                  Place (' ');
1794                               end if;
1795
1796                               Place_Lower
1797                                 (To_Canonical_File_Spec
1798                                    (Arg (SwP + 2 .. Arg'Last)).all);
1799                            end if;
1800
1801                         when T_Numeric =>
1802                            if OK_Integer (Arg (SwP + 2 .. Arg'Last)) then
1803                               Place_Unix_Switches (Sw.Unix_String);
1804                               Place (Arg (SwP + 2 .. Arg'Last));
1805
1806                            else
1807                               Put (Standard_Error, "argument for ");
1808                               Put (Standard_Error, Sw.Name.all);
1809                               Put_Line
1810                                 (Standard_Error, " must be numeric");
1811                               Errors := Errors + 1;
1812                            end if;
1813
1814                         when T_Alphanumplus =>
1815                            if OK_Alphanumerplus
1816                              (Arg (SwP + 2 .. Arg'Last))
1817                            then
1818                               Place_Unix_Switches (Sw.Unix_String);
1819                               Place (Arg (SwP + 2 .. Arg'Last));
1820
1821                            else
1822                               Put (Standard_Error, "argument for ");
1823                               Put (Standard_Error, Sw.Name.all);
1824                               Put_Line (Standard_Error,
1825                                         " must be alphanumeric");
1826                               Errors := Errors + 1;
1827                            end if;
1828
1829                         when T_String =>
1830
1831                            --  A String value must be extended to the
1832                            --  end of the Argv, otherwise strings like
1833                            --  "foo/bar" get split at the slash.
1834
1835                            --  The begining and ending of the string
1836                            --  are flagged with embedded nulls which
1837                            --  are removed when building the Spawn
1838                            --  call. Nulls are use because they won't
1839                            --  show up in a /? output. Quotes aren't
1840                            --  used because that would make it
1841                            --  difficult to embed them.
1842
1843                            Place_Unix_Switches (Sw.Unix_String);
1844
1845                            if Next_Arg_Idx /= Argv'Last then
1846                               Next_Arg_Idx := Argv'Last;
1847                               Arg := new String'
1848                                 (Argv (Arg_Idx .. Next_Arg_Idx));
1849
1850                               SwP := Arg'First;
1851                               while SwP < Arg'Last and then
1852                               Arg (SwP + 1) /= '=' loop
1853                                  SwP := SwP + 1;
1854                               end loop;
1855                            end if;
1856
1857                            Place (ASCII.NUL);
1858                            Place (Arg (SwP + 2 .. Arg'Last));
1859                            Place (ASCII.NUL);
1860
1861                         when T_Commands =>
1862
1863                            --  Output -largs/-bargs/-cargs
1864
1865                            Place (' ');
1866                            Place (Sw.Unix_String
1867                                     (Sw.Unix_String'First ..
1868                                        Sw.Unix_String'First + 5));
1869
1870                            if Sw.Unix_String
1871                              (Sw.Unix_String'First + 7 ..
1872                                 Sw.Unix_String'Last) = "MAKE"
1873                            then
1874                               Make_Commands_Active := null;
1875
1876                            else
1877                               --  Set source of new commands, also
1878                               --  setting this non-null indicates that
1879                               --  we are in the special commands mode
1880                               --  for processing the -xargs case.
1881
1882                               Make_Commands_Active :=
1883                                 Matching_Name
1884                                   (Sw.Unix_String
1885                                        (Sw.Unix_String'First + 7 ..
1886                                             Sw.Unix_String'Last),
1887                                    Commands);
1888                            end if;
1889
1890                         when T_Options =>
1891                            if SwP + 1 > Arg'Last then
1892                               Place_Unix_Switches
1893                                 (Sw.Options.Unix_String);
1894                               SwP := Endp + 1;
1895
1896                            elsif Arg (SwP + 2) /= '(' then
1897                               SwP := SwP + 2;
1898                               Endp := Arg'Last;
1899
1900                            elsif Arg (Arg'Last) /= ')' then
1901                               Put (Standard_Error,
1902                                    "incorrectly parenthesized argument: ");
1903                               Put_Line (Standard_Error, Arg.all);
1904                               Errors := Errors + 1;
1905                               SwP := Endp + 1;
1906
1907                            else
1908                               SwP := SwP + 3;
1909                               Endp := Arg'Last - 1;
1910                            end if;
1911
1912                            while SwP <= Endp loop
1913                               P2 := SwP;
1914
1915                               while P2 < Endp
1916                                 and then Arg (P2 + 1) /= ','
1917                               loop
1918                                  P2 := P2 + 1;
1919                               end loop;
1920
1921                               --  Option name is in Arg (SwP .. P2)
1922
1923                               Opt := Matching_Name (Arg (SwP .. P2),
1924                                                     Sw.Options);
1925
1926                               if Opt /= null then
1927                                  Place_Unix_Switches
1928                                    (Opt.Unix_String);
1929                               end if;
1930
1931                               SwP := P2 + 2;
1932                            end loop;
1933
1934                         when T_Other =>
1935                            Place_Unix_Switches
1936                              (new String'(Sw.Unix_String.all &
1937                                           Arg.all));
1938
1939                      end case;
1940                   end if;
1941                end;
1942             end if;
1943
1944             Arg_Idx := Next_Arg_Idx + 1;
1945          end;
1946
1947          exit when Arg_Idx > Argv'Last;
1948
1949       end loop;
1950
1951       if not Is_Open (Arg_File) then
1952          Arg_Num := Arg_Num + 1;
1953       end if;
1954    end Process_Argument;
1955
1956    --------------------------------
1957    -- Validate_Command_Or_Option --
1958    --------------------------------
1959
1960    procedure Validate_Command_Or_Option (N : VMS_Data.String_Ptr) is
1961    begin
1962       pragma Assert (N'Length > 0);
1963
1964       for J in N'Range loop
1965          if N (J) = '_' then
1966             pragma Assert (N (J - 1) /= '_');
1967             null;
1968          else
1969             pragma Assert (Is_Upper (N (J)) or else Is_Digit (N (J)));
1970             null;
1971          end if;
1972       end loop;
1973    end Validate_Command_Or_Option;
1974
1975    --------------------------
1976    -- Validate_Unix_Switch --
1977    --------------------------
1978
1979    procedure Validate_Unix_Switch (S : VMS_Data.String_Ptr) is
1980    begin
1981       if S (S'First) = '`' then
1982          return;
1983       end if;
1984
1985       pragma Assert (S (S'First) = '-' or else S (S'First) = '!');
1986
1987       for J in S'First + 1 .. S'Last loop
1988          pragma Assert (S (J) /= ' ');
1989
1990          if S (J) = '!' then
1991             pragma Assert (S (J - 1) = ',' and then S (J + 1) = '-');
1992             null;
1993          end if;
1994       end loop;
1995    end Validate_Unix_Switch;
1996
1997    --------------------
1998    -- VMS_Conversion --
1999    --------------------
2000
2001    procedure VMS_Conversion (The_Command : out Command_Type) is
2002       Result : Command_Type := Undefined;
2003       Result_Set : Boolean := False;
2004    begin
2005       Buffer.Init;
2006
2007       --  First we must preprocess the string form of the command and options
2008       --  list into the internal form that we use.
2009
2010       Preprocess_Command_Data;
2011
2012       --  If no parameters, give complete list of commands
2013
2014       if Argument_Count = 0 then
2015          Output_Version;
2016          New_Line;
2017          Put_Line ("List of available commands");
2018          New_Line;
2019
2020          while Commands /= null loop
2021             Put (Commands.Usage.all);
2022             Set_Col (53);
2023             Put_Line (Commands.Unix_String.all);
2024             Commands := Commands.Next;
2025          end loop;
2026
2027          raise Normal_Exit;
2028       end if;
2029
2030       Arg_Num := 1;
2031
2032       --  Loop through arguments
2033
2034       while Arg_Num <= Argument_Count loop
2035          Process_Argument (Result);
2036
2037          if not Result_Set then
2038             The_Command := Result;
2039             Result_Set := True;
2040          end if;
2041       end loop;
2042
2043       --  Gross error checking that the number of parameters is correct.
2044       --  Not applicable to Unlimited_Files parameters.
2045
2046       if (Param_Count = Command.Params'Length - 1
2047             and then Command.Params (Param_Count + 1) = Unlimited_Files)
2048         or else Param_Count <= Command.Params'Length
2049       then
2050          null;
2051
2052       else
2053          Put_Line (Standard_Error,
2054                    "Parameter count of "
2055                    & Integer'Image (Param_Count)
2056                    & " not equal to expected "
2057                    & Integer'Image (Command.Params'Length));
2058          Put (Standard_Error, "usage: ");
2059          Put_Line (Standard_Error, Command.Usage.all);
2060          Errors := Errors + 1;
2061       end if;
2062
2063       if Errors > 0 then
2064          raise Error_Exit;
2065       else
2066          --  Prepare arguments for a call to spawn, filtering out
2067          --  embedded nulls place there to delineate strings.
2068
2069          declare
2070             P1, P2     : Natural;
2071             Inside_Nul : Boolean := False;
2072             Arg        : String (1 .. 1024);
2073             Arg_Ctr    : Natural;
2074
2075          begin
2076             P1 := 1;
2077
2078             while P1 <= Buffer.Last and then Buffer.Table (P1) = ' ' loop
2079                P1 := P1 + 1;
2080             end loop;
2081
2082             Arg_Ctr := 1;
2083             Arg (Arg_Ctr) := Buffer.Table (P1);
2084
2085             while P1 <= Buffer.Last loop
2086
2087                if Buffer.Table (P1) = ASCII.NUL then
2088                   if Inside_Nul then
2089                      Inside_Nul := False;
2090                   else
2091                      Inside_Nul := True;
2092                   end if;
2093                end if;
2094
2095                if Buffer.Table (P1) = ' ' and then not Inside_Nul then
2096                   P1 := P1 + 1;
2097                   Arg_Ctr := Arg_Ctr + 1;
2098                   Arg (Arg_Ctr) := Buffer.Table (P1);
2099
2100                else
2101                   Last_Switches.Increment_Last;
2102                   P2 := P1;
2103
2104                   while P2 < Buffer.Last
2105                     and then (Buffer.Table (P2 + 1) /= ' ' or else
2106                               Inside_Nul)
2107                   loop
2108                      P2 := P2 + 1;
2109                      Arg_Ctr := Arg_Ctr + 1;
2110                      Arg (Arg_Ctr) := Buffer.Table (P2);
2111                      if Buffer.Table (P2) = ASCII.NUL then
2112                         Arg_Ctr := Arg_Ctr - 1;
2113                         if Inside_Nul then
2114                            Inside_Nul := False;
2115                         else
2116                            Inside_Nul := True;
2117                         end if;
2118                      end if;
2119                   end loop;
2120
2121                   Last_Switches.Table (Last_Switches.Last) :=
2122                     new String'(String (Arg (1 .. Arg_Ctr)));
2123                   P1 := P2 + 2;
2124                   Arg_Ctr := 1;
2125                   Arg (Arg_Ctr) := Buffer.Table (P1);
2126                end if;
2127             end loop;
2128          end;
2129       end if;
2130    end VMS_Conversion;
2131
2132 end VMS_Conv;