File : gnatcmd.adb


   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              G N A T C M D                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1996-2016, 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 3,  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 COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25 
  26 with Csets;
  27 with Gnatvsn;
  28 with Makeutl;  use Makeutl;
  29 with Namet;    use Namet;
  30 with Opt;      use Opt;
  31 with Osint;    use Osint;
  32 with Output;   use Output;
  33 with Prj;      use Prj;
  34 with Prj.Env;
  35 with Prj.Ext;  use Prj.Ext;
  36 with Prj.Pars;
  37 with Prj.Tree; use Prj.Tree;
  38 with Prj.Util; use Prj.Util;
  39 with Sdefault;
  40 with Sinput.P;
  41 with Snames;   use Snames;
  42 with Stringt;
  43 with Switch;   use Switch;
  44 with Table;
  45 with Tempdir;
  46 with Types;    use Types;
  47 
  48 with Ada.Characters.Handling; use Ada.Characters.Handling;
  49 with Ada.Command_Line;        use Ada.Command_Line;
  50 with Ada.Text_IO;             use Ada.Text_IO;
  51 
  52 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
  53 with GNAT.OS_Lib;               use GNAT.OS_Lib;
  54 
  55 procedure GNATCmd is
  56    Gprbuild : constant String := "gprbuild";
  57    Gprclean : constant String := "gprclean";
  58    Gprname  : constant String := "gprname";
  59    Gprls    : constant String := "gprls";
  60 
  61    Error_Exit : exception;
  62    --  Raise this exception if error detected
  63 
  64    type Command_Type is
  65      (Bind,
  66       Chop,
  67       Clean,
  68       Compile,
  69       Check,
  70       Elim,
  71       Find,
  72       Krunch,
  73       Link,
  74       List,
  75       Make,
  76       Metric,
  77       Name,
  78       Preprocess,
  79       Pretty,
  80       Stack,
  81       Stub,
  82       Test,
  83       Xref,
  84       Undefined);
  85 
  86    subtype Real_Command_Type is Command_Type range Bind .. Xref;
  87    --  All real command types (excludes only Undefined).
  88 
  89    type Alternate_Command is (Comp, Ls, Kr, Pp, Prep);
  90    --  Alternate command label
  91 
  92    Corresponding_To : constant array (Alternate_Command) of Command_Type :=
  93      (Comp  => Compile,
  94       Ls    => List,
  95       Kr    => Krunch,
  96       Prep  => Preprocess,
  97       Pp    => Pretty);
  98    --  Mapping of alternate commands to commands
  99 
 100    Call_GPR_Tool : Boolean := False;
 101    --  True when a GPR tool should be called, if available
 102 
 103    Project_Node_Tree : Project_Node_Tree_Ref;
 104    Project_File      : String_Access;
 105    Project           : Prj.Project_Id;
 106    Current_Verbosity : Prj.Verbosity := Prj.Default;
 107    Tool_Package_Name : Name_Id       := No_Name;
 108 
 109    Project_Tree : constant Project_Tree_Ref :=
 110                     new Project_Tree_Data (Is_Root_Tree => True);
 111    --  The project tree
 112 
 113    All_Projects : Boolean := False;
 114 
 115    Temp_File_Name : Path_Name_Type := No_Path;
 116    --  The name of the temporary text file to put a list of source/object
 117    --  files to pass to a tool.
 118 
 119    package First_Switches is new Table.Table
 120      (Table_Component_Type => String_Access,
 121       Table_Index_Type     => Integer,
 122       Table_Low_Bound      => 1,
 123       Table_Initial        => 20,
 124       Table_Increment      => 100,
 125       Table_Name           => "Gnatcmd.First_Switches");
 126    --  A table to keep the switches from the project file
 127 
 128    package Last_Switches is new Table.Table
 129      (Table_Component_Type => String_Access,
 130       Table_Index_Type     => Integer,
 131       Table_Low_Bound      => 1,
 132       Table_Initial        => 20,
 133       Table_Increment      => 100,
 134       Table_Name           => "Gnatcmd.Last_Switches");
 135 
 136    ----------------------------------
 137    -- Declarations for GNATCMD use --
 138    ----------------------------------
 139 
 140    The_Command : Command_Type;
 141    --  The command specified in the invocation of the GNAT driver
 142 
 143    Command_Arg : Positive := 1;
 144    --  The index of the command in the arguments of the GNAT driver
 145 
 146    My_Exit_Status : Exit_Status := Success;
 147    --  The exit status of the spawned tool
 148 
 149    type Command_Entry is record
 150       Cname : String_Access;
 151       --  Command name for GNAT xxx command
 152 
 153       Unixcmd : String_Access;
 154       --  Corresponding Unix command
 155 
 156       Unixsws : Argument_List_Access;
 157       --  List of switches to be used with the Unix command
 158    end record;
 159 
 160    Command_List : constant array (Real_Command_Type) of Command_Entry :=
 161      (Bind =>
 162         (Cname    => new String'("BIND"),
 163          Unixcmd  => new String'("gnatbind"),
 164          Unixsws  => null),
 165 
 166       Chop =>
 167         (Cname    => new String'("CHOP"),
 168          Unixcmd  => new String'("gnatchop"),
 169          Unixsws  => null),
 170 
 171       Clean =>
 172         (Cname    => new String'("CLEAN"),
 173          Unixcmd  => new String'("gnatclean"),
 174          Unixsws  => null),
 175 
 176       Compile =>
 177         (Cname    => new String'("COMPILE"),
 178          Unixcmd  => new String'("gnatmake"),
 179          Unixsws  => new Argument_List'(1 => new String'("-f"),
 180                                         2 => new String'("-u"),
 181                                         3 => new String'("-c"))),
 182 
 183       Check =>
 184         (Cname    => new String'("CHECK"),
 185          Unixcmd  => new String'("gnatcheck"),
 186          Unixsws  => null),
 187 
 188       Elim =>
 189         (Cname    => new String'("ELIM"),
 190          Unixcmd  => new String'("gnatelim"),
 191          Unixsws  => null),
 192 
 193       Find =>
 194         (Cname    => new String'("FIND"),
 195          Unixcmd  => new String'("gnatfind"),
 196          Unixsws  => null),
 197 
 198       Krunch =>
 199         (Cname    => new String'("KRUNCH"),
 200          Unixcmd  => new String'("gnatkr"),
 201          Unixsws  => null),
 202 
 203       Link =>
 204         (Cname    => new String'("LINK"),
 205          Unixcmd  => new String'("gnatlink"),
 206          Unixsws  => null),
 207 
 208       List =>
 209         (Cname    => new String'("LIST"),
 210          Unixcmd  => new String'("gnatls"),
 211          Unixsws  => null),
 212 
 213       Make =>
 214         (Cname    => new String'("MAKE"),
 215          Unixcmd  => new String'("gnatmake"),
 216          Unixsws  => null),
 217 
 218       Metric =>
 219         (Cname    => new String'("METRIC"),
 220          Unixcmd  => new String'("gnatmetric"),
 221          Unixsws  => null),
 222 
 223       Name =>
 224         (Cname    => new String'("NAME"),
 225          Unixcmd  => new String'("gnatname"),
 226          Unixsws  => null),
 227 
 228       Preprocess =>
 229         (Cname    => new String'("PREPROCESS"),
 230          Unixcmd  => new String'("gnatprep"),
 231          Unixsws  => null),
 232 
 233       Pretty =>
 234         (Cname    => new String'("PRETTY"),
 235          Unixcmd  => new String'("gnatpp"),
 236          Unixsws  => null),
 237 
 238       Stack =>
 239         (Cname    => new String'("STACK"),
 240          Unixcmd  => new String'("gnatstack"),
 241          Unixsws  => null),
 242 
 243       Stub =>
 244         (Cname    => new String'("STUB"),
 245          Unixcmd  => new String'("gnatstub"),
 246          Unixsws  => null),
 247 
 248       Test =>
 249         (Cname    => new String'("TEST"),
 250          Unixcmd  => new String'("gnattest"),
 251          Unixsws  => null),
 252 
 253       Xref =>
 254         (Cname    => new String'("XREF"),
 255          Unixcmd  => new String'("gnatxref"),
 256          Unixsws  => null)
 257      );
 258 
 259    subtype SA is String_Access;
 260 
 261    Naming_String      : constant SA := new String'("naming");
 262    Gnatls_String      : constant SA := new String'("gnatls");
 263 
 264    Packages_To_Check_By_Gnatls    : constant String_List_Access :=
 265      new String_List'((Naming_String, Gnatls_String));
 266 
 267    Packages_To_Check : String_List_Access := Prj.All_Packages;
 268 
 269    -----------------------
 270    -- Local Subprograms --
 271    -----------------------
 272 
 273    procedure Check_Files;
 274    --  For GNAT LIST -V, check if a project file is specified, without any file
 275    --  arguments and without a switch -files=. If it is the case, invoke the
 276    --  GNAT tool with the proper list of files, derived from the sources of
 277    --  the project.
 278 
 279    procedure Output_Version;
 280    --  Output the version of this program
 281 
 282    procedure Usage;
 283    --  Display usage
 284 
 285    -----------------
 286    -- Check_Files --
 287    -----------------
 288 
 289    procedure Check_Files is
 290       Add_Sources : Boolean := True;
 291       Unit        : Prj.Unit_Index;
 292       Subunit     : Boolean := False;
 293       FD          : File_Descriptor := Invalid_FD;
 294       Status      : Integer;
 295       Success     : Boolean;
 296 
 297       procedure Add_To_Response_File
 298         (File_Name  : String;
 299          Check_File : Boolean := True);
 300       --  Include the file name passed as parameter in the response file for
 301       --  the tool being called. If the response file can not be written then
 302       --  the file name is passed in the parameter list of the tool. If the
 303       --  Check_File parameter is True then the procedure verifies the
 304       --  existence of the file before adding it to the response file.
 305 
 306       --------------------------
 307       -- Add_To_Response_File --
 308       --------------------------
 309 
 310       procedure Add_To_Response_File
 311         (File_Name  : String;
 312          Check_File : Boolean := True)
 313       is
 314       begin
 315          Name_Len := 0;
 316 
 317          Add_Str_To_Name_Buffer (File_Name);
 318 
 319          if not Check_File or else
 320            Is_Regular_File (Name_Buffer (1 .. Name_Len))
 321          then
 322             if FD /= Invalid_FD then
 323                Name_Len := Name_Len + 1;
 324                Name_Buffer (Name_Len) := ASCII.LF;
 325 
 326                Status := Write (FD, Name_Buffer (1)'Address, Name_Len);
 327 
 328                if Status /= Name_Len then
 329                   Osint.Fail ("disk full");
 330                end if;
 331             else
 332                Last_Switches.Increment_Last;
 333                Last_Switches.Table (Last_Switches.Last) :=
 334                  new String'(File_Name);
 335             end if;
 336          end if;
 337       end Add_To_Response_File;
 338 
 339    --  Start of processing for Check_Files
 340 
 341    begin
 342       --  Check if there is at least one argument that is not a switch
 343 
 344       for Index in 1 .. Last_Switches.Last loop
 345          if Last_Switches.Table (Index) (1) /= '-'
 346            or else (Last_Switches.Table (Index).all'Length > 7
 347                      and then Last_Switches.Table (Index) (1 .. 7) = "-files=")
 348          then
 349             Add_Sources := False;
 350             exit;
 351          end if;
 352       end loop;
 353 
 354       --  If all arguments are switches and there is no switch -files=, add the
 355       --  path names of all the sources of the main project.
 356 
 357       if Add_Sources then
 358          Tempdir.Create_Temp_File (FD, Temp_File_Name);
 359          Last_Switches.Increment_Last;
 360          Last_Switches.Table (Last_Switches.Last) :=
 361            new String'("-files=" & Get_Name_String (Temp_File_Name));
 362 
 363          Unit := Units_Htable.Get_First (Project_Tree.Units_HT);
 364          while Unit /= No_Unit_Index loop
 365 
 366             --  We only need to put the library units, body or spec, but not
 367             --  the subunits.
 368 
 369             if Unit.File_Names (Impl) /= null
 370               and then not Unit.File_Names (Impl).Locally_Removed
 371             then
 372                --  There is a body, check if it is for this project
 373 
 374                if All_Projects
 375                  or else Unit.File_Names (Impl).Project = Project
 376                then
 377                   Subunit := False;
 378 
 379                   if Unit.File_Names (Spec) = null
 380                     or else Unit.File_Names (Spec).Locally_Removed
 381                   then
 382                      --  We have a body with no spec: we need to check if
 383                      --  this is a subunit, because gnatls will complain
 384                      --  about subunits.
 385 
 386                      declare
 387                         Src_Ind : constant Source_File_Index :=
 388                                     Sinput.P.Load_Project_File
 389                                       (Get_Name_String
 390                                          (Unit.File_Names (Impl).Path.Name));
 391                      begin
 392                         Subunit := Sinput.P.Source_File_Is_Subunit (Src_Ind);
 393                      end;
 394                   end if;
 395 
 396                   if not Subunit then
 397                      Add_To_Response_File
 398                        (Get_Name_String (Unit.File_Names (Impl).Display_File),
 399                         Check_File => False);
 400                   end if;
 401                end if;
 402 
 403             elsif Unit.File_Names (Spec) /= null
 404               and then not Unit.File_Names (Spec).Locally_Removed
 405             then
 406                --  We have a spec with no body. Check if it is for this project
 407 
 408                if All_Projects
 409                  or else Unit.File_Names (Spec).Project = Project
 410                then
 411                   Add_To_Response_File
 412                     (Get_Name_String (Unit.File_Names (Spec).Display_File),
 413                      Check_File => False);
 414                end if;
 415             end if;
 416 
 417             Unit := Units_Htable.Get_Next (Project_Tree.Units_HT);
 418          end loop;
 419 
 420          if FD /= Invalid_FD then
 421             Close (FD, Success);
 422 
 423             if not Success then
 424                Osint.Fail ("disk full");
 425             end if;
 426          end if;
 427       end if;
 428    end Check_Files;
 429 
 430    --------------------
 431    -- Output_Version --
 432    --------------------
 433 
 434    procedure Output_Version is
 435    begin
 436       Put ("GNAT ");
 437       Put_Line (Gnatvsn.Gnat_Version_String);
 438       Put_Line ("Copyright 1996-" & Gnatvsn.Current_Year
 439                 & ", Free Software Foundation, Inc.");
 440    end Output_Version;
 441 
 442    -----------
 443    -- Usage --
 444    -----------
 445 
 446    procedure Usage is
 447    begin
 448       Output_Version;
 449       New_Line;
 450       Put_Line ("List of available commands");
 451       New_Line;
 452 
 453       for C in Command_List'Range loop
 454          Put ("gnat ");
 455          Put (To_Lower (Command_List (C).Cname.all));
 456          Set_Col (25);
 457          Put (Program_Name (Command_List (C).Unixcmd.all, "gnat").all);
 458 
 459          declare
 460             Sws : Argument_List_Access renames Command_List (C).Unixsws;
 461          begin
 462             if Sws /= null then
 463                for J in Sws'Range loop
 464                   Put (' ');
 465                   Put (Sws (J).all);
 466                end loop;
 467             end if;
 468          end;
 469 
 470          New_Line;
 471       end loop;
 472 
 473       New_Line;
 474    end Usage;
 475 
 476    procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
 477 
 478 --  Start of processing for GNATCmd
 479 
 480 begin
 481    --  All output from GNATCmd is debugging or error output: send to stderr
 482 
 483    Set_Standard_Error;
 484 
 485    --  Initializations
 486 
 487    Csets.Initialize;
 488    Snames.Initialize;
 489    Stringt.Initialize;
 490 
 491    Prj.Tree.Initialize (Root_Environment, Gnatmake_Flags);
 492 
 493    Project_Node_Tree := new Project_Node_Tree_Data;
 494    Prj.Tree.Initialize (Project_Node_Tree);
 495 
 496    Prj.Initialize (Project_Tree);
 497 
 498    Last_Switches.Init;
 499    Last_Switches.Set_Last (0);
 500 
 501    First_Switches.Init;
 502    First_Switches.Set_Last (0);
 503 
 504    --  Put the command line in environment variable GNAT_DRIVER_COMMAND_LINE,
 505    --  so that the spawned tool may know the way the GNAT driver was invoked.
 506 
 507    Name_Len := 0;
 508    Add_Str_To_Name_Buffer (Command_Name);
 509 
 510    for J in 1 .. Argument_Count loop
 511       Add_Char_To_Name_Buffer (' ');
 512       Add_Str_To_Name_Buffer (Argument (J));
 513    end loop;
 514 
 515    Setenv ("GNAT_DRIVER_COMMAND_LINE", Name_Buffer (1 .. Name_Len));
 516 
 517    --  Add the directory where the GNAT driver is invoked in front of the path,
 518    --  if the GNAT driver is invoked with directory information.
 519 
 520    declare
 521       Command : constant String := Command_Name;
 522 
 523    begin
 524       for Index in reverse Command'Range loop
 525          if Command (Index) = Directory_Separator then
 526             declare
 527                Absolute_Dir : constant String :=
 528                  Normalize_Pathname (Command (Command'First .. Index));
 529                PATH         : constant String :=
 530                  Absolute_Dir & Path_Separator & Getenv ("PATH").all;
 531             begin
 532                Setenv ("PATH", PATH);
 533             end;
 534 
 535             exit;
 536          end if;
 537       end loop;
 538    end;
 539 
 540    --  Scan the command line
 541 
 542    --  First, scan to detect --version and/or --help
 543 
 544    Check_Version_And_Help ("GNAT", "1996");
 545 
 546    begin
 547       loop
 548          if Command_Arg <= Argument_Count
 549            and then Argument (Command_Arg) = "-v"
 550          then
 551             Verbose_Mode := True;
 552             Command_Arg := Command_Arg + 1;
 553 
 554          elsif Command_Arg <= Argument_Count
 555            and then Argument (Command_Arg) = "-dn"
 556          then
 557             Keep_Temporary_Files := True;
 558             Command_Arg := Command_Arg + 1;
 559 
 560          else
 561             exit;
 562          end if;
 563       end loop;
 564 
 565       --  If there is no command, just output the usage
 566 
 567       if Command_Arg > Argument_Count then
 568          Usage;
 569          return;
 570       end if;
 571 
 572       The_Command := Real_Command_Type'Value (Argument (Command_Arg));
 573 
 574    exception
 575       when Constraint_Error =>
 576 
 577          --  Check if it is an alternate command
 578 
 579          declare
 580             Alternate : Alternate_Command;
 581 
 582          begin
 583             Alternate := Alternate_Command'Value (Argument (Command_Arg));
 584             The_Command := Corresponding_To (Alternate);
 585 
 586          exception
 587             when Constraint_Error =>
 588                Usage;
 589                Fail ("unknown command: " & Argument (Command_Arg));
 590          end;
 591    end;
 592 
 593    --  Get the arguments from the command line and from the eventual
 594    --  argument file(s) specified on the command line.
 595 
 596    for Arg in Command_Arg + 1 .. Argument_Count loop
 597       declare
 598          The_Arg : constant String := Argument (Arg);
 599 
 600       begin
 601          --  Check if an argument file is specified
 602 
 603          if The_Arg (The_Arg'First) = '@' then
 604             declare
 605                Arg_File : Ada.Text_IO.File_Type;
 606                Line     : String (1 .. 256);
 607                Last     : Natural;
 608 
 609             begin
 610                --  Open the file and fail if the file cannot be found
 611 
 612                begin
 613                   Open (Arg_File, In_File,
 614                         The_Arg (The_Arg'First + 1 .. The_Arg'Last));
 615 
 616                exception
 617                   when others =>
 618                      Put (Standard_Error, "Cannot open argument file """);
 619                      Put (Standard_Error,
 620                           The_Arg (The_Arg'First + 1 .. The_Arg'Last));
 621                      Put_Line (Standard_Error, """");
 622                      raise Error_Exit;
 623                end;
 624 
 625                --  Read line by line and put the content of each non-
 626                --  empty line in the Last_Switches table.
 627 
 628                while not End_Of_File (Arg_File) loop
 629                   Get_Line (Arg_File, Line, Last);
 630 
 631                   if Last /= 0 then
 632                      Last_Switches.Increment_Last;
 633                      Last_Switches.Table (Last_Switches.Last) :=
 634                        new String'(Line (1 .. Last));
 635                   end if;
 636                end loop;
 637 
 638                Close (Arg_File);
 639             end;
 640 
 641          else
 642             --  It is not an argument file; just put the argument in
 643             --  the Last_Switches table.
 644 
 645             Last_Switches.Increment_Last;
 646             Last_Switches.Table (Last_Switches.Last) := new String'(The_Arg);
 647          end if;
 648       end;
 649    end loop;
 650 
 651    declare
 652       Program    : String_Access;
 653       Exec_Path  : String_Access;
 654       Get_Target : Boolean := False;
 655 
 656    begin
 657       if The_Command = Stack then
 658 
 659          --  Never call gnatstack with a prefix
 660 
 661          Program := new String'(Command_List (The_Command).Unixcmd.all);
 662 
 663       else
 664          Program :=
 665            Program_Name (Command_List (The_Command).Unixcmd.all, "gnat");
 666 
 667          --  If we want to invoke gnatmake/gnatclean with -P, then check if
 668          --  gprbuild/gprclean is available; if it is, use gprbuild/gprclean
 669          --  instead of gnatmake/gnatclean.
 670          --  Ditto for gnatname -> gprname and gnatls -> gprls.
 671 
 672          if The_Command = Make
 673            or else The_Command = Compile
 674            or else The_Command = Bind
 675            or else The_Command = Link
 676            or else The_Command = Clean
 677            or else The_Command = Name
 678            or else The_Command = List
 679          then
 680             declare
 681                Switch            : String_Access;
 682                Dash_V_Switch     : constant String := "-V";
 683 
 684             begin
 685                for J in 1 .. Last_Switches.Last loop
 686                   Switch := Last_Switches.Table (J);
 687 
 688                   if The_Command = List and then Switch.all = Dash_V_Switch
 689                   then
 690                      Call_GPR_Tool := False;
 691                      exit;
 692                   end if;
 693 
 694                   if Switch'Length >= 2
 695                     and then Switch (Switch'First .. Switch'First + 1) = "-P"
 696                   then
 697                      Call_GPR_Tool := True;
 698                   end if;
 699                end loop;
 700 
 701                if Call_GPR_Tool then
 702                   case The_Command is
 703                      when Make | Compile | Bind | Link =>
 704                         if Locate_Exec_On_Path (Gprbuild) /= null then
 705                            Program    := new String'(Gprbuild);
 706                            Get_Target := True;
 707 
 708                            if The_Command = Bind then
 709                               First_Switches.Append (new String'("-b"));
 710                            elsif The_Command = Link then
 711                               First_Switches.Append (new String'("-l"));
 712                            end if;
 713 
 714                         elsif The_Command = Bind then
 715                            Fail
 716                              ("'gnat bind -P' is no longer supported;" &
 717                               " use 'gprbuild -b' instead.");
 718 
 719                         elsif The_Command = Link then
 720                            Fail
 721                              ("'gnat Link -P' is no longer supported;" &
 722                               " use 'gprbuild -l' instead.");
 723                         end if;
 724 
 725                      when Clean =>
 726                         if Locate_Exec_On_Path (Gprclean) /= null then
 727                            Program := new String'(Gprclean);
 728                            Get_Target := True;
 729                         end if;
 730 
 731                      when Name =>
 732                         if Locate_Exec_On_Path (Gprname) /= null then
 733                            Program := new String'(Gprname);
 734                            Get_Target := True;
 735                         end if;
 736 
 737                      when List =>
 738                         if Locate_Exec_On_Path (Gprls) /= null then
 739                            Program := new String'(Gprls);
 740                            Get_Target := True;
 741                         end if;
 742 
 743                      when others =>
 744                         null;
 745                   end case;
 746 
 747                   if Get_Target then
 748                      Find_Program_Name;
 749 
 750                      if Name_Len > 5 then
 751                         First_Switches.Append
 752                           (new String'
 753                              ("--target=" & Name_Buffer (1 .. Name_Len - 5)));
 754                      end if;
 755                   end if;
 756                end if;
 757             end;
 758          end if;
 759       end if;
 760 
 761       --  Locate the executable for the command
 762 
 763       Exec_Path := Locate_Exec_On_Path (Program.all);
 764 
 765       if Exec_Path = null then
 766          Put_Line (Standard_Error, "could not locate " & Program.all);
 767          raise Error_Exit;
 768       end if;
 769 
 770       --  If there are switches for the executable, put them as first switches
 771 
 772       if Command_List (The_Command).Unixsws /= null then
 773          for J in Command_List (The_Command).Unixsws'Range loop
 774             First_Switches.Increment_Last;
 775             First_Switches.Table (First_Switches.Last) :=
 776               Command_List (The_Command).Unixsws (J);
 777          end loop;
 778       end if;
 779 
 780       --  For FIND and XREF, look for switch -P. If it is specified, then
 781       --  report an error indicating that the command is no longer supporting
 782       --  project files.
 783 
 784       if The_Command = Find or else  The_Command = Xref then
 785          declare
 786             Argv    : String_Access;
 787          begin
 788             for Arg_Num in 1 .. Last_Switches.Last loop
 789                Argv := Last_Switches.Table (Arg_Num);
 790 
 791                if Argv'Length >= 2 and then
 792                   Argv (Argv'First .. Argv'First + 1) = "-P"
 793                then
 794                   if The_Command = Find then
 795                      Fail ("'gnat find -P' is no longer supported;");
 796                   else
 797                      Fail ("'gnat xref -P' is no longer supported;");
 798                   end if;
 799                end if;
 800             end loop;
 801          end;
 802       end if;
 803 
 804       if The_Command = List and then not Call_GPR_Tool then
 805          Tool_Package_Name := Name_Gnatls;
 806          Packages_To_Check := Packages_To_Check_By_Gnatls;
 807 
 808          --  Check that the switches are consistent. Detect project file
 809          --  related switches.
 810 
 811          Inspect_Switches : declare
 812             Arg_Num : Positive := 1;
 813             Argv    : String_Access;
 814 
 815             procedure Remove_Switch (Num : Positive);
 816             --  Remove a project related switch from table Last_Switches
 817 
 818             -------------------
 819             -- Remove_Switch --
 820             -------------------
 821 
 822             procedure Remove_Switch (Num : Positive) is
 823             begin
 824                Last_Switches.Table (Num .. Last_Switches.Last - 1) :=
 825                  Last_Switches.Table (Num + 1 .. Last_Switches.Last);
 826                Last_Switches.Decrement_Last;
 827             end Remove_Switch;
 828 
 829          --  Start of processing for Inspect_Switches
 830 
 831          begin
 832             while Arg_Num <= Last_Switches.Last loop
 833                Argv := Last_Switches.Table (Arg_Num);
 834 
 835                if Argv (Argv'First) = '-' then
 836                   if Argv'Length = 1 then
 837                      Fail ("switch character cannot be followed by a blank");
 838                   end if;
 839 
 840                   --  --subdirs=... Specify Subdirs
 841 
 842                   if Argv'Length > Makeutl.Subdirs_Option'Length
 843                     and then
 844                       Argv
 845                        (Argv'First ..
 846                         Argv'First + Makeutl.Subdirs_Option'Length - 1) =
 847                                                         Makeutl.Subdirs_Option
 848                   then
 849                      Subdirs :=
 850                        new String'
 851                          (Argv (Argv'First + Makeutl.Subdirs_Option'Length ..
 852                                 Argv'Last));
 853 
 854                      Remove_Switch (Arg_Num);
 855 
 856                   --  -aPdir  Add dir to the project search path
 857 
 858                   elsif Argv'Length > 3
 859                     and then Argv (Argv'First + 1 .. Argv'First + 2) = "aP"
 860                   then
 861                      Prj.Env.Add_Directories
 862                        (Root_Environment.Project_Path,
 863                         Argv (Argv'First + 3 .. Argv'Last));
 864 
 865                      --  Pass -aPdir to gnatls, but not to other tools
 866 
 867                      if The_Command = List then
 868                         Arg_Num := Arg_Num + 1;
 869                      else
 870                         Remove_Switch (Arg_Num);
 871                      end if;
 872 
 873                   --  -eL  Follow links for files
 874 
 875                   elsif Argv.all = "-eL" then
 876                      Follow_Links_For_Files := True;
 877                      Follow_Links_For_Dirs  := True;
 878 
 879                      Remove_Switch (Arg_Num);
 880 
 881                   --  -vPx  Specify verbosity while parsing project files
 882 
 883                   elsif Argv'Length >= 3
 884                     and then  Argv (Argv'First + 1 .. Argv'First + 2) = "vP"
 885                   then
 886                      if Argv'Length = 4
 887                        and then Argv (Argv'Last) in '0' .. '2'
 888                      then
 889                         case Argv (Argv'Last) is
 890                            when '0' =>
 891                               Current_Verbosity := Prj.Default;
 892                            when '1' =>
 893                               Current_Verbosity := Prj.Medium;
 894                            when '2' =>
 895                               Current_Verbosity := Prj.High;
 896                            when others =>
 897 
 898                               --  Cannot happen
 899 
 900                               raise Program_Error;
 901                         end case;
 902                      else
 903                         Fail ("invalid verbosity level: "
 904                               & Argv (Argv'First + 3 .. Argv'Last));
 905                      end if;
 906 
 907                      Remove_Switch (Arg_Num);
 908 
 909                   --  -Pproject_file  Specify project file to be used
 910 
 911                   elsif Argv (Argv'First + 1) = 'P' then
 912 
 913                      --  Only one -P switch can be used
 914 
 915                      if Project_File /= null then
 916                         Fail
 917                           (Argv.all
 918                            & ": second project file forbidden (first is """
 919                            & Project_File.all & """)");
 920 
 921                      elsif Argv'Length = 2 then
 922 
 923                         --  There is space between -P and the project file
 924                         --  name. -P cannot be the last option.
 925 
 926                         if Arg_Num = Last_Switches.Last then
 927                            Fail ("project file name missing after -P");
 928 
 929                         else
 930                            Remove_Switch (Arg_Num);
 931                            Argv := Last_Switches.Table (Arg_Num);
 932 
 933                            --  After -P, there must be a project file name,
 934                            --  not another switch.
 935 
 936                            if Argv (Argv'First) = '-' then
 937                               Fail ("project file name missing after -P");
 938 
 939                            else
 940                               Project_File := new String'(Argv.all);
 941                            end if;
 942                         end if;
 943 
 944                      else
 945                         --  No space between -P and project file name
 946 
 947                         Project_File :=
 948                           new String'(Argv (Argv'First + 2 .. Argv'Last));
 949                      end if;
 950 
 951                      Remove_Switch (Arg_Num);
 952 
 953                   --  -Xexternal=value Specify an external reference to be
 954                   --                   used in project files
 955 
 956                   elsif Argv'Length >= 5
 957                     and then Argv (Argv'First + 1) = 'X'
 958                   then
 959                      if not Check (Root_Environment.External,
 960                                     Argv (Argv'First + 2 .. Argv'Last))
 961                      then
 962                         Fail
 963                           (Argv.all & " is not a valid external assignment.");
 964                      end if;
 965 
 966                      Remove_Switch (Arg_Num);
 967 
 968                   --  --unchecked-shared-lib-imports
 969 
 970                   elsif Argv.all = "--unchecked-shared-lib-imports" then
 971                      Opt.Unchecked_Shared_Lib_Imports := True;
 972                      Remove_Switch (Arg_Num);
 973 
 974                   --  gnat list -U
 975 
 976                   elsif
 977                     The_Command = List
 978                     and then Argv'Length = 2
 979                     and then Argv (2) = 'U'
 980                   then
 981                      All_Projects := True;
 982                      Remove_Switch (Arg_Num);
 983 
 984                   else
 985                      Arg_Num := Arg_Num + 1;
 986                   end if;
 987 
 988                else
 989                   Arg_Num := Arg_Num + 1;
 990                end if;
 991             end loop;
 992          end Inspect_Switches;
 993       end if;
 994 
 995       --  Add the default project search directories now, after the directories
 996       --  that have been specified by switches -aP<dir>.
 997 
 998       Prj.Env.Initialize_Default_Project_Path
 999         (Root_Environment.Project_Path,
1000          Target_Name => Sdefault.Target_Name.all);
1001 
1002       --  If there is a project file specified, parse it, get the switches
1003       --  for the tool and setup PATH environment variables.
1004 
1005       if Project_File /= null then
1006          Prj.Pars.Set_Verbosity (To => Current_Verbosity);
1007 
1008          Prj.Pars.Parse
1009            (Project           => Project,
1010             In_Tree           => Project_Tree,
1011             In_Node_Tree      => Project_Node_Tree,
1012             Project_File_Name => Project_File.all,
1013             Env               => Root_Environment,
1014             Packages_To_Check => Packages_To_Check);
1015 
1016          --  Prj.Pars.Parse calls Set_Standard_Output, reset to stderr
1017 
1018          Set_Standard_Error;
1019 
1020          if Project = Prj.No_Project then
1021             Fail ("""" & Project_File.all & """ processing failed");
1022 
1023          elsif Project.Qualifier = Aggregate then
1024             Fail ("aggregate projects are not supported");
1025 
1026          elsif Aggregate_Libraries_In (Project_Tree) then
1027             Fail ("aggregate library projects are not supported");
1028          end if;
1029 
1030          --  Check if a package with the name of the tool is in the project
1031          --  file and if there is one, get the switches, if any, and scan them.
1032 
1033          declare
1034             Pkg : constant Prj.Package_Id :=
1035                     Prj.Util.Value_Of
1036                       (Name        => Tool_Package_Name,
1037                        In_Packages => Project.Decl.Packages,
1038                        Shared      => Project_Tree.Shared);
1039 
1040             Element : Package_Element;
1041 
1042             Switches_Array : Array_Element_Id;
1043 
1044             The_Switches : Prj.Variable_Value;
1045             Current      : Prj.String_List_Id;
1046             The_String   : String_Element;
1047 
1048             Main : String_Access := null;
1049 
1050          begin
1051             if Pkg /= No_Package then
1052                Element := Project_Tree.Shared.Packages.Table (Pkg);
1053 
1054                --  Package Gnatls has a single attribute Switches, that is not
1055                --  an associative array.
1056 
1057                if The_Command = List then
1058                   The_Switches :=
1059                     Prj.Util.Value_Of
1060                     (Variable_Name => Snames.Name_Switches,
1061                      In_Variables  => Element.Decl.Attributes,
1062                      Shared        => Project_Tree.Shared);
1063 
1064                --  Packages Binder (for gnatbind), Cross_Reference (for
1065                --  gnatxref), Linker (for gnatlink), Finder (for gnatfind),
1066                --  have an attributed Switches, an associative array, indexed
1067                --  by the name of the file.
1068 
1069                --  They also have an attribute Default_Switches, indexed by the
1070                --  name of the programming language.
1071 
1072                else
1073                   --  First check if there is a single main
1074 
1075                   for J in 1 .. Last_Switches.Last loop
1076                      if Last_Switches.Table (J) (1) /= '-' then
1077                         if Main = null then
1078                            Main := Last_Switches.Table (J);
1079                         else
1080                            Main := null;
1081                            exit;
1082                         end if;
1083                      end if;
1084                   end loop;
1085 
1086                   if Main /= null then
1087                      Switches_Array :=
1088                        Prj.Util.Value_Of
1089                          (Name      => Name_Switches,
1090                           In_Arrays => Element.Decl.Arrays,
1091                           Shared    => Project_Tree.Shared);
1092                      Name_Len := 0;
1093 
1094                      --  If the single main has been specified as an absolute
1095                      --  path, use only the simple file name. If the absolute
1096                      --  path is incorrect, an error will be reported by the
1097                      --  underlying tool and it does not make a difference
1098                      --  what switches are used.
1099 
1100                      if Is_Absolute_Path (Main.all) then
1101                         Add_Str_To_Name_Buffer (File_Name (Main.all));
1102                      else
1103                         Add_Str_To_Name_Buffer (Main.all);
1104                      end if;
1105 
1106                      The_Switches := Prj.Util.Value_Of
1107                        (Index     => Name_Find,
1108                         Src_Index => 0,
1109                         In_Array  => Switches_Array,
1110                         Shared    => Project_Tree.Shared);
1111                   end if;
1112 
1113                   if The_Switches.Kind = Prj.Undefined then
1114                      Switches_Array :=
1115                        Prj.Util.Value_Of
1116                          (Name      => Name_Default_Switches,
1117                           In_Arrays => Element.Decl.Arrays,
1118                           Shared    => Project_Tree.Shared);
1119                      The_Switches := Prj.Util.Value_Of
1120                        (Index     => Name_Ada,
1121                         Src_Index => 0,
1122                         In_Array  => Switches_Array,
1123                         Shared    => Project_Tree.Shared);
1124                   end if;
1125                end if;
1126 
1127                --  If there are switches specified in the package of the
1128                --  project file corresponding to the tool, scan them.
1129 
1130                case The_Switches.Kind is
1131                   when Prj.Undefined =>
1132                      null;
1133 
1134                   when Prj.Single =>
1135                      declare
1136                         Switch : constant String :=
1137                                    Get_Name_String (The_Switches.Value);
1138                      begin
1139                         if Switch'Length > 0 then
1140                            First_Switches.Increment_Last;
1141                            First_Switches.Table (First_Switches.Last) :=
1142                              new String'(Switch);
1143                         end if;
1144                      end;
1145 
1146                   when Prj.List =>
1147                      Current := The_Switches.Values;
1148                      while Current /= Prj.Nil_String loop
1149                         The_String := Project_Tree.Shared.String_Elements.
1150                                         Table (Current);
1151 
1152                         declare
1153                            Switch : constant String :=
1154                                       Get_Name_String (The_String.Value);
1155                         begin
1156                            if Switch'Length > 0 then
1157                               First_Switches.Increment_Last;
1158                               First_Switches.Table (First_Switches.Last) :=
1159                                 new String'(Switch);
1160                            end if;
1161                         end;
1162 
1163                         Current := The_String.Next;
1164                      end loop;
1165                end case;
1166             end if;
1167          end;
1168 
1169          if The_Command = Bind or else The_Command = Link then
1170             if Project.Object_Directory.Name = No_Path then
1171                Fail ("project " & Get_Name_String (Project.Display_Name)
1172                      & " has no object directory");
1173             end if;
1174 
1175             Change_Dir (Get_Name_String (Project.Object_Directory.Name));
1176          end if;
1177 
1178          --  Set up the env vars for project path files
1179 
1180          Prj.Env.Set_Ada_Paths
1181            (Project, Project_Tree, Including_Libraries => True);
1182 
1183          if The_Command = List then
1184             Check_Files;
1185          end if;
1186       end if;
1187 
1188       --  Gather all the arguments and invoke the executable
1189 
1190       declare
1191          The_Args : Argument_List
1192                       (1 .. First_Switches.Last + Last_Switches.Last);
1193          Arg_Num  : Natural := 0;
1194 
1195       begin
1196          for J in 1 .. First_Switches.Last loop
1197             Arg_Num := Arg_Num + 1;
1198             The_Args (Arg_Num) := First_Switches.Table (J);
1199          end loop;
1200 
1201          for J in 1 .. Last_Switches.Last loop
1202             Arg_Num := Arg_Num + 1;
1203             The_Args (Arg_Num) := Last_Switches.Table (J);
1204          end loop;
1205 
1206          if Verbose_Mode then
1207             Put (Exec_Path.all);
1208 
1209             for Arg in The_Args'Range loop
1210                Put (" " & The_Args (Arg).all);
1211             end loop;
1212 
1213             New_Line;
1214          end if;
1215 
1216          My_Exit_Status := Exit_Status (Spawn (Exec_Path.all, The_Args));
1217          Set_Exit_Status (My_Exit_Status);
1218       end;
1219    end;
1220 
1221 exception
1222    when Error_Exit =>
1223       Set_Exit_Status (Failure);
1224 end GNATCmd;