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