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