gcc/ada/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-2005 Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
  28
  29 with Csets;
  30 with MLib.Tgt; use MLib.Tgt;
  31 with MLib.Utl;
  32 with Namet;    use Namet;
  33 with Opt;      use Opt;
  34 with Osint;    use Osint;
  35 with Output;
  36 with Prj;      use Prj;
  37 with Prj.Env;
  38 with Prj.Ext;  use Prj.Ext;
  39 with Prj.Pars;
  40 with Prj.Util; use Prj.Util;
  41 with Sinput.P;
  42 with Snames;   use Snames;
  43 with Table;
  44 with Types;    use Types;
  45 with Hostparm; use Hostparm;
  46 --  Used to determine if we are in VMS or not for error message purposes
  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.OS_Lib;             use GNAT.OS_Lib;
  53
  54 with Table;
  55
  56 with VMS_Conv; use VMS_Conv;
  57
  58 procedure GNATCmd is
  59    Project_Tree      : constant Project_Tree_Ref := new Project_Tree_Data;
  60    Project_File      : String_Access;
  61    Project           : Prj.Project_Id;
  62    Current_Verbosity : Prj.Verbosity := Prj.Default;
  63    Tool_Package_Name : Name_Id       := No_Name;
  64
  65    Old_Project_File_Used : Boolean := False;
  66    --  This flag indicates a switch -p (for gnatxref and gnatfind) for
  67    --  an old fashioned project file. -p cannot be used in conjonction
  68    --  with -P.
  69
  70    Max_Files_On_The_Command_Line : constant := 30; --  Arbitrary
  71
  72    Temp_File_Name : String_Access := null;
  73    --  The name of the temporary text file to put a list of source/object
  74    --  files to pass to a tool, when there are more than
  75    --  Max_Files_On_The_Command_Line files.
  76
  77    package First_Switches is new Table.Table
  78      (Table_Component_Type => String_Access,
  79       Table_Index_Type     => Integer,
  80       Table_Low_Bound      => 1,
  81       Table_Initial        => 20,
  82       Table_Increment      => 100,
  83       Table_Name           => "Gnatcmd.First_Switches");
  84    --  A table to keep the switches from the project file
  85
  86    package Carg_Switches is new Table.Table
  87      (Table_Component_Type => String_Access,
  88       Table_Index_Type     => Integer,
  89       Table_Low_Bound      => 1,
  90       Table_Initial        => 20,
  91       Table_Increment      => 100,
  92       Table_Name           => "Gnatcmd.Carg_Switches");
  93    --  A table to keep the switches following -cargs for ASIS tools
  94
  95    package Library_Paths is new Table.Table (
  96      Table_Component_Type => String_Access,
  97      Table_Index_Type     => Integer,
  98      Table_Low_Bound      => 1,
  99      Table_Initial        => 20,
 100      Table_Increment      => 100,
 101      Table_Name           => "Make.Library_Path");
 102
 103    --  Packages of project files to pass to Prj.Pars.Parse, depending on the
 104    --  tool. We allocate objects because we cannot declare aliased objects
 105    --  as we are in a procedure, not a library level package.
 106
 107    Naming_String    : constant String_Access := new String'("naming");
 108    Binder_String    : constant String_Access := new String'("binder");
 109    Eliminate_String : constant String_Access := new String'("eliminate");
 110    Finder_String    : constant String_Access := new String'("finder");
 111    Linker_String    : constant String_Access := new String'("linker");
 112    Gnatls_String    : constant String_Access := new String'("gnatls");
 113    Pretty_String    : constant String_Access := new String'("pretty_printer");
 114    Gnatstub_String  : constant String_Access := new String'("gnatstub");
 115    Metric_String    : constant String_Access := new String'("metrics");
 116    Xref_String      : constant String_Access := new String'("cross_reference");
 117
 118    Packages_To_Check_By_Binder   : constant String_List_Access :=
 119      new String_List'((Naming_String, Binder_String));
 120
 121    Packages_To_Check_By_Eliminate : constant String_List_Access :=
 122      new String_List'((Naming_String, Eliminate_String));
 123
 124    Packages_To_Check_By_Finder    : constant String_List_Access :=
 125      new String_List'((Naming_String, Finder_String));
 126
 127    Packages_To_Check_By_Linker    : constant String_List_Access :=
 128      new String_List'((Naming_String, Linker_String));
 129
 130    Packages_To_Check_By_Gnatls    : constant String_List_Access :=
 131      new String_List'((Naming_String, Gnatls_String));
 132
 133    Packages_To_Check_By_Pretty    : constant String_List_Access :=
 134      new String_List'((Naming_String, Pretty_String));
 135
 136    Packages_To_Check_By_Gnatstub  : constant String_List_Access :=
 137      new String_List'((Naming_String, Gnatstub_String));
 138
 139    Packages_To_Check_By_Metric  : constant String_List_Access :=
 140      new String_List'((Naming_String, Metric_String));
 141
 142    Packages_To_Check_By_Xref      : constant String_List_Access :=
 143      new String_List'((Naming_String, Xref_String));
 144
 145    Packages_To_Check : String_List_Access := Prj.All_Packages;
 146
 147    ----------------------------------
 148    -- Declarations for GNATCMD use --
 149    ----------------------------------
 150
 151    The_Command : Command_Type;
 152
 153    Command_Arg : Positive := 1;
 154
 155    My_Exit_Status : Exit_Status := Success;
 156
 157    Current_Work_Dir : constant String := Get_Current_Dir;
 158
 159    -----------------------
 160    -- Local Subprograms --
 161    -----------------------
 162
 163    procedure Add_To_Carg_Switches (Switch : String_Access);
 164    --  Add a switch to the Carg_Switches table. If it is the first one,
 165    --  put the switch "-cargs" at the beginning of the table.
 166
 167    procedure Check_Files;
 168    --  For GNAT LIST, GNAT PRETTY and GNAT METRIC, check if a project
 169    --  file is specified, without any file arguments. If it is the case,
 170    --  invoke the GNAT tool with the proper list of files, derived from
 171    --  the sources of the project.
 172
 173    function Check_Project
 174      (Project      : Project_Id;
 175       Root_Project : Project_Id) return Boolean;
 176    --  Returns True if Project = Root_Project.
 177    --  For GNAT METRIC, also returns True if Project is extended by
 178    --  Root_Project.
 179
 180    procedure Check_Relative_Executable (Name : in out String_Access);
 181    --  Check if an executable is specified as a relative path.
 182    --  If it is, and the path contains directory information, fail.
 183    --  Otherwise, prepend the exec directory.
 184    --  This procedure is only used for GNAT LINK when a project file
 185    --  is specified.
 186
 187    function Configuration_Pragmas_File return Name_Id;
 188    --  Return an argument, if there is a configuration pragmas file to be
 189    --  specified for Project, otherwise return No_Name.
 190    --  Used for gnatstub (GNAT STUB), gnatpp (GNAT PRETTY), gnatelim
 191    --  (GNAT ELIM), and gnatmetric (GNAT METRIC).
 192
 193    procedure Delete_Temp_Config_Files;
 194    --  Delete all temporary config files
 195
 196    function Index (Char : Character; Str : String) return Natural;
 197    --  Returns the first occurrence of Char in Str.
 198    --  Returns 0 if Char is not in Str.
 199
 200    procedure Non_VMS_Usage;
 201    --  Display usage for platforms other than VMS
 202
 203    procedure Process_Link;
 204    --  Process GNAT LINK, when there is a project file specified.
 205
 206    procedure Set_Library_For
 207      (Project             : Project_Id;
 208       There_Are_Libraries : in out Boolean);
 209    --  If Project is a library project, add the correct
 210    --  -L and -l switches to the linker invocation.
 211
 212    procedure Set_Libraries is
 213       new For_Every_Project_Imported (Boolean, Set_Library_For);
 214    --  Add the -L and -l switches to the linker for all
 215    --  of the library projects.
 216
 217    procedure Test_If_Relative_Path
 218      (Switch : in out String_Access;
 219       Parent : String);
 220    --  Test if Switch is a relative search path switch.
 221    --  If it is and it includes directory information, prepend the path with
 222    --  Parent.This subprogram is only called when using project files.
 223
 224    --------------------------
 225    -- Add_To_Carg_Switches --
 226    --------------------------
 227
 228    procedure Add_To_Carg_Switches (Switch : String_Access) is
 229    begin
 230       --  If the Carg_Switches table is empty, put "-cargs" at the beginning
 231
 232       if Carg_Switches.Last = 0 then
 233          Carg_Switches.Increment_Last;
 234          Carg_Switches.Table (Carg_Switches.Last) := new String'("-cargs");
 235       end if;
 236
 237       Carg_Switches.Increment_Last;
 238       Carg_Switches.Table (Carg_Switches.Last) := Switch;
 239    end Add_To_Carg_Switches;
 240
 241    -----------------
 242    -- Check_Files --
 243    -----------------
 244
 245    procedure Check_Files is
 246       Add_Sources : Boolean := True;
 247       Unit_Data   : Prj.Unit_Data;
 248       Subunit     : Boolean := False;
 249
 250    begin
 251       --  Check if there is at least one argument that is not a switch
 252
 253       for Index in 1 .. Last_Switches.Last loop
 254          if Last_Switches.Table (Index) (1) /= '-' then
 255             Add_Sources := False;
 256             exit;
 257          end if;
 258       end loop;
 259
 260       --  If all arguments were switches, add the path names of
 261       --  all the sources of the main project.
 262
 263       if Add_Sources then
 264          declare
 265             Current_Last : constant Integer := Last_Switches.Last;
 266          begin
 267             for Unit in Unit_Table.First ..
 268                         Unit_Table.Last (Project_Tree.Units)
 269             loop
 270                Unit_Data := Project_Tree.Units.Table (Unit);
 271
 272                --  For gnatls, we only need to put the library units,
 273                --  body or spec, but not the subunits.
 274
 275                if The_Command = List then
 276                   if
 277                     Unit_Data.File_Names (Body_Part).Name /= No_Name
 278                   then
 279                      --  There is a body; check if it is for this
 280                      --  project.
 281
 282                      if Unit_Data.File_Names (Body_Part).Project =
 283                        Project
 284                      then
 285                         Subunit := False;
 286
 287                         if Unit_Data.File_Names (Specification).Name =
 288                           No_Name
 289                         then
 290                            --  We have a body with no spec: we need
 291                            --  to check if this is a subunit, because
 292                            --  gnatls will complain about subunits.
 293
 294                            declare
 295                               Src_Ind : Source_File_Index;
 296
 297                            begin
 298                               Src_Ind := Sinput.P.Load_Project_File
 299                                 (Get_Name_String
 300                                    (Unit_Data.File_Names
 301                                       (Body_Part).Path));
 302
 303                               Subunit :=
 304                                 Sinput.P.Source_File_Is_Subunit
 305                                   (Src_Ind);
 306                            end;
 307                         end if;
 308
 309                         if not Subunit then
 310                            Last_Switches.Increment_Last;
 311                            Last_Switches.Table (Last_Switches.Last) :=
 312                              new String'
 313                                (Get_Name_String
 314                                     (Unit_Data.File_Names
 315                                          (Body_Part).Display_Name));
 316                         end if;
 317                      end if;
 318
 319                   elsif Unit_Data.File_Names (Specification).Name /=
 320                     No_Name
 321                   then
 322                      --  We have a spec with no body; check if it is
 323                      --  for this project.
 324
 325                      if Unit_Data.File_Names (Specification).Project =
 326                        Project
 327                      then
 328                         Last_Switches.Increment_Last;
 329                         Last_Switches.Table (Last_Switches.Last) :=
 330                           new String'
 331                             (Get_Name_String
 332                                  (Unit_Data.File_Names
 333                                       (Specification).Display_Name));
 334                      end if;
 335                   end if;
 336
 337                else
 338                   --  For gnatpp and gnatmetric, put all sources
 339                   --  of the project.
 340
 341                   for Kind in Spec_Or_Body loop
 342
 343                      --  Put only sources that belong to the main
 344                      --  project.
 345
 346                      if Check_Project
 347                           (Unit_Data.File_Names (Kind).Project, Project)
 348                      then
 349                         Last_Switches.Increment_Last;
 350                         Last_Switches.Table (Last_Switches.Last) :=
 351                           new String'
 352                             (Get_Name_String
 353                                  (Unit_Data.File_Names
 354                                       (Kind).Display_Path));
 355                      end if;
 356                   end loop;
 357                end if;
 358             end loop;
 359
 360             --  If the list of files is too long, create a temporary
 361             --  text file that lists these files, and pass this temp
 362             --  file to gnatpp or gnatmetric using switch -files=.
 363
 364             if Last_Switches.Last - Current_Last >
 365               Max_Files_On_The_Command_Line
 366             then
 367                declare
 368                   Temp_File_FD : File_Descriptor;
 369                   Buffer       : String (1 .. 1_000);
 370                   Len          : Natural;
 371                   OK           : Boolean := True;
 372
 373                begin
 374                   Create_Temp_File (Temp_File_FD, Temp_File_Name);
 375
 376                   if Temp_File_Name /= null then
 377                      for Index in Current_Last + 1 ..
 378                        Last_Switches.Last
 379                      loop
 380                         Len := Last_Switches.Table (Index)'Length;
 381                         Buffer (1 .. Len) :=
 382                           Last_Switches.Table (Index).all;
 383                         Len := Len + 1;
 384                         Buffer (Len) := ASCII.LF;
 385                         Buffer (Len + 1) := ASCII.NUL;
 386                         OK :=
 387                           Write (Temp_File_FD,
 388                                  Buffer (1)'Address,
 389                                  Len) = Len;
 390                         exit when not OK;
 391                      end loop;
 392
 393                      if OK then
 394                         Close (Temp_File_FD, OK);
 395                      else
 396                         Close (Temp_File_FD, OK);
 397                         OK := False;
 398                      end if;
 399
 400                      --  If there were any problem creating the temp
 401                      --  file, then pass the list of files.
 402
 403                      if OK then
 404
 405                         --  Replace the list of files with
 406                         --  "-files=<temp file name>".
 407
 408                         Last_Switches.Set_Last (Current_Last + 1);
 409                         Last_Switches.Table (Last_Switches.Last) :=
 410                           new String'("-files=" & Temp_File_Name.all);
 411                      end if;
 412                   end if;
 413                end;
 414             end if;
 415          end;
 416       end if;
 417    end Check_Files;
 418
 419    -------------------
 420    -- Check_Project --
 421    -------------------
 422
 423    function Check_Project
 424      (Project      : Project_Id;
 425       Root_Project : Project_Id) return Boolean
 426    is
 427    begin
 428       if Project = Root_Project then
 429          return True;
 430
 431       elsif The_Command = Metric then
 432          declare
 433             Data : Project_Data :=
 434                      Project_Tree.Projects.Table (Root_Project);
 435
 436          begin
 437             while Data.Extends /= No_Project loop
 438                if Project = Data.Extends then
 439                   return True;
 440                end if;
 441
 442                Data := Project_Tree.Projects.Table (Data.Extends);
 443             end loop;
 444          end;
 445       end if;
 446
 447       return False;
 448    end Check_Project;
 449
 450    -------------------------------
 451    -- Check_Relative_Executable --
 452    -------------------------------
 453
 454    procedure Check_Relative_Executable (Name : in out String_Access) is
 455       Exec_File_Name : constant String := Name.all;
 456
 457    begin
 458       if not Is_Absolute_Path (Exec_File_Name) then
 459          for Index in Exec_File_Name'Range loop
 460             if Exec_File_Name (Index) = Directory_Separator then
 461                Fail ("relative executable (""" &
 462                        Exec_File_Name &
 463                        """) with directory part not allowed " &
 464                        "when using project files");
 465             end if;
 466          end loop;
 467
 468          Get_Name_String (Project_Tree.Projects.Table
 469                             (Project).Exec_Directory);
 470
 471          if Name_Buffer (Name_Len) /= Directory_Separator then
 472             Name_Len := Name_Len + 1;
 473             Name_Buffer (Name_Len) := Directory_Separator;
 474          end if;
 475
 476          Name_Buffer (Name_Len + 1 ..
 477                         Name_Len + Exec_File_Name'Length) :=
 478            Exec_File_Name;
 479          Name_Len := Name_Len + Exec_File_Name'Length;
 480          Name := new String'(Name_Buffer (1 .. Name_Len));
 481       end if;
 482    end Check_Relative_Executable;
 483
 484    --------------------------------
 485    -- Configuration_Pragmas_File --
 486    --------------------------------
 487
 488    function Configuration_Pragmas_File return Name_Id is
 489    begin
 490       Prj.Env.Create_Config_Pragmas_File
 491         (Project, Project, Project_Tree, Include_Config_Files => False);
 492       return Project_Tree.Projects.Table (Project).Config_File_Name;
 493    end Configuration_Pragmas_File;
 494
 495    ------------------------------
 496    -- Delete_Temp_Config_Files --
 497    ------------------------------
 498
 499    procedure Delete_Temp_Config_Files is
 500       Success : Boolean;
 501
 502    begin
 503       if not Keep_Temporary_Files then
 504          if Project /= No_Project then
 505             for Prj in Project_Table.First ..
 506                        Project_Table.Last (Project_Tree.Projects)
 507             loop
 508                if
 509                  Project_Tree.Projects.Table (Prj).Config_File_Temp
 510                then
 511                   if Verbose_Mode then
 512                      Output.Write_Str ("Deleting temp configuration file """);
 513                      Output.Write_Str
 514                        (Get_Name_String
 515                           (Project_Tree.Projects.Table
 516                              (Prj).Config_File_Name));
 517                      Output.Write_Line ("""");
 518                   end if;
 519
 520                   Delete_File
 521                     (Name    => Get_Name_String
 522                        (Project_Tree.Projects.Table
 523                           (Prj).Config_File_Name),
 524                      Success => Success);
 525                end if;
 526             end loop;
 527          end if;
 528
 529          --  If a temporary text file that contains a list of files for a tool
 530          --  has been created, delete this temporary file.
 531
 532          if Temp_File_Name /= null then
 533             Delete_File (Temp_File_Name.all, Success);
 534          end if;
 535       end if;
 536    end Delete_Temp_Config_Files;
 537
 538    -----------
 539    -- Index --
 540    -----------
 541
 542    function Index (Char : Character; Str : String) return Natural is
 543    begin
 544       for Index in Str'Range loop
 545          if Str (Index) = Char then
 546             return Index;
 547          end if;
 548       end loop;
 549
 550       return 0;
 551    end Index;
 552
 553    ------------------
 554    -- Process_Link --
 555    ------------------
 556
 557    procedure Process_Link is
 558       Look_For_Executable  : Boolean := True;
 559       There_Are_Libraries  : Boolean := False;
 560       Path_Option          : constant String_Access :=
 561                                MLib.Linker_Library_Path_Option;
 562       Prj                  : Project_Id := Project;
 563       Arg                  : String_Access;
 564       Last                 : Natural := 0;
 565       Skip_Executable      : Boolean := False;
 566
 567    begin
 568       --  Add the default search directories, to be able to find
 569       --  libgnat in call to MLib.Utl.Lib_Directory.
 570
 571       Add_Default_Search_Dirs;
 572
 573       Library_Paths.Set_Last (0);
 574
 575       --  Check if there are library project files
 576
 577       if MLib.Tgt.Support_For_Libraries /= MLib.Tgt.None then
 578          Set_Libraries (Project, Project_Tree, There_Are_Libraries);
 579       end if;
 580
 581       --  If there are, add the necessary additional switches
 582
 583       if There_Are_Libraries then
 584
 585          --  Add -L<lib_dir> -lgnarl -lgnat -Wl,-rpath,<lib_dir>
 586
 587          Last_Switches.Increment_Last;
 588          Last_Switches.Table (Last_Switches.Last) :=
 589            new String'("-L" & MLib.Utl.Lib_Directory);
 590          Last_Switches.Increment_Last;
 591          Last_Switches.Table (Last_Switches.Last) :=
 592            new String'("-lgnarl");
 593          Last_Switches.Increment_Last;
 594          Last_Switches.Table (Last_Switches.Last) :=
 595            new String'("-lgnat");
 596
 597          --  If Path_Option is not null, create the switch
 598          --  ("-Wl,-rpath," or equivalent) with all the library dirs
 599          --  plus the standard GNAT library dir.
 600
 601          if Path_Option /= null then
 602             declare
 603                Option  : String_Access;
 604                Length  : Natural := Path_Option'Length;
 605                Current : Natural;
 606
 607             begin
 608                --  First, compute the exact length for the switch
 609
 610                for Index in
 611                  Library_Paths.First .. Library_Paths.Last
 612                loop
 613                   --  Add the length of the library dir plus one
 614                   --  for the directory separator.
 615
 616                   Length :=
 617                     Length +
 618                       Library_Paths.Table (Index)'Length + 1;
 619                end loop;
 620
 621                --  Finally, add the length of the standard GNAT
 622                --  library dir.
 623
 624                Length := Length + MLib.Utl.Lib_Directory'Length;
 625                Option := new String (1 .. Length);
 626                Option (1 .. Path_Option'Length) := Path_Option.all;
 627                Current := Path_Option'Length;
 628
 629                --  Put each library dir followed by a dir separator
 630
 631                for Index in
 632                  Library_Paths.First .. Library_Paths.Last
 633                loop
 634                   Option
 635                     (Current + 1 ..
 636                        Current +
 637                          Library_Paths.Table (Index)'Length) :=
 638                       Library_Paths.Table (Index).all;
 639                   Current :=
 640                     Current +
 641                       Library_Paths.Table (Index)'Length + 1;
 642                   Option (Current) := Path_Separator;
 643                end loop;
 644
 645                --  Finally put the standard GNAT library dir
 646
 647                Option
 648                  (Current + 1 ..
 649                     Current + MLib.Utl.Lib_Directory'Length) :=
 650                    MLib.Utl.Lib_Directory;
 651
 652                --  And add the switch to the last switches
 653
 654                Last_Switches.Increment_Last;
 655                Last_Switches.Table (Last_Switches.Last) :=
 656                  Option;
 657             end;
 658          end if;
 659       end if;
 660
 661       --  Check if the first ALI file specified can be found, either
 662       --  in the object directory of the main project or in an object
 663       --  directory of a project file extended by the main project.
 664       --  If the ALI file can be found, replace its name with its
 665       --  absolute path.
 666
 667       Skip_Executable := False;
 668
 669       Switch_Loop : for J in 1 .. Last_Switches.Last loop
 670
 671          --  If we have an executable just reset the flag
 672
 673          if Skip_Executable then
 674             Skip_Executable := False;
 675
 676          --  If -o, set flag so that next switch is not processed
 677
 678          elsif Last_Switches.Table (J).all = "-o" then
 679             Skip_Executable := True;
 680
 681          --  Normal case
 682
 683          else
 684             declare
 685                Switch         : constant String :=
 686                                   Last_Switches.Table (J).all;
 687
 688                ALI_File       : constant String (1 .. Switch'Length + 4) :=
 689                                   Switch & ".ali";
 690
 691                Test_Existence : Boolean := False;
 692
 693             begin
 694                Last := Switch'Length;
 695
 696                --  Skip real switches
 697
 698                if Switch'Length /= 0
 699                  and then Switch (Switch'First) /= '-'
 700                then
 701                   --  Append ".ali" if file name does not end with it
 702
 703                   if Switch'Length <= 4
 704                     or else Switch (Switch'Last - 3 .. Switch'Last)
 705                     /= ".ali"
 706                   then
 707                      Last := ALI_File'Last;
 708                   end if;
 709
 710                   --  If file name includes directory information,
 711                   --  stop if ALI file exists.
 712
 713                   if Is_Absolute_Path (ALI_File (1 .. Last)) then
 714                      Test_Existence := True;
 715
 716                   else
 717                      for K in Switch'Range loop
 718                         if Switch (K) = '/' or else
 719                           Switch (K) = Directory_Separator
 720                         then
 721                            Test_Existence := True;
 722                            exit;
 723                         end if;
 724                      end loop;
 725                   end if;
 726
 727                   if Test_Existence then
 728                      if Is_Regular_File (ALI_File (1 .. Last)) then
 729                         exit Switch_Loop;
 730                      end if;
 731
 732                   --  Look in object directories if ALI file exists
 733
 734                   else
 735                      Project_Loop : loop
 736                         declare
 737                            Dir : constant String :=
 738                                    Get_Name_String
 739                                      (Project_Tree.Projects.Table
 740                                         (Prj).Object_Directory);
 741                         begin
 742                            if Is_Regular_File
 743                                 (Dir &
 744                                  Directory_Separator &
 745                                  ALI_File (1 .. Last))
 746                            then
 747                               --  We have found the correct project, so we
 748                               --  replace the file with the absolute path.
 749
 750                               Last_Switches.Table (J) :=
 751                                 new String'
 752                                   (Dir & Directory_Separator &
 753                                    ALI_File (1 .. Last));
 754
 755                               --  And we are done
 756
 757                               exit Switch_Loop;
 758                            end if;
 759                         end;
 760
 761                         --  Go to the project being extended,
 762                         --  if any.
 763
 764                         Prj :=
 765                           Project_Tree.Projects.Table (Prj).Extends;
 766                         exit Project_Loop when Prj = No_Project;
 767                      end loop Project_Loop;
 768                   end if;
 769                end if;
 770             end;
 771          end if;
 772       end loop Switch_Loop;
 773
 774       --  If a relative path output file has been specified, we add
 775       --  the exec directory.
 776
 777       for J in reverse 1 .. Last_Switches.Last - 1 loop
 778          if Last_Switches.Table (J).all = "-o" then
 779             Check_Relative_Executable
 780               (Name => Last_Switches.Table (J + 1));
 781             Look_For_Executable := False;
 782             exit;
 783          end if;
 784       end loop;
 785
 786       if Look_For_Executable then
 787          for J in reverse 1 .. First_Switches.Last - 1 loop
 788             if First_Switches.Table (J).all = "-o" then
 789                Look_For_Executable := False;
 790                Check_Relative_Executable
 791                  (Name => First_Switches.Table (J + 1));
 792                exit;
 793             end if;
 794          end loop;
 795       end if;
 796
 797       --  If no executable is specified, then find the name
 798       --  of the first ALI file on the command line and issue
 799       --  a -o switch with the absolute path of the executable
 800       --  in the exec directory.
 801
 802       if Look_For_Executable then
 803          for J in 1 .. Last_Switches.Last loop
 804             Arg  := Last_Switches.Table (J);
 805             Last := 0;
 806
 807             if Arg'Length /= 0 and then Arg (Arg'First) /= '-' then
 808                if Arg'Length > 4
 809                  and then Arg (Arg'Last - 3 .. Arg'Last) = ".ali"
 810                then
 811                   Last := Arg'Last - 4;
 812
 813                elsif Is_Regular_File (Arg.all & ".ali") then
 814                   Last := Arg'Last;
 815                end if;
 816
 817                if Last /= 0 then
 818                   Last_Switches.Increment_Last;
 819                   Last_Switches.Table (Last_Switches.Last) :=
 820                     new String'("-o");
 821                   Get_Name_String
 822                     (Project_Tree.Projects.Table
 823                        (Project).Exec_Directory);
 824                   Last_Switches.Increment_Last;
 825                   Last_Switches.Table (Last_Switches.Last) :=
 826                     new String'(Name_Buffer (1 .. Name_Len) &
 827                                 Directory_Separator &
 828                                 Base_Name (Arg (Arg'First .. Last)) &
 829                                 Get_Executable_Suffix.all);
 830                   exit;
 831                end if;
 832             end if;
 833          end loop;
 834       end if;
 835    end Process_Link;
 836
 837    ---------------------
 838    -- Set_Library_For --
 839    ---------------------
 840
 841    procedure Set_Library_For
 842      (Project             : Project_Id;
 843       There_Are_Libraries : in out Boolean)
 844    is
 845       Path_Option : constant String_Access :=
 846                       MLib.Linker_Library_Path_Option;
 847
 848    begin
 849       --  Case of library project
 850
 851       if Project_Tree.Projects.Table (Project).Library then
 852          There_Are_Libraries := True;
 853
 854          --  Add the -L switch
 855
 856          Last_Switches.Increment_Last;
 857          Last_Switches.Table (Last_Switches.Last) :=
 858            new String'("-L" &
 859                        Get_Name_String
 860                          (Project_Tree.Projects.Table
 861                             (Project).Library_Dir));
 862
 863          --  Add the -l switch
 864
 865          Last_Switches.Increment_Last;
 866          Last_Switches.Table (Last_Switches.Last) :=
 867            new String'("-l" &
 868                        Get_Name_String
 869                          (Project_Tree.Projects.Table
 870                             (Project).Library_Name));
 871
 872          --  Add the directory to table Library_Paths, to be processed later
 873          --  if library is not static and if Path_Option is not null.
 874
 875          if Project_Tree.Projects.Table (Project).Library_Kind /=
 876               Static
 877            and then Path_Option /= null
 878          then
 879             Library_Paths.Increment_Last;
 880             Library_Paths.Table (Library_Paths.Last) :=
 881               new String'(Get_Name_String
 882                             (Project_Tree.Projects.Table
 883                                (Project).Library_Dir));
 884          end if;
 885       end if;
 886    end Set_Library_For;
 887
 888    ---------------------------
 889    -- Test_If_Relative_Path --
 890    ---------------------------
 891
 892    procedure Test_If_Relative_Path
 893      (Switch : in out String_Access;
 894       Parent : String)
 895    is
 896    begin
 897       if Switch /= null then
 898
 899          declare
 900             Sw : String (1 .. Switch'Length);
 901             Start : Positive := 1;
 902
 903          begin
 904             Sw := Switch.all;
 905
 906             if Sw (1) = '-' then
 907                if Sw'Length >= 3
 908                  and then (Sw (2) = 'A' or else
 909                            Sw (2) = 'I' or else
 910                            Sw (2) = 'L')
 911                then
 912                   Start := 3;
 913
 914                   if Sw = "-I-" then
 915                      return;
 916                   end if;
 917
 918                elsif Sw'Length >= 4
 919                  and then (Sw (2 .. 3) = "aL" or else
 920                            Sw (2 .. 3) = "aO" or else
 921                            Sw (2 .. 3) = "aI")
 922                then
 923                   Start := 4;
 924
 925                elsif Sw'Length >= 7
 926                  and then Sw (2 .. 6) = "-RTS="
 927                then
 928                   Start := 7;
 929                else
 930                   return;
 931                end if;
 932             end if;
 933
 934             --  If the path is relative, test if it includes directory
 935             --  information. If it does, prepend Parent to the path.
 936
 937             if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then
 938                for J in Start .. Sw'Last loop
 939                   if Sw (J) = Directory_Separator then
 940                      Switch :=
 941                         new String'
 942                               (Sw (1 .. Start - 1) &
 943                                Parent &
 944                                Directory_Separator &
 945                                Sw (Start .. Sw'Last));
 946                      return;
 947                   end if;
 948                end loop;
 949             end if;
 950          end;
 951       end if;
 952    end Test_If_Relative_Path;
 953
 954    -------------------
 955    -- Non_VMS_Usage --
 956    -------------------
 957
 958    procedure Non_VMS_Usage is
 959    begin
 960       Output_Version;
 961       New_Line;
 962       Put_Line ("List of available commands");
 963       New_Line;
 964
 965       for C in Command_List'Range loop
 966          if not Command_List (C).VMS_Only then
 967             Put ("gnat " & To_Lower (Command_List (C).Cname.all));
 968             Set_Col (25);
 969             Put (Command_List (C).Unixcmd.all);
 970
 971             declare
 972                Sws : Argument_List_Access renames Command_List (C).Unixsws;
 973             begin
 974                if Sws /= null then
 975                   for J in Sws'Range loop
 976                      Put (' ');
 977                      Put (Sws (J).all);
 978                   end loop;
 979                end if;
 980             end;
 981
 982             New_Line;
 983          end if;
 984       end loop;
 985
 986       New_Line;
 987       Put_Line ("Commands find, list, metric, pretty, stub and xref accept " &
 988                 "project file switches -vPx, -Pprj and -Xnam=val");
 989       New_Line;
 990    end Non_VMS_Usage;
 991
 992    -------------------------------------
 993    -- Start of processing for GNATCmd --
 994    -------------------------------------
 995
 996 begin
 997    --  Initializations
 998
 999    Namet.Initialize;
1000    Csets.Initialize;
1001
1002    Snames.Initialize;
1003
1004    Prj.Initialize (Project_Tree);
1005
1006    Last_Switches.Init;
1007    Last_Switches.Set_Last (0);
1008
1009    First_Switches.Init;
1010    First_Switches.Set_Last (0);
1011    Carg_Switches.Init;
1012    Carg_Switches.Set_Last (0);
1013
1014    VMS_Conv.Initialize;
1015
1016    --  Add the directory where the GNAT driver is invoked in front of the
1017    --  path, if the GNAT driver is invoked with directory information.
1018    --  Only do this if the platform is not VMS, where the notion of path
1019    --  does not really exist.
1020
1021    if not OpenVMS then
1022       declare
1023          Command : constant String := Command_Name;
1024
1025       begin
1026          for Index in reverse Command'Range loop
1027             if Command (Index) = Directory_Separator then
1028                declare
1029                   Absolute_Dir : constant String :=
1030                                    Normalize_Pathname
1031                                      (Command (Command'First .. Index));
1032
1033                   PATH         : constant String :=
1034                                    Absolute_Dir &
1035                   Path_Separator &
1036                   Getenv ("PATH").all;
1037
1038                begin
1039                   Setenv ("PATH", PATH);
1040                end;
1041
1042                exit;
1043             end if;
1044          end loop;
1045       end;
1046    end if;
1047
1048    --  If on VMS, or if VMS emulation is on, convert VMS style /qualifiers,
1049    --  filenames and pathnames to Unix style.
1050
1051    if Hostparm.OpenVMS
1052      or else To_Lower (Getenv ("EMULATE_VMS").all) = "true"
1053    then
1054       VMS_Conversion (The_Command);
1055
1056    --  If not on VMS, scan the command line directly
1057
1058    else
1059       if Argument_Count = 0 then
1060          Non_VMS_Usage;
1061          return;
1062       else
1063          begin
1064             loop
1065                if Argument_Count > Command_Arg
1066                  and then Argument (Command_Arg) = "-v"
1067                then
1068                   Verbose_Mode := True;
1069                   Command_Arg := Command_Arg + 1;
1070
1071                elsif Argument_Count > Command_Arg
1072                  and then Argument (Command_Arg) = "-dn"
1073                then
1074                   Keep_Temporary_Files := True;
1075                   Command_Arg := Command_Arg + 1;
1076
1077                else
1078                   exit;
1079                end if;
1080             end loop;
1081
1082             The_Command := Real_Command_Type'Value (Argument (Command_Arg));
1083
1084             if Command_List (The_Command).VMS_Only then
1085                Non_VMS_Usage;
1086                Fail
1087                  ("Command """,
1088                   Command_List (The_Command).Cname.all,
1089                   """ can only be used on VMS");
1090             end if;
1091
1092          exception
1093             when Constraint_Error =>
1094
1095                --  Check if it is an alternate command
1096
1097                declare
1098                   Alternate : Alternate_Command;
1099
1100                begin
1101                   Alternate := Alternate_Command'Value
1102                                               (Argument (Command_Arg));
1103                   The_Command := Corresponding_To (Alternate);
1104
1105                exception
1106                   when Constraint_Error =>
1107                      Non_VMS_Usage;
1108                      Fail ("Unknown command: ", Argument (Command_Arg));
1109                end;
1110          end;
1111
1112          --  Get the arguments from the command line and from the eventual
1113          --  argument file(s) specified on the command line.
1114
1115          for Arg in Command_Arg + 1 .. Argument_Count loop
1116             declare
1117                The_Arg : constant String := Argument (Arg);
1118
1119             begin
1120                --  Check if an argument file is specified
1121
1122                if The_Arg (The_Arg'First) = '@' then
1123                   declare
1124                      Arg_File : Ada.Text_IO.File_Type;
1125                      Line     : String (1 .. 256);
1126                      Last     : Natural;
1127
1128                   begin
1129                      --  Open the file and fail if the file cannot be found
1130
1131                      begin
1132                         Open
1133                           (Arg_File, In_File,
1134                            The_Arg (The_Arg'First + 1 .. The_Arg'Last));
1135
1136                      exception
1137                         when others =>
1138                            Put
1139                              (Standard_Error, "Cannot open argument file """);
1140                            Put
1141                              (Standard_Error,
1142                               The_Arg (The_Arg'First + 1 .. The_Arg'Last));
1143
1144                            Put_Line (Standard_Error, """");
1145                            raise Error_Exit;
1146                      end;
1147
1148                      --  Read line by line and put the content of each
1149                      --  non empty line in the Last_Switches table.
1150
1151                      while not End_Of_File (Arg_File) loop
1152                         Get_Line (Arg_File, Line, Last);
1153
1154                         if Last /= 0 then
1155                            Last_Switches.Increment_Last;
1156                            Last_Switches.Table (Last_Switches.Last) :=
1157                              new String'(Line (1 .. Last));
1158                         end if;
1159                      end loop;
1160
1161                      Close (Arg_File);
1162                   end;
1163
1164                else
1165                   --  It is not an argument file; just put the argument in
1166                   --  the Last_Switches table.
1167
1168                   Last_Switches.Increment_Last;
1169                   Last_Switches.Table (Last_Switches.Last) :=
1170                     new String'(The_Arg);
1171                end if;
1172             end;
1173          end loop;
1174       end if;
1175    end if;
1176
1177    declare
1178       Program : constant String :=
1179                   Program_Name (Command_List (The_Command).Unixcmd.all).all;
1180
1181       Exec_Path : String_Access;
1182
1183    begin
1184       --  First deal with built-in command(s)
1185
1186       if The_Command = Setup then
1187          Process_Setup :
1188          declare
1189             Arg_Num : Positive := 1;
1190             Argv    : String_Access;
1191
1192          begin
1193             while Arg_Num <= Last_Switches.Last loop
1194                Argv := Last_Switches.Table (Arg_Num);
1195
1196                if Argv (Argv'First) /= '-' then
1197                   Fail ("invalid parameter """, Argv.all, """");
1198
1199                else
1200                   if Argv'Length = 1 then
1201                      Fail
1202                        ("switch character cannot be followed by a blank");
1203                   end if;
1204
1205                   --  -vPx  Specify verbosity while parsing project files
1206
1207                   if Argv'Length = 4
1208                     and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP"
1209                   then
1210                      case Argv (Argv'Last) is
1211                         when '0' =>
1212                            Current_Verbosity := Prj.Default;
1213                         when '1' =>
1214                            Current_Verbosity := Prj.Medium;
1215                         when '2' =>
1216                            Current_Verbosity := Prj.High;
1217                         when others =>
1218                            Fail ("Invalid switch: ", Argv.all);
1219                      end case;
1220
1221                   --  -Pproject_file  Specify project file to be used
1222
1223                   elsif Argv (Argv'First + 1) = 'P' then
1224
1225                      --  Only one -P switch can be used
1226
1227                      if Project_File /= null then
1228                         Fail
1229                           (Argv.all,
1230                            ": second project file forbidden (first is """,
1231                            Project_File.all & """)");
1232
1233                      elsif Argv'Length = 2 then
1234
1235                         --  There is space between -P and the project file
1236                         --  name. -P cannot be the last option.
1237
1238                         if Arg_Num = Last_Switches.Last then
1239                            Fail ("project file name missing after -P");
1240
1241                         else
1242                            Arg_Num := Arg_Num + 1;
1243                            Argv := Last_Switches.Table (Arg_Num);
1244
1245                            --  After -P, there must be a project file name,
1246                            --  not another switch.
1247
1248                            if Argv (Argv'First) = '-' then
1249                               Fail ("project file name missing after -P");
1250
1251                            else
1252                               Project_File := new String'(Argv.all);
1253                            end if;
1254                         end if;
1255
1256                      else
1257                         --  No space between -P and project file name
1258
1259                         Project_File :=
1260                           new String'(Argv (Argv'First + 2 .. Argv'Last));
1261                      end if;
1262
1263                   --  -Xexternal=value Specify an external reference to be
1264                   --                   used in project files
1265
1266                   elsif Argv'Length >= 5
1267                     and then Argv (Argv'First + 1) = 'X'
1268                   then
1269                      declare
1270                         Equal_Pos : constant Natural :=
1271                           Index ('=', Argv (Argv'First + 2 .. Argv'Last));
1272                      begin
1273                         if Equal_Pos >= Argv'First + 3 and then
1274                           Equal_Pos /= Argv'Last then
1275                            Add
1276                              (External_Name =>
1277                               Argv (Argv'First + 2 .. Equal_Pos - 1),
1278                               Value     => Argv (Equal_Pos + 1 .. Argv'Last));
1279                         else
1280                            Fail
1281                              (Argv.all,
1282                               " is not a valid external assignment.");
1283                         end if;
1284                      end;
1285
1286                   elsif Argv.all = "-v" then
1287                      Verbose_Mode := True;
1288
1289                   elsif Argv.all = "-q" then
1290                      Quiet_Output := True;
1291
1292                   else
1293                      Fail ("invalid parameter """, Argv.all, """");
1294                   end if;
1295                end if;
1296
1297                Arg_Num := Arg_Num + 1;
1298             end loop;
1299
1300             if Project_File = null then
1301                Fail ("no project file specified");
1302             end if;
1303
1304             Setup_Projects := True;
1305
1306             Prj.Pars.Set_Verbosity (To => Current_Verbosity);
1307
1308             --  Missing directories are created during processing of the
1309             --  project tree.
1310
1311             Prj.Pars.Parse
1312               (Project           => Project,
1313                In_Tree           => Project_Tree,
1314                Project_File_Name => Project_File.all,
1315                Packages_To_Check => All_Packages);
1316
1317             if Project = Prj.No_Project then
1318                Fail ("""", Project_File.all, """ processing failed");
1319             end if;
1320
1321             --  Processing is done
1322
1323             return;
1324          end Process_Setup;
1325       end if;
1326
1327       --  Locate the executable for the command
1328
1329       Exec_Path := Locate_Exec_On_Path (Program);
1330
1331       if Exec_Path = null then
1332          Put_Line (Standard_Error, "Couldn't locate " & Program);
1333          raise Error_Exit;
1334       end if;
1335
1336       --  If there are switches for the executable, put them as first switches
1337
1338       if Command_List (The_Command).Unixsws /= null then
1339          for J in Command_List (The_Command).Unixsws'Range loop
1340             First_Switches.Increment_Last;
1341             First_Switches.Table (First_Switches.Last) :=
1342               Command_List (The_Command).Unixsws (J);
1343          end loop;
1344       end if;
1345
1346       --  For BIND, FIND, LINK, LIST, PRETTY ad  XREF, look for project file
1347       --  related switches.
1348
1349       if The_Command = Bind
1350         or else The_Command = Elim
1351         or else The_Command = Find
1352         or else The_Command = Link
1353         or else The_Command = List
1354         or else The_Command = Xref
1355         or else The_Command = Pretty
1356         or else The_Command = Stub
1357         or else The_Command = Metric
1358       then
1359          case The_Command is
1360             when Bind =>
1361                Tool_Package_Name := Name_Binder;
1362                Packages_To_Check := Packages_To_Check_By_Binder;
1363             when Elim =>
1364                Tool_Package_Name := Name_Eliminate;
1365                Packages_To_Check := Packages_To_Check_By_Eliminate;
1366             when Find =>
1367                Tool_Package_Name := Name_Finder;
1368                Packages_To_Check := Packages_To_Check_By_Finder;
1369             when Link =>
1370                Tool_Package_Name := Name_Linker;
1371                Packages_To_Check := Packages_To_Check_By_Linker;
1372             when List =>
1373                Tool_Package_Name := Name_Gnatls;
1374                Packages_To_Check := Packages_To_Check_By_Gnatls;
1375             when Metric =>
1376                Tool_Package_Name := Name_Metrics;
1377                Packages_To_Check := Packages_To_Check_By_Metric;
1378             when Pretty =>
1379                Tool_Package_Name := Name_Pretty_Printer;
1380                Packages_To_Check := Packages_To_Check_By_Pretty;
1381             when Stub =>
1382                Tool_Package_Name := Name_Gnatstub;
1383                Packages_To_Check := Packages_To_Check_By_Gnatstub;
1384             when Xref =>
1385                Tool_Package_Name := Name_Cross_Reference;
1386                Packages_To_Check := Packages_To_Check_By_Xref;
1387             when others =>
1388                null;
1389          end case;
1390
1391          --  Check that the switches are consistent.
1392          --  Detect project file related switches.
1393
1394          Inspect_Switches :
1395          declare
1396             Arg_Num : Positive := 1;
1397             Argv    : String_Access;
1398
1399             procedure Remove_Switch (Num : Positive);
1400             --  Remove a project related switch from table Last_Switches
1401
1402             -------------------
1403             -- Remove_Switch --
1404             -------------------
1405
1406             procedure Remove_Switch (Num : Positive) is
1407             begin
1408                Last_Switches.Table (Num .. Last_Switches.Last - 1) :=
1409                  Last_Switches.Table (Num + 1 .. Last_Switches.Last);
1410                Last_Switches.Decrement_Last;
1411             end Remove_Switch;
1412
1413          --  Start of processing for Inspect_Switches
1414
1415          begin
1416             while Arg_Num <= Last_Switches.Last loop
1417                Argv := Last_Switches.Table (Arg_Num);
1418
1419                if Argv (Argv'First) = '-' then
1420                   if Argv'Length = 1 then
1421                      Fail
1422                        ("switch character cannot be followed by a blank");
1423                   end if;
1424
1425                   --  The two style project files (-p and -P) cannot be used
1426                   --  together
1427
1428                   if (The_Command = Find or else The_Command = Xref)
1429                     and then Argv (2) = 'p'
1430                   then
1431                      Old_Project_File_Used := True;
1432                      if Project_File /= null then
1433                         Fail ("-P and -p cannot be used together");
1434                      end if;
1435                   end if;
1436
1437                   --  -vPx  Specify verbosity while parsing project files
1438
1439                   if Argv'Length = 4
1440                     and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP"
1441                   then
1442                      case Argv (Argv'Last) is
1443                         when '0' =>
1444                            Current_Verbosity := Prj.Default;
1445                         when '1' =>
1446                            Current_Verbosity := Prj.Medium;
1447                         when '2' =>
1448                            Current_Verbosity := Prj.High;
1449                         when others =>
1450                            Fail ("Invalid switch: ", Argv.all);
1451                      end case;
1452
1453                      Remove_Switch (Arg_Num);
1454
1455                   --  -Pproject_file  Specify project file to be used
1456
1457                   elsif Argv (Argv'First + 1) = 'P' then
1458
1459                      --  Only one -P switch can be used
1460
1461                      if Project_File /= null then
1462                         Fail
1463                           (Argv.all,
1464                            ": second project file forbidden (first is """,
1465                            Project_File.all & """)");
1466
1467                      --  The two style project files (-p and -P) cannot be
1468                      --  used together.
1469
1470                      elsif Old_Project_File_Used then
1471                         Fail ("-p and -P cannot be used together");
1472
1473                      elsif Argv'Length = 2 then
1474
1475                         --  There is space between -P and the project file
1476                         --  name. -P cannot be the last option.
1477
1478                         if Arg_Num = Last_Switches.Last then
1479                            Fail ("project file name missing after -P");
1480
1481                         else
1482                            Remove_Switch (Arg_Num);
1483                            Argv := Last_Switches.Table (Arg_Num);
1484
1485                            --  After -P, there must be a project file name,
1486                            --  not another switch.
1487
1488                            if Argv (Argv'First) = '-' then
1489                               Fail ("project file name missing after -P");
1490
1491                            else
1492                               Project_File := new String'(Argv.all);
1493                            end if;
1494                         end if;
1495
1496                      else
1497                         --  No space between -P and project file name
1498
1499                         Project_File :=
1500                           new String'(Argv (Argv'First + 2 .. Argv'Last));
1501                      end if;
1502
1503                      Remove_Switch (Arg_Num);
1504
1505                   --  -Xexternal=value Specify an external reference to be
1506                   --                   used in project files
1507
1508                   elsif Argv'Length >= 5
1509                     and then Argv (Argv'First + 1) = 'X'
1510                   then
1511                      declare
1512                         Equal_Pos : constant Natural :=
1513                           Index ('=', Argv (Argv'First + 2 .. Argv'Last));
1514                      begin
1515                         if Equal_Pos >= Argv'First + 3 and then
1516                           Equal_Pos /= Argv'Last then
1517                            Add (External_Name =>
1518                                   Argv (Argv'First + 2 .. Equal_Pos - 1),
1519                                 Value => Argv (Equal_Pos + 1 .. Argv'Last));
1520                         else
1521                            Fail
1522                              (Argv.all,
1523                               " is not a valid external assignment.");
1524                         end if;
1525                      end;
1526
1527                      Remove_Switch (Arg_Num);
1528
1529                   else
1530                      Arg_Num := Arg_Num + 1;
1531                   end if;
1532
1533                else
1534                   Arg_Num := Arg_Num + 1;
1535                end if;
1536             end loop;
1537          end Inspect_Switches;
1538       end if;
1539
1540       --  If there is a project file specified, parse it, get the switches
1541       --  for the tool and setup PATH environment variables.
1542
1543       if Project_File /= null then
1544          Prj.Pars.Set_Verbosity (To => Current_Verbosity);
1545
1546          Prj.Pars.Parse
1547            (Project           => Project,
1548             In_Tree           => Project_Tree,
1549             Project_File_Name => Project_File.all,
1550             Packages_To_Check => Packages_To_Check);
1551
1552          if Project = Prj.No_Project then
1553             Fail ("""", Project_File.all, """ processing failed");
1554          end if;
1555
1556          --  Check if a package with the name of the tool is in the project
1557          --  file and if there is one, get the switches, if any, and scan them.
1558
1559          declare
1560             Data : constant Prj.Project_Data :=
1561                      Project_Tree.Projects.Table (Project);
1562
1563             Pkg : constant Prj.Package_Id :=
1564                     Prj.Util.Value_Of
1565                       (Name        => Tool_Package_Name,
1566                        In_Packages => Data.Decl.Packages,
1567                        In_Tree     => Project_Tree);
1568
1569             Element : Package_Element;
1570
1571             Default_Switches_Array : Array_Element_Id;
1572
1573             The_Switches : Prj.Variable_Value;
1574             Current      : Prj.String_List_Id;
1575             The_String   : String_Element;
1576
1577          begin
1578             if Pkg /= No_Package then
1579                Element := Project_Tree.Packages.Table (Pkg);
1580
1581                --  Packages Gnatls has a single attribute Switches, that is
1582                --  not an associative array.
1583
1584                if The_Command = List then
1585                   The_Switches :=
1586                     Prj.Util.Value_Of
1587                     (Variable_Name => Snames.Name_Switches,
1588                      In_Variables  => Element.Decl.Attributes,
1589                      In_Tree       => Project_Tree);
1590
1591                --  Packages Binder (for gnatbind), Cross_Reference (for
1592                --  gnatxref), Linker (for gnatlink) Finder (for gnatfind),
1593                --  Pretty_Printer (for gnatpp) Eliminate (for gnatelim) and
1594                --  Metric (for gnatmetric) have an attributed Switches,
1595                --  an associative array, indexed by the name of the file.
1596
1597                --  They also have an attribute Default_Switches, indexed
1598                --  by the name of the programming language.
1599
1600                else
1601                   if The_Switches.Kind = Prj.Undefined then
1602                      Default_Switches_Array :=
1603                        Prj.Util.Value_Of
1604                          (Name      => Name_Default_Switches,
1605                           In_Arrays => Element.Decl.Arrays,
1606                           In_Tree   => Project_Tree);
1607                      The_Switches := Prj.Util.Value_Of
1608                        (Index     => Name_Ada,
1609                         Src_Index => 0,
1610                         In_Array  => Default_Switches_Array,
1611                         In_Tree   => Project_Tree);
1612                   end if;
1613                end if;
1614
1615                --  If there are switches specified in the package of the
1616                --  project file corresponding to the tool, scan them.
1617
1618                case The_Switches.Kind is
1619                   when Prj.Undefined =>
1620                      null;
1621
1622                   when Prj.Single =>
1623                      declare
1624                         Switch : constant String :=
1625                                    Get_Name_String (The_Switches.Value);
1626
1627                      begin
1628                         if Switch'Length > 0 then
1629                            First_Switches.Increment_Last;
1630                            First_Switches.Table (First_Switches.Last) :=
1631                              new String'(Switch);
1632                         end if;
1633                      end;
1634
1635                   when Prj.List =>
1636                      Current := The_Switches.Values;
1637                      while Current /= Prj.Nil_String loop
1638                         The_String := Project_Tree.String_Elements.
1639                                         Table (Current);
1640
1641                         declare
1642                            Switch : constant String :=
1643                              Get_Name_String (The_String.Value);
1644
1645                         begin
1646                            if Switch'Length > 0 then
1647                               First_Switches.Increment_Last;
1648                               First_Switches.Table (First_Switches.Last) :=
1649                                 new String'(Switch);
1650                            end if;
1651                         end;
1652
1653                         Current := The_String.Next;
1654                      end loop;
1655                end case;
1656             end if;
1657          end;
1658
1659          if The_Command = Bind
1660            or else The_Command = Link
1661            or else The_Command = Elim
1662          then
1663             Change_Dir
1664               (Get_Name_String
1665                  (Project_Tree.Projects.Table
1666                     (Project).Object_Directory));
1667          end if;
1668
1669          --  Set up the env vars for project path files
1670
1671          Prj.Env.Set_Ada_Paths
1672            (Project, Project_Tree, Including_Libraries => False);
1673
1674          --  For gnatstub, gnatmetric, gnatpp and gnatelim, create
1675          --  a configuration pragmas file, if necessary.
1676
1677          if The_Command = Pretty
1678            or else The_Command = Metric
1679            or else The_Command = Stub
1680            or else The_Command = Elim
1681          then
1682             --  If -cargs is one of the switches, move the following
1683             --  switches to the Carg_Switches table.
1684
1685             for J in 1 .. First_Switches.Last loop
1686                if First_Switches.Table (J).all = "-cargs" then
1687                   for K in J + 1 .. First_Switches.Last loop
1688                      Add_To_Carg_Switches (First_Switches.Table (K));
1689                   end loop;
1690                   First_Switches.Set_Last (J - 1);
1691                   exit;
1692                end if;
1693             end loop;
1694
1695             for J in 1 .. Last_Switches.Last loop
1696                if Last_Switches.Table (J).all = "-cargs" then
1697                   for K in J + 1 .. Last_Switches.Last loop
1698                      Add_To_Carg_Switches (Last_Switches.Table (K));
1699                   end loop;
1700                   Last_Switches.Set_Last (J - 1);
1701                   exit;
1702                end if;
1703             end loop;
1704
1705             declare
1706                CP_File : constant Name_Id := Configuration_Pragmas_File;
1707             begin
1708                if CP_File /= No_Name then
1709                   if The_Command = Elim then
1710                      First_Switches.Increment_Last;
1711                      First_Switches.Table (First_Switches.Last)  :=
1712                        new String'("-C" & Get_Name_String (CP_File));
1713                   else
1714                      Add_To_Carg_Switches
1715                        (new String'("-gnatec=" & Get_Name_String (CP_File)));
1716                   end if;
1717                end if;
1718             end;
1719          end if;
1720
1721          if The_Command = Link then
1722             Process_Link;
1723          end if;
1724
1725          if The_Command = Link or The_Command = Bind then
1726
1727             --  For files that are specified as relative paths with directory
1728             --  information, we convert them to absolute paths, with parent
1729             --  being the current working directory if specified on the command
1730             --  line and the project directory if specified in the project
1731             --  file. This is what gnatmake is doing for linker and binder
1732             --  arguments.
1733
1734             for J in 1 .. Last_Switches.Last loop
1735                Test_If_Relative_Path
1736                  (Last_Switches.Table (J), Current_Work_Dir);
1737             end loop;
1738
1739             Get_Name_String
1740               (Project_Tree.Projects.Table (Project).Directory);
1741
1742             declare
1743                Project_Dir : constant String := Name_Buffer (1 .. Name_Len);
1744
1745             begin
1746                for J in 1 .. First_Switches.Last loop
1747                   Test_If_Relative_Path
1748                     (First_Switches.Table (J), Project_Dir);
1749                end loop;
1750             end;
1751
1752          elsif The_Command = Stub then
1753             declare
1754                Data : constant Prj.Project_Data :=
1755                         Project_Tree.Projects.Table (Project);
1756                File_Index : Integer := 0;
1757                Dir_Index  : Integer := 0;
1758                Last       : constant Integer := Last_Switches.Last;
1759
1760             begin
1761                for Index in 1 .. Last loop
1762                   if Last_Switches.Table (Index)
1763                     (Last_Switches.Table (Index)'First) /= '-'
1764                   then
1765                      File_Index := Index;
1766                      exit;
1767                   end if;
1768                end loop;
1769
1770                --  If the naming scheme of the project file is not standard,
1771                --  and if the file name ends with the spec suffix, then
1772                --  indicate to gnatstub the name of the body file with
1773                --  a -o switch.
1774
1775                if Data.Naming.Ada_Spec_Suffix /=
1776                  Prj.Default_Ada_Spec_Suffix
1777                then
1778                   if File_Index /= 0 then
1779                      declare
1780                         Spec : constant String :=
1781                           Base_Name (Last_Switches.Table (File_Index).all);
1782                         Last : Natural := Spec'Last;
1783
1784                      begin
1785                         Get_Name_String (Data.Naming.Ada_Spec_Suffix);
1786
1787                         if Spec'Length > Name_Len
1788                           and then Spec (Last - Name_Len + 1 .. Last) =
1789                           Name_Buffer (1 .. Name_Len)
1790                         then
1791                            Last := Last - Name_Len;
1792                            Get_Name_String (Data.Naming.Ada_Body_Suffix);
1793                            Last_Switches.Increment_Last;
1794                            Last_Switches.Table (Last_Switches.Last) :=
1795                              new String'("-o");
1796                            Last_Switches.Increment_Last;
1797                            Last_Switches.Table (Last_Switches.Last) :=
1798                              new String'(Spec (Spec'First .. Last) &
1799                                            Name_Buffer (1 .. Name_Len));
1800                         end if;
1801                      end;
1802                   end if;
1803                end if;
1804
1805                --  Add the directory of the spec as the destination directory
1806                --  of the body, if there is no destination directory already
1807                --  specified.
1808
1809                if File_Index /= 0 then
1810                   for Index in File_Index + 1 .. Last loop
1811                      if Last_Switches.Table (Index)
1812                        (Last_Switches.Table (Index)'First) /= '-'
1813                      then
1814                         Dir_Index := Index;
1815                         exit;
1816                      end if;
1817                   end loop;
1818
1819                   if Dir_Index = 0 then
1820                      Last_Switches.Increment_Last;
1821                      Last_Switches.Table (Last_Switches.Last) :=
1822                        new String'
1823                              (Dir_Name (Last_Switches.Table (File_Index).all));
1824                   end if;
1825                end if;
1826             end;
1827          end if;
1828
1829          --  For gnatmetric, the generated files should be put in the
1830          --  object directory. This must be the first switch, because it may
1831          --  be overriden by a switch in package Metrics in the project file
1832          --  or by a command line option.
1833
1834          if The_Command = Metric then
1835             First_Switches.Increment_Last;
1836             First_Switches.Table (2 .. First_Switches.Last) :=
1837               First_Switches.Table (1 .. First_Switches.Last - 1);
1838             First_Switches.Table (1) :=
1839               new String'("-d=" &
1840                           Get_Name_String
1841                             (Project_Tree.Projects.Table
1842                                (Project).Object_Directory));
1843          end if;
1844
1845          --  For gnat pretty and gnat metric, if no file has been put on the
1846          --  command line, call the tool with all the sources of the main
1847          --  project.
1848
1849          if The_Command = Pretty or else
1850             The_Command = Metric or else
1851             The_Command = List
1852          then
1853             Check_Files;
1854          end if;
1855       end if;
1856
1857       --  Gather all the arguments and invoke the executable
1858
1859       declare
1860          The_Args : Argument_List
1861                       (1 .. First_Switches.Last +
1862                             Last_Switches.Last +
1863                             Carg_Switches.Last);
1864          Arg_Num  : Natural := 0;
1865
1866       begin
1867          for J in 1 .. First_Switches.Last loop
1868             Arg_Num := Arg_Num + 1;
1869             The_Args (Arg_Num) := First_Switches.Table (J);
1870          end loop;
1871
1872          for J in 1 .. Last_Switches.Last loop
1873             Arg_Num := Arg_Num + 1;
1874             The_Args (Arg_Num) := Last_Switches.Table (J);
1875          end loop;
1876
1877          for J in 1 .. Carg_Switches.Last loop
1878             Arg_Num := Arg_Num + 1;
1879             The_Args (Arg_Num) := Carg_Switches.Table (J);
1880          end loop;
1881
1882          --  If Display_Command is on, only display the generated command
1883
1884          if Display_Command then
1885             Put (Standard_Error, "generated command -->");
1886             Put (Standard_Error, Exec_Path.all);
1887
1888             for Arg in The_Args'Range loop
1889                Put (Standard_Error, " ");
1890                Put (Standard_Error, The_Args (Arg).all);
1891             end loop;
1892
1893             Put (Standard_Error, "<--");
1894             New_Line (Standard_Error);
1895             raise Normal_Exit;
1896          end if;
1897
1898          if Verbose_Mode then
1899             Output.Write_Str (Exec_Path.all);
1900
1901             for Arg in The_Args'Range loop
1902                Output.Write_Char (' ');
1903                Output.Write_Str (The_Args (Arg).all);
1904             end loop;
1905
1906             Output.Write_Eol;
1907          end if;
1908
1909          My_Exit_Status :=
1910            Exit_Status (Spawn (Exec_Path.all, The_Args));
1911          raise Normal_Exit;
1912       end;
1913    end;
1914
1915 exception
1916    when Error_Exit =>
1917       Prj.Env.Delete_All_Path_Files (Project_Tree);
1918       Delete_Temp_Config_Files;
1919       Set_Exit_Status (Failure);
1920
1921    when Normal_Exit =>
1922       Prj.Env.Delete_All_Path_Files (Project_Tree);
1923       Delete_Temp_Config_Files;
1924
1925       --  Since GNATCmd is normally called from DCL (the VMS shell),
1926       --  it must return an understandable VMS exit status. However
1927       --  the exit status returned *to* GNATCmd is a Posix style code,
1928       --  so we test it and return just a simple success or failure on VMS.
1929
1930       if Hostparm.OpenVMS and then My_Exit_Status /= Success then
1931          Set_Exit_Status (Failure);
1932       else
1933          Set_Exit_Status (My_Exit_Status);
1934       end if;
1935 end GNATCmd;