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-2009, 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 GNAT.Directory_Operations; use GNAT.Directory_Operations;
  27
  28 with Csets;
  29 with Makeutl;  use Makeutl;
  30 with MLib.Tgt; use MLib.Tgt;
  31 with MLib.Utl;
  32 with MLib.Fil;
  33 with Namet;    use Namet;
  34 with Opt;      use Opt;
  35 with Osint;    use Osint;
  36 with Output;
  37 with Prj;      use Prj;
  38 with Prj.Env;
  39 with Prj.Ext;  use Prj.Ext;
  40 with Prj.Pars;
  41 with Prj.Tree; use Prj.Tree;
  42 with Prj.Util; use Prj.Util;
  43 with Sinput.P;
  44 with Snames;   use Snames;
  45 with Table;
  46 with Targparm;
  47 with Tempdir;
  48 with Types;    use Types;
  49 with Hostparm; use Hostparm;
  50 --  Used to determine if we are in VMS or not for error message purposes
  51
  52 with Ada.Characters.Handling; use Ada.Characters.Handling;
  53 with Ada.Command_Line;        use Ada.Command_Line;
  54 with Ada.Text_IO;             use Ada.Text_IO;
  55
  56 with GNAT.OS_Lib;             use GNAT.OS_Lib;
  57
  58 with VMS_Conv;                use VMS_Conv;
  59
  60 procedure GNATCmd is
  61    Project_Node_Tree : Project_Node_Tree_Ref;
  62    Project_File      : String_Access;
  63    Project           : Prj.Project_Id;
  64    Current_Verbosity : Prj.Verbosity := Prj.Default;
  65    Tool_Package_Name : Name_Id       := No_Name;
  66
  67    B_Start : String_Ptr    := new String'("b~");
  68    --  Prefix of binder generated file, changed to b__ for VMS
  69
  70    Old_Project_File_Used : Boolean := False;
  71    --  This flag indicates a switch -p (for gnatxref and gnatfind) for
  72    --  an old fashioned project file. -p cannot be used in conjunction
  73    --  with -P.
  74
  75    Temp_File_Name : Path_Name_Type := No_Path;
  76    --  The name of the temporary text file to put a list of source/object
  77    --  files to pass to a tool.
  78
  79    ASIS_Main : String_Access := null;
  80    --  Main for commands Check, Metric and Pretty, when -U is used
  81
  82    package First_Switches is new Table.Table
  83      (Table_Component_Type => String_Access,
  84       Table_Index_Type     => Integer,
  85       Table_Low_Bound      => 1,
  86       Table_Initial        => 20,
  87       Table_Increment      => 100,
  88       Table_Name           => "Gnatcmd.First_Switches");
  89    --  A table to keep the switches from the project file
  90
  91    package Carg_Switches is new Table.Table
  92      (Table_Component_Type => String_Access,
  93       Table_Index_Type     => Integer,
  94       Table_Low_Bound      => 1,
  95       Table_Initial        => 20,
  96       Table_Increment      => 100,
  97       Table_Name           => "Gnatcmd.Carg_Switches");
  98    --  A table to keep the switches following -cargs for ASIS tools
  99
 100    package Rules_Switches is new Table.Table
 101      (Table_Component_Type => String_Access,
 102       Table_Index_Type     => Integer,
 103       Table_Low_Bound      => 1,
 104       Table_Initial        => 20,
 105       Table_Increment      => 100,
 106       Table_Name           => "Gnatcmd.Rules_Switches");
 107    --  A table to keep the switches following -rules for gnatcheck
 108
 109    package Library_Paths is new Table.Table (
 110      Table_Component_Type => String_Access,
 111      Table_Index_Type     => Integer,
 112      Table_Low_Bound      => 1,
 113      Table_Initial        => 20,
 114      Table_Increment      => 100,
 115      Table_Name           => "Make.Library_Path");
 116
 117    --  Packages of project files to pass to Prj.Pars.Parse, depending on the
 118    --  tool. We allocate objects because we cannot declare aliased objects
 119    --  as we are in a procedure, not a library level package.
 120
 121    subtype SA is String_Access;
 122
 123    Naming_String      : constant SA := new String'("naming");
 124    Binder_String      : constant SA := new String'("binder");
 125    Compiler_String    : constant SA := new String'("compiler");
 126    Check_String       : constant SA := new String'("check");
 127    Synchronize_String : constant SA := new String'("synchronize");
 128    Eliminate_String   : constant SA := new String'("eliminate");
 129    Finder_String      : constant SA := new String'("finder");
 130    Linker_String      : constant SA := new String'("linker");
 131    Gnatls_String      : constant SA := new String'("gnatls");
 132    Pretty_String      : constant SA := new String'("pretty_printer");
 133    Stack_String       : constant SA := new String'("stack");
 134    Gnatstub_String    : constant SA := new String'("gnatstub");
 135    Metric_String      : constant SA := new String'("metrics");
 136    Xref_String        : constant SA := new String'("cross_reference");
 137
 138    Packages_To_Check_By_Binder   : constant String_List_Access :=
 139      new String_List'((Naming_String, Binder_String));
 140
 141    Packages_To_Check_By_Check : constant String_List_Access :=
 142      new String_List'((Naming_String, Check_String, Compiler_String));
 143
 144    Packages_To_Check_By_Sync : constant String_List_Access :=
 145      new String_List'((Naming_String, Synchronize_String, Compiler_String));
 146
 147    Packages_To_Check_By_Eliminate : constant String_List_Access :=
 148      new String_List'((Naming_String, Eliminate_String, Compiler_String));
 149
 150    Packages_To_Check_By_Finder    : constant String_List_Access :=
 151      new String_List'((Naming_String, Finder_String));
 152
 153    Packages_To_Check_By_Linker    : constant String_List_Access :=
 154      new String_List'((Naming_String, Linker_String));
 155
 156    Packages_To_Check_By_Gnatls    : constant String_List_Access :=
 157      new String_List'((Naming_String, Gnatls_String));
 158
 159    Packages_To_Check_By_Pretty    : constant String_List_Access :=
 160      new String_List'((Naming_String, Pretty_String, Compiler_String));
 161
 162    Packages_To_Check_By_Stack     : constant String_List_Access :=
 163      new String_List'((Naming_String, Stack_String));
 164
 165    Packages_To_Check_By_Gnatstub  : constant String_List_Access :=
 166      new String_List'((Naming_String, Gnatstub_String, Compiler_String));
 167
 168    Packages_To_Check_By_Metric  : constant String_List_Access :=
 169      new String_List'((Naming_String, Metric_String, Compiler_String));
 170
 171    Packages_To_Check_By_Xref      : constant String_List_Access :=
 172      new String_List'((Naming_String, Xref_String));
 173
 174    Packages_To_Check : String_List_Access := Prj.All_Packages;
 175
 176    ----------------------------------
 177    -- Declarations for GNATCMD use --
 178    ----------------------------------
 179
 180    The_Command : Command_Type;
 181    --  The command specified in the invocation of the GNAT driver
 182
 183    Command_Arg : Positive := 1;
 184    --  The index of the command in the arguments of the GNAT driver
 185
 186    My_Exit_Status : Exit_Status := Success;
 187    --  The exit status of the spawned tool. Used to set the correct VMS
 188    --  exit status.
 189
 190    Current_Work_Dir : constant String := Get_Current_Dir;
 191    --  The path of the working directory
 192
 193    All_Projects : Boolean := False;
 194    --  Flag used for GNAT CHECK, GNAT PRETTY, GNAT METRIC, and GNAT STACK to
 195    --  indicate that the underlying tool (gnatcheck, gnatpp or gnatmetric)
 196    --  should be invoked for all sources of all projects.
 197
 198    -----------------------
 199    -- Local Subprograms --
 200    -----------------------
 201
 202    procedure Add_To_Carg_Switches (Switch : String_Access);
 203    --  Add a switch to the Carg_Switches table. If it is the first one, put the
 204    --  switch "-cargs" at the beginning of the table.
 205
 206    procedure Add_To_Rules_Switches (Switch : String_Access);
 207    --  Add a switch to the Rules_Switches table. If it is the first one, put
 208    --  the switch "-crules" at the beginning of the table.
 209
 210    procedure Check_Files;
 211    --  For GNAT LIST, GNAT PRETTY, GNAT METRIC, and GNAT STACK, check if a
 212    --  project file is specified, without any file arguments. If it is the
 213    --  case, invoke the GNAT tool with the proper list of files, derived from
 214    --  the sources of the project.
 215
 216    function Check_Project
 217      (Project      : Project_Id;
 218       Root_Project : Project_Id) return Boolean;
 219    --  Returns True if Project = Root_Project or if we want to consider all
 220    --  sources of all projects. For GNAT METRIC, also returns True if Project
 221    --  is extended by Root_Project.
 222
 223    procedure Check_Relative_Executable (Name : in out String_Access);
 224    --  Check if an executable is specified as a relative path. If it is, and
 225    --  the path contains directory information, fail. Otherwise, prepend the
 226    --  exec directory. This procedure is only used for GNAT LINK when a project
 227    --  file is specified.
 228
 229    function Configuration_Pragmas_File return Path_Name_Type;
 230    --  Return an argument, if there is a configuration pragmas file to be
 231    --  specified for Project, otherwise return No_Name. Used for gnatstub (GNAT
 232    --  STUB), gnatpp (GNAT PRETTY), gnatelim (GNAT ELIM), and gnatmetric (GNAT
 233    --  METRIC).
 234
 235    procedure Delete_Temp_Config_Files;
 236    --  Delete all temporary config files. The caller is responsible for
 237    --  ensuring that Keep_Temporary_Files is False.
 238
 239    procedure Get_Closure;
 240    --  Get the sources in the closure of the ASIS_Main and add them to the
 241    --  list of arguments.
 242
 243    function Index (Char : Character; Str : String) return Natural;
 244    --  Returns first occurrence of Char in Str, returns 0 if Char not in Str
 245
 246    procedure Non_VMS_Usage;
 247    --  Display usage for platforms other than VMS
 248
 249    procedure Process_Link;
 250    --  Process GNAT LINK, when there is a project file specified
 251
 252    procedure Set_Library_For
 253      (Project           : Project_Id;
 254       Libraries_Present : in out Boolean);
 255    --  If Project is a library project, add the correct -L and -l switches to
 256    --  the linker invocation.
 257
 258    procedure Set_Libraries is
 259       new For_Every_Project_Imported (Boolean, Set_Library_For);
 260    --  Add the -L and -l switches to the linker for all of the library
 261    --  projects.
 262
 263    procedure Test_If_Relative_Path
 264      (Switch : in out String_Access;
 265       Parent : String);
 266    --  Test if Switch is a relative search path switch. If it is and it
 267    --  includes directory information, prepend the path with Parent. This
 268    --  subprogram is only called when using project files.
 269
 270    --------------------------
 271    -- Add_To_Carg_Switches --
 272    --------------------------
 273
 274    procedure Add_To_Carg_Switches (Switch : String_Access) is
 275    begin
 276       --  If the Carg_Switches table is empty, put "-cargs" at the beginning
 277
 278       if Carg_Switches.Last = 0 then
 279          Carg_Switches.Increment_Last;
 280          Carg_Switches.Table (Carg_Switches.Last) := new String'("-cargs");
 281       end if;
 282
 283       Carg_Switches.Increment_Last;
 284       Carg_Switches.Table (Carg_Switches.Last) := Switch;
 285    end Add_To_Carg_Switches;
 286
 287    ---------------------------
 288    -- Add_To_Rules_Switches --
 289    ---------------------------
 290
 291    procedure Add_To_Rules_Switches (Switch : String_Access) is
 292    begin
 293       --  If the Rules_Switches table is empty, put "-rules" at the beginning
 294
 295       if Rules_Switches.Last = 0 then
 296          Rules_Switches.Increment_Last;
 297          Rules_Switches.Table (Rules_Switches.Last) := new String'("-rules");
 298       end if;
 299
 300       Rules_Switches.Increment_Last;
 301       Rules_Switches.Table (Rules_Switches.Last) := Switch;
 302    end Add_To_Rules_Switches;
 303
 304    -----------------
 305    -- Check_Files --
 306    -----------------
 307
 308    procedure Check_Files is
 309       Add_Sources : Boolean := True;
 310       Unit        : Prj.Unit_Index;
 311       Subunit     : Boolean := False;
 312       FD          : File_Descriptor := Invalid_FD;
 313       Status      : Integer;
 314       Success     : Boolean;
 315
 316    begin
 317       --  Check if there is at least one argument that is not a switch
 318
 319       for Index in 1 .. Last_Switches.Last loop
 320          if Last_Switches.Table (Index) (1) /= '-' then
 321             Add_Sources := False;
 322             exit;
 323          end if;
 324       end loop;
 325
 326       --  If all arguments were switches, add the path names of all the sources
 327       --  of the main project.
 328
 329       if Add_Sources then
 330
 331          --  For gnatcheck, gnatpp and gnatmetric , create a temporary file and
 332          --  put the list of sources in it.
 333
 334          if The_Command = Check  or else
 335             The_Command = Pretty or else
 336             The_Command = Metric
 337          then
 338             Tempdir.Create_Temp_File (FD, Temp_File_Name);
 339             Last_Switches.Increment_Last;
 340             Last_Switches.Table (Last_Switches.Last) :=
 341               new String'("-files=" & Get_Name_String (Temp_File_Name));
 342          end if;
 343
 344          declare
 345             Proj : Project_List;
 346
 347          begin
 348             --  Gnatstack needs to add the .ci file for the binder generated
 349             --  files corresponding to all of the library projects and main
 350             --  units belonging to the application.
 351
 352             if The_Command = Stack then
 353                Proj := Project_Tree.Projects;
 354                while Proj /= null loop
 355                   if Check_Project (Proj.Project, Project) then
 356                      declare
 357                         Main : String_List_Id;
 358                         File : String_Access;
 359
 360                      begin
 361                         --  Include binder generated files for main programs
 362
 363                         Main := Proj.Project.Mains;
 364                         while Main /= Nil_String loop
 365                            File :=
 366                              new String'
 367                                (Get_Name_String
 368                                  (Proj.Project.Object_Directory.Name)        &
 369                                 B_Start.all                                  &
 370                                 MLib.Fil.Ext_To
 371                                   (Get_Name_String
 372                                      (Project_Tree.String_Elements.Table
 373                                         (Main).Value),
 374                                    "ci"));
 375
 376                            if Is_Regular_File (File.all) then
 377                               Last_Switches.Increment_Last;
 378                               Last_Switches.Table (Last_Switches.Last) := File;
 379                            end if;
 380
 381                            Main :=
 382                              Project_Tree.String_Elements.Table (Main).Next;
 383                         end loop;
 384
 385                         if Proj.Project.Library then
 386
 387                            --  Include the .ci file for the binder generated
 388                            --  files that contains the initialization and
 389                            --  finalization of the library.
 390
 391                            File :=
 392                              new String'
 393                                (Get_Name_String
 394                                  (Proj.Project.Object_Directory.Name)        &
 395                                 B_Start.all                                  &
 396                                 Get_Name_String (Proj.Project.Library_Name)  &
 397                                 ".ci");
 398
 399                            if Is_Regular_File (File.all) then
 400                               Last_Switches.Increment_Last;
 401                               Last_Switches.Table (Last_Switches.Last) := File;
 402                            end if;
 403                         end if;
 404                      end;
 405                   end if;
 406
 407                   Proj := Proj.Next;
 408                end loop;
 409             end if;
 410
 411             Unit := Units_Htable.Get_First (Project_Tree.Units_HT);
 412             while Unit /= No_Unit_Index loop
 413
 414                --  For gnatls, we only need to put the library units, body or
 415                --  spec, but not the subunits.
 416
 417                if The_Command = List then
 418                   if Unit.File_Names (Impl) /= null
 419                     and then not Unit.File_Names (Impl).Locally_Removed
 420                   then
 421                      --  There is a body, check if it is for this project
 422
 423                      if All_Projects or else
 424                         Unit.File_Names (Impl).Project = Project
 425                      then
 426                         Subunit := False;
 427
 428                         if Unit.File_Names (Spec) = null
 429                           or else Unit.File_Names (Spec).Locally_Removed
 430                         then
 431                            --  We have a body with no spec: we need to check if
 432                            --  this is a subunit, because gnatls will complain
 433                            --  about subunits.
 434
 435                            declare
 436                               Src_Ind : constant Source_File_Index :=
 437                                           Sinput.P.Load_Project_File
 438                                             (Get_Name_String
 439                                               (Unit.File_Names
 440                                                 (Impl).Path.Name));
 441                            begin
 442                               Subunit :=
 443                                 Sinput.P.Source_File_Is_Subunit (Src_Ind);
 444                            end;
 445                         end if;
 446
 447                         if not Subunit then
 448                            Last_Switches.Increment_Last;
 449                            Last_Switches.Table (Last_Switches.Last) :=
 450                              new String'
 451                                (Get_Name_String
 452                                     (Unit.File_Names
 453                                          (Impl).Display_File));
 454                         end if;
 455                      end if;
 456
 457                   elsif Unit.File_Names (Spec) /= null
 458                     and then not Unit.File_Names (Spec).Locally_Removed
 459                   then
 460                      --  We have a spec with no body. Check if it is for this
 461                      --  project.
 462
 463                      if All_Projects or else
 464                         Unit.File_Names (Spec).Project = Project
 465                      then
 466                         Last_Switches.Increment_Last;
 467                         Last_Switches.Table (Last_Switches.Last) :=
 468                           new String'(Get_Name_String
 469                                        (Unit.File_Names (Spec).Display_File));
 470                      end if;
 471                   end if;
 472
 473                --  For gnatstack, we put the .ci files corresponding to the
 474                --  different units, including the binder generated files. We
 475                --  only need to do that for the library units, body or spec,
 476                --  but not the subunits.
 477
 478                elsif The_Command = Stack then
 479                   if Unit.File_Names (Impl) /= null
 480                     and then not Unit.File_Names (Impl).Locally_Removed
 481                   then
 482                      --  There is a body. Check if .ci files for this project
 483                      --  must be added.
 484
 485                      if Check_Project
 486                           (Unit.File_Names (Impl).Project, Project)
 487                      then
 488                         Subunit := False;
 489
 490                         if Unit.File_Names (Spec) = null
 491                           or else Unit.File_Names (Spec).Locally_Removed
 492                         then
 493                            --  We have a body with no spec: we need to check
 494                            --  if this is a subunit, because .ci files are not
 495                            --  generated for subunits.
 496
 497                            declare
 498                               Src_Ind : constant Source_File_Index :=
 499                                           Sinput.P.Load_Project_File
 500                                             (Get_Name_String
 501                                               (Unit.File_Names
 502                                                 (Impl).Path.Name));
 503                            begin
 504                               Subunit :=
 505                                 Sinput.P.Source_File_Is_Subunit (Src_Ind);
 506                            end;
 507                         end if;
 508
 509                         if not Subunit then
 510                            Last_Switches.Increment_Last;
 511                            Last_Switches.Table (Last_Switches.Last) :=
 512                              new String'
 513                                (Get_Name_String
 514                                  (Unit.File_Names
 515                                    (Impl).Project. Object_Directory.Name)  &
 516                                 MLib.Fil.Ext_To
 517                                   (Get_Name_String
 518                                      (Unit.File_Names (Impl).Display_File),
 519                                    "ci"));
 520                         end if;
 521                      end if;
 522
 523                   elsif Unit.File_Names (Spec) /= null
 524                     and then not Unit.File_Names (Spec).Locally_Removed
 525                   then
 526                      --  Spec with no body, check if it is for this project
 527
 528                      if Check_Project
 529                           (Unit.File_Names (Spec).Project, Project)
 530                      then
 531                         Last_Switches.Increment_Last;
 532                         Last_Switches.Table (Last_Switches.Last) :=
 533                           new String'
 534                             (Get_Name_String
 535                               (Unit.File_Names
 536                                 (Spec).Project. Object_Directory.Name)     &
 537                              Dir_Separator                                 &
 538                              MLib.Fil.Ext_To
 539                                (Get_Name_String (Unit.File_Names (Spec).File),
 540                                 "ci"));
 541                      end if;
 542                   end if;
 543
 544                else
 545                   --  For gnatcheck, gnatsync, gnatpp and gnatmetric, put all
 546                   --  sources of the project, or of all projects if -U was
 547                   --  specified.
 548
 549                   for Kind in Spec_Or_Body loop
 550                      if Unit.File_Names (Kind) /= null
 551                        and then Check_Project
 552                                   (Unit.File_Names (Kind).Project, Project)
 553                        and then not Unit.File_Names (Kind).Locally_Removed
 554                      then
 555                         Get_Name_String
 556                           (Unit.File_Names (Kind).Path.Display_Name);
 557
 558                         if FD /= Invalid_FD then
 559                            Name_Len := Name_Len + 1;
 560                            Name_Buffer (Name_Len) := ASCII.LF;
 561                            Status :=
 562                              Write (FD, Name_Buffer (1)'Address, Name_Len);
 563
 564                            if Status /= Name_Len then
 565                               Osint.Fail ("disk full");
 566                            end if;
 567
 568                         else
 569                            Last_Switches.Increment_Last;
 570                            Last_Switches.Table (Last_Switches.Last) :=
 571                              new String'(Get_Name_String
 572                                           (Unit.File_Names
 573                                             (Kind).Path.Display_Name));
 574                         end if;
 575                      end if;
 576                   end loop;
 577                end if;
 578
 579                Unit := Units_Htable.Get_Next (Project_Tree.Units_HT);
 580             end loop;
 581          end;
 582
 583          if FD /= Invalid_FD then
 584             Close (FD, Success);
 585
 586             if not Success then
 587                Osint.Fail ("disk full");
 588             end if;
 589          end if;
 590       end if;
 591    end Check_Files;
 592
 593    -------------------
 594    -- Check_Project --
 595    -------------------
 596
 597    function Check_Project
 598      (Project      : Project_Id;
 599       Root_Project : Project_Id) return Boolean
 600    is
 601       Proj : Project_Id;
 602
 603    begin
 604       if Project = No_Project then
 605          return False;
 606
 607       elsif All_Projects or else Project = Root_Project then
 608          return True;
 609
 610       elsif The_Command = Metric then
 611          Proj := Root_Project;
 612          while Proj.Extends /= No_Project loop
 613             if Project = Proj.Extends then
 614                return True;
 615             end if;
 616
 617             Proj := Proj.Extends;
 618          end loop;
 619       end if;
 620
 621       return False;
 622    end Check_Project;
 623
 624    -------------------------------
 625    -- Check_Relative_Executable --
 626    -------------------------------
 627
 628    procedure Check_Relative_Executable (Name : in out String_Access) is
 629       Exec_File_Name : constant String := Name.all;
 630
 631    begin
 632       if not Is_Absolute_Path (Exec_File_Name) then
 633          for Index in Exec_File_Name'Range loop
 634             if Exec_File_Name (Index) = Directory_Separator then
 635                Fail ("relative executable (""" &
 636                        Exec_File_Name &
 637                        """) with directory part not allowed " &
 638                        "when using project files");
 639             end if;
 640          end loop;
 641
 642          Get_Name_String (Project.Exec_Directory.Name);
 643
 644          if Name_Buffer (Name_Len) /= Directory_Separator then
 645             Name_Len := Name_Len + 1;
 646             Name_Buffer (Name_Len) := Directory_Separator;
 647          end if;
 648
 649          Name_Buffer (Name_Len + 1 ..
 650                         Name_Len + Exec_File_Name'Length) :=
 651            Exec_File_Name;
 652          Name_Len := Name_Len + Exec_File_Name'Length;
 653          Name := new String'(Name_Buffer (1 .. Name_Len));
 654       end if;
 655    end Check_Relative_Executable;
 656
 657    --------------------------------
 658    -- Configuration_Pragmas_File --
 659    --------------------------------
 660
 661    function Configuration_Pragmas_File return Path_Name_Type is
 662    begin
 663       Prj.Env.Create_Config_Pragmas_File (Project, Project_Tree);
 664       return Project.Config_File_Name;
 665    end Configuration_Pragmas_File;
 666
 667    ------------------------------
 668    -- Delete_Temp_Config_Files --
 669    ------------------------------
 670
 671    procedure Delete_Temp_Config_Files is
 672       Success : Boolean;
 673       Proj    : Project_List;
 674       pragma Warnings (Off, Success);
 675
 676    begin
 677       --  This should only be called if Keep_Temporary_Files is False
 678
 679       pragma Assert (not Keep_Temporary_Files);
 680
 681       if Project /= No_Project then
 682          Proj := Project_Tree.Projects;
 683          while Proj /= null loop
 684             if Proj.Project.Config_File_Temp then
 685                Delete_Temporary_File
 686                  (Project_Tree, Proj.Project.Config_File_Name);
 687             end if;
 688
 689             Proj := Proj.Next;
 690          end loop;
 691       end if;
 692
 693       --  If a temporary text file that contains a list of files for a tool
 694       --  has been created, delete this temporary file.
 695
 696       if Temp_File_Name /= No_Path then
 697          Delete_Temporary_File (Project_Tree, Temp_File_Name);
 698       end if;
 699    end Delete_Temp_Config_Files;
 700
 701    -----------------
 702    -- Get_Closure --
 703    -----------------
 704
 705    procedure Get_Closure is
 706       Args : constant Argument_List :=
 707                (1 => new String'("-q"),
 708                 2 => new String'("-b"),
 709                 3 => new String'("-P"),
 710                 4 => Project_File,
 711                 5 => ASIS_Main,
 712                 6 => new String'("-bargs"),
 713                 7 => new String'("-R"),
 714                 8 => new String'("-Z"));
 715       --  Arguments for the invocation of gnatmake which are added to the
 716       --  Last_Arguments list by this procedure.
 717
 718       FD : File_Descriptor;
 719       --  File descriptor for the temp file that will get the output of the
 720       --  invocation of gnatmake.
 721
 722       Name : Path_Name_Type;
 723       --  Path of the file FD
 724
 725       GN_Name : constant String := Program_Name ("gnatmake", "gnat").all;
 726       --  Name for gnatmake
 727
 728       GN_Path : constant String_Access := Locate_Exec_On_Path (GN_Name);
 729       --  Path of gnatmake
 730
 731       Return_Code : Integer;
 732
 733       Unused : Boolean;
 734       pragma Warnings (Off, Unused);
 735
 736       File : Ada.Text_IO.File_Type;
 737       Line : String (1 .. 250);
 738       Last : Natural;
 739       --  Used to read file if there is an error, it is good enough to display
 740       --  just 250 characters if the first line of the file is very long.
 741
 742       Unit  : Unit_Index;
 743       Path  : Path_Name_Type;
 744
 745    begin
 746       if GN_Path = null then
 747          Put_Line (Standard_Error, "could not locate " & GN_Name);
 748          raise Error_Exit;
 749       end if;
 750
 751       --  Create the temp file
 752
 753       Tempdir.Create_Temp_File (FD, Name);
 754
 755       --  And close it, because on VMS Spawn with a file descriptor created
 756       --  with Create_Temp_File does not redirect output.
 757
 758       Close (FD);
 759
 760       --  Spawn "gnatmake -q -b -P <project> <main> -bargs -R -Z"
 761
 762       Spawn
 763         (Program_Name => GN_Path.all,
 764          Args         => Args,
 765          Output_File  => Get_Name_String (Name),
 766          Success      => Unused,
 767          Return_Code  => Return_Code,
 768          Err_To_Out   => True);
 769
 770       Close (FD);
 771
 772       --  Read the output of the invocation of gnatmake
 773
 774       Open (File, In_File, Get_Name_String (Name));
 775
 776       --  If it was unsuccessful, display the first line in the file and exit
 777       --  with error.
 778
 779       if Return_Code /= 0 then
 780          Get_Line (File, Line, Last);
 781
 782          if not Keep_Temporary_Files then
 783             Delete (File);
 784          else
 785             Close (File);
 786          end if;
 787
 788          Put_Line (Standard_Error, Line (1 .. Last));
 789          Put_Line
 790            (Standard_Error, "could not get closure of " & ASIS_Main.all);
 791          raise Error_Exit;
 792
 793       else
 794          --  Get each file name in the file, find its path and add it the
 795          --  list of arguments.
 796
 797          while not End_Of_File (File) loop
 798             Get_Line (File, Line, Last);
 799             Path := No_Path;
 800
 801             Unit := Units_Htable.Get_First (Project_Tree.Units_HT);
 802             while Unit /= No_Unit_Index loop
 803                if Unit.File_Names (Spec) /= null
 804                  and then
 805                    Get_Name_String (Unit.File_Names (Spec).File) =
 806                       Line (1 .. Last)
 807                then
 808                   Path := Unit.File_Names (Spec).Path.Name;
 809                   exit;
 810
 811                elsif Unit.File_Names (Impl) /= null
 812                  and then
 813                    Get_Name_String (Unit.File_Names (Impl).File) =
 814                      Line (1 .. Last)
 815                then
 816                   Path := Unit.File_Names (Impl).Path.Name;
 817                   exit;
 818                end if;
 819
 820                Unit := Units_Htable.Get_Next (Project_Tree.Units_HT);
 821             end loop;
 822
 823             Last_Switches.Increment_Last;
 824
 825             if Path /= No_Path then
 826                Last_Switches.Table (Last_Switches.Last) :=
 827                   new String'(Get_Name_String (Path));
 828
 829             else
 830                Last_Switches.Table (Last_Switches.Last) :=
 831                  new String'(Line (1 .. Last));
 832             end if;
 833          end loop;
 834
 835          if not Keep_Temporary_Files then
 836             Delete (File);
 837          else
 838             Close (File);
 839          end if;
 840       end if;
 841    end Get_Closure;
 842
 843    -----------
 844    -- Index --
 845    -----------
 846
 847    function Index (Char : Character; Str : String) return Natural is
 848    begin
 849       for Index in Str'Range loop
 850          if Str (Index) = Char then
 851             return Index;
 852          end if;
 853       end loop;
 854
 855       return 0;
 856    end Index;
 857
 858    ------------------
 859    -- Process_Link --
 860    ------------------
 861
 862    procedure Process_Link is
 863       Look_For_Executable : Boolean := True;
 864       Libraries_Present   : Boolean := False;
 865       Path_Option         : constant String_Access :=
 866                               MLib.Linker_Library_Path_Option;
 867       Prj                 : Project_Id := Project;
 868       Arg                 : String_Access;
 869       Last                : Natural := 0;
 870       Skip_Executable     : Boolean := False;
 871
 872    begin
 873       --  Add the default search directories, to be able to find
 874       --  libgnat in call to MLib.Utl.Lib_Directory.
 875
 876       Add_Default_Search_Dirs;
 877
 878       Library_Paths.Set_Last (0);
 879
 880       --  Check if there are library project files
 881
 882       if MLib.Tgt.Support_For_Libraries /= None then
 883          Set_Libraries (Project, Libraries_Present);
 884       end if;
 885
 886       --  If there are, add the necessary additional switches
 887
 888       if Libraries_Present then
 889
 890          --  Add -L<lib_dir> -lgnarl -lgnat -Wl,-rpath,<lib_dir>
 891
 892          Last_Switches.Increment_Last;
 893          Last_Switches.Table (Last_Switches.Last) :=
 894            new String'("-L" & MLib.Utl.Lib_Directory);
 895          Last_Switches.Increment_Last;
 896          Last_Switches.Table (Last_Switches.Last) :=
 897            new String'("-lgnarl");
 898          Last_Switches.Increment_Last;
 899          Last_Switches.Table (Last_Switches.Last) :=
 900            new String'("-lgnat");
 901
 902          --  If Path_Option is not null, create the switch ("-Wl,-rpath," or
 903          --  equivalent) with all the library dirs plus the standard GNAT
 904          --  library dir.
 905
 906          if Path_Option /= null then
 907             declare
 908                Option  : String_Access;
 909                Length  : Natural := Path_Option'Length;
 910                Current : Natural;
 911
 912             begin
 913                if MLib.Separate_Run_Path_Options then
 914
 915                   --  We are going to create one switch of the form
 916                   --  "-Wl,-rpath,dir_N" for each directory to consider.
 917
 918                   --  One switch for each library directory
 919
 920                   for Index in
 921                     Library_Paths.First .. Library_Paths.Last
 922                   loop
 923                      Last_Switches.Increment_Last;
 924                      Last_Switches.Table
 925                        (Last_Switches.Last) := new String'
 926                        (Path_Option.all &
 927                         Last_Switches.Table (Index).all);
 928                   end loop;
 929
 930                   --  One switch for the standard GNAT library dir
 931
 932                   Last_Switches.Increment_Last;
 933                   Last_Switches.Table
 934                     (Last_Switches.Last) := new String'
 935                     (Path_Option.all & MLib.Utl.Lib_Directory);
 936
 937                else
 938                   --  First, compute the exact length for the switch
 939
 940                   for Index in
 941                     Library_Paths.First .. Library_Paths.Last
 942                   loop
 943                      --  Add the length of the library dir plus one for the
 944                      --  directory separator.
 945
 946                      Length :=
 947                        Length +
 948                          Library_Paths.Table (Index)'Length + 1;
 949                   end loop;
 950
 951                   --  Finally, add the length of the standard GNAT library dir
 952
 953                   Length := Length + MLib.Utl.Lib_Directory'Length;
 954                   Option := new String (1 .. Length);
 955                   Option (1 .. Path_Option'Length) := Path_Option.all;
 956                   Current := Path_Option'Length;
 957
 958                   --  Put each library dir followed by a dir separator
 959
 960                   for Index in
 961                     Library_Paths.First .. Library_Paths.Last
 962                   loop
 963                      Option
 964                        (Current + 1 ..
 965                           Current +
 966                             Library_Paths.Table (Index)'Length) :=
 967                        Library_Paths.Table (Index).all;
 968                      Current :=
 969                        Current +
 970                          Library_Paths.Table (Index)'Length + 1;
 971                      Option (Current) := Path_Separator;
 972                   end loop;
 973
 974                   --  Finally put the standard GNAT library dir
 975
 976                   Option
 977                     (Current + 1 ..
 978                        Current + MLib.Utl.Lib_Directory'Length) :=
 979                       MLib.Utl.Lib_Directory;
 980
 981                   --  And add the switch to the last switches
 982
 983                   Last_Switches.Increment_Last;
 984                   Last_Switches.Table (Last_Switches.Last) :=
 985                     Option;
 986                end if;
 987             end;
 988          end if;
 989       end if;
 990
 991       --  Check if the first ALI file specified can be found, either in the
 992       --  object directory of the main project or in an object directory of a
 993       --  project file extended by the main project. If the ALI file can be
 994       --  found, replace its name with its absolute path.
 995
 996       Skip_Executable := False;
 997
 998       Switch_Loop : for J in 1 .. Last_Switches.Last loop
 999
1000          --  If we have an executable just reset the flag
1001
1002          if Skip_Executable then
1003             Skip_Executable := False;
1004
1005          --  If -o, set flag so that next switch is not processed
1006
1007          elsif Last_Switches.Table (J).all = "-o" then
1008             Skip_Executable := True;
1009
1010          --  Normal case
1011
1012          else
1013             declare
1014                Switch    : constant String :=
1015                              Last_Switches.Table (J).all;
1016                ALI_File  : constant String (1 .. Switch'Length + 4) :=
1017                              Switch & ".ali";
1018
1019                Test_Existence : Boolean := False;
1020
1021             begin
1022                Last := Switch'Length;
1023
1024                --  Skip real switches
1025
1026                if Switch'Length /= 0
1027                  and then Switch (Switch'First) /= '-'
1028                then
1029                   --  Append ".ali" if file name does not end with it
1030
1031                   if Switch'Length <= 4
1032                     or else Switch (Switch'Last - 3 .. Switch'Last)
1033                     /= ".ali"
1034                   then
1035                      Last := ALI_File'Last;
1036                   end if;
1037
1038                   --  If file name includes directory information, stop if ALI
1039                   --  file exists.
1040
1041                   if Is_Absolute_Path (ALI_File (1 .. Last)) then
1042                      Test_Existence := True;
1043
1044                   else
1045                      for K in Switch'Range loop
1046                         if Switch (K) = '/' or else
1047                           Switch (K) = Directory_Separator
1048                         then
1049                            Test_Existence := True;
1050                            exit;
1051                         end if;
1052                      end loop;
1053                   end if;
1054
1055                   if Test_Existence then
1056                      if Is_Regular_File (ALI_File (1 .. Last)) then
1057                         exit Switch_Loop;
1058                      end if;
1059
1060                   --  Look in object directories if ALI file exists
1061
1062                   else
1063                      Project_Loop : loop
1064                         declare
1065                            Dir : constant String :=
1066                                    Get_Name_String (Prj.Object_Directory.Name);
1067                         begin
1068                            if Is_Regular_File
1069                                 (Dir &
1070                                  ALI_File (1 .. Last))
1071                            then
1072                               --  We have found the correct project, so we
1073                               --  replace the file with the absolute path.
1074
1075                               Last_Switches.Table (J) :=
1076                                 new String'(Dir & ALI_File (1 .. Last));
1077
1078                               --  And we are done
1079
1080                               exit Switch_Loop;
1081                            end if;
1082                         end;
1083
1084                         --  Go to the project being extended, if any
1085
1086                         Prj := Prj.Extends;
1087                         exit Project_Loop when Prj = No_Project;
1088                      end loop Project_Loop;
1089                   end if;
1090                end if;
1091             end;
1092          end if;
1093       end loop Switch_Loop;
1094
1095       --  If a relative path output file has been specified, we add the exec
1096       --  directory.
1097
1098       for J in reverse 1 .. Last_Switches.Last - 1 loop
1099          if Last_Switches.Table (J).all = "-o" then
1100             Check_Relative_Executable
1101               (Name => Last_Switches.Table (J + 1));
1102             Look_For_Executable := False;
1103             exit;
1104          end if;
1105       end loop;
1106
1107       if Look_For_Executable then
1108          for J in reverse 1 .. First_Switches.Last - 1 loop
1109             if First_Switches.Table (J).all = "-o" then
1110                Look_For_Executable := False;
1111                Check_Relative_Executable
1112                  (Name => First_Switches.Table (J + 1));
1113                exit;
1114             end if;
1115          end loop;
1116       end if;
1117
1118       --  If no executable is specified, then find the name of the first ALI
1119       --  file on the command line and issue a -o switch with the absolute path
1120       --  of the executable in the exec directory.
1121
1122       if Look_For_Executable then
1123          for J in 1 .. Last_Switches.Last loop
1124             Arg  := Last_Switches.Table (J);
1125             Last := 0;
1126
1127             if Arg'Length /= 0 and then Arg (Arg'First) /= '-' then
1128                if Arg'Length > 4
1129                  and then Arg (Arg'Last - 3 .. Arg'Last) = ".ali"
1130                then
1131                   Last := Arg'Last - 4;
1132
1133                elsif Is_Regular_File (Arg.all & ".ali") then
1134                   Last := Arg'Last;
1135                end if;
1136
1137                if Last /= 0 then
1138                   Last_Switches.Increment_Last;
1139                   Last_Switches.Table (Last_Switches.Last) :=
1140                     new String'("-o");
1141                   Get_Name_String (Project.Exec_Directory.Name);
1142                   Last_Switches.Increment_Last;
1143                   Last_Switches.Table (Last_Switches.Last) :=
1144                     new String'(Name_Buffer (1 .. Name_Len) &
1145                                 Executable_Name
1146                                   (Base_Name (Arg (Arg'First .. Last))));
1147                   exit;
1148                end if;
1149             end if;
1150          end loop;
1151       end if;
1152    end Process_Link;
1153
1154    ---------------------
1155    -- Set_Library_For --
1156    ---------------------
1157
1158    procedure Set_Library_For
1159      (Project           : Project_Id;
1160       Libraries_Present : in out Boolean)
1161    is
1162       Path_Option : constant String_Access :=
1163                       MLib.Linker_Library_Path_Option;
1164
1165    begin
1166       --  Case of library project
1167
1168       if Project.Library then
1169          Libraries_Present := True;
1170
1171          --  Add the -L switch
1172
1173          Last_Switches.Increment_Last;
1174          Last_Switches.Table (Last_Switches.Last) :=
1175            new String'("-L" & Get_Name_String (Project.Library_Dir.Name));
1176
1177          --  Add the -l switch
1178
1179          Last_Switches.Increment_Last;
1180          Last_Switches.Table (Last_Switches.Last) :=
1181            new String'("-l" & Get_Name_String (Project.Library_Name));
1182
1183          --  Add the directory to table Library_Paths, to be processed later
1184          --  if library is not static and if Path_Option is not null.
1185
1186          if Project.Library_Kind /= Static
1187            and then Path_Option /= null
1188          then
1189             Library_Paths.Increment_Last;
1190             Library_Paths.Table (Library_Paths.Last) :=
1191               new String'(Get_Name_String (Project.Library_Dir.Name));
1192          end if;
1193       end if;
1194    end Set_Library_For;
1195
1196    ---------------------------
1197    -- Test_If_Relative_Path --
1198    ---------------------------
1199
1200    procedure Test_If_Relative_Path
1201      (Switch : in out String_Access;
1202       Parent : String)
1203    is
1204    begin
1205       Makeutl.Test_If_Relative_Path
1206         (Switch, Parent, Including_Non_Switch => False, Including_RTS => True);
1207    end Test_If_Relative_Path;
1208
1209    -------------------
1210    -- Non_VMS_Usage --
1211    -------------------
1212
1213    procedure Non_VMS_Usage is
1214    begin
1215       Output_Version;
1216       New_Line;
1217       Put_Line ("List of available commands");
1218       New_Line;
1219
1220       for C in Command_List'Range loop
1221          if not Command_List (C).VMS_Only then
1222             if Targparm.AAMP_On_Target then
1223                Put ("gnaampcmd ");
1224             else
1225                Put ("gnat ");
1226             end if;
1227
1228             Put (To_Lower (Command_List (C).Cname.all));
1229             Set_Col (25);
1230
1231             --  Never call gnatstack with a prefix
1232
1233             if C = Stack then
1234                Put (Command_List (C).Unixcmd.all);
1235             else
1236                Put (Program_Name (Command_List (C).Unixcmd.all, "gnat").all);
1237             end if;
1238
1239             declare
1240                Sws : Argument_List_Access renames Command_List (C).Unixsws;
1241             begin
1242                if Sws /= null then
1243                   for J in Sws'Range loop
1244                      Put (' ');
1245                      Put (Sws (J).all);
1246                   end loop;
1247                end if;
1248             end;
1249
1250             New_Line;
1251          end if;
1252       end loop;
1253
1254       New_Line;
1255       Put_Line ("Commands find, list, metric, pretty, stack, stub and xref " &
1256                 "accept project file switches -vPx, -Pprj and -Xnam=val");
1257       New_Line;
1258    end Non_VMS_Usage;
1259
1260    -------------------------------------
1261    -- Start of processing for GNATCmd --
1262    -------------------------------------
1263
1264 begin
1265    --  Initializations
1266
1267    Namet.Initialize;
1268    Csets.Initialize;
1269
1270    Snames.Initialize;
1271
1272    Project_Node_Tree := new Project_Node_Tree_Data;
1273    Prj.Tree.Initialize (Project_Node_Tree);
1274
1275    Prj.Initialize (Project_Tree);
1276
1277    Last_Switches.Init;
1278    Last_Switches.Set_Last (0);
1279
1280    First_Switches.Init;
1281    First_Switches.Set_Last (0);
1282    Carg_Switches.Init;
1283    Carg_Switches.Set_Last (0);
1284    Rules_Switches.Init;
1285    Rules_Switches.Set_Last (0);
1286
1287    VMS_Conv.Initialize;
1288
1289    --  Add the default search directories, to be able to find system.ads in the
1290    --  subsequent call to Targparm.Get_Target_Parameters.
1291
1292    Add_Default_Search_Dirs;
1293
1294    --  Get target parameters so that AAMP_On_Target will be set, for testing in
1295    --  Osint.Program_Name to handle the mapping of GNAAMP tool names.
1296
1297    Targparm.Get_Target_Parameters;
1298
1299    --  Add the directory where the GNAT driver is invoked in front of the path,
1300    --  if the GNAT driver is invoked with directory information. Do not do this
1301    --  for VMS, where the notion of path does not really exist.
1302
1303    if not OpenVMS then
1304       declare
1305          Command : constant String := Command_Name;
1306
1307       begin
1308          for Index in reverse Command'Range loop
1309             if Command (Index) = Directory_Separator then
1310                declare
1311                   Absolute_Dir : constant String :=
1312                                    Normalize_Pathname
1313                                      (Command (Command'First .. Index));
1314
1315                   PATH : constant String :=
1316                            Absolute_Dir & Path_Separator & Getenv ("PATH").all;
1317
1318                begin
1319                   Setenv ("PATH", PATH);
1320                end;
1321
1322                exit;
1323             end if;
1324          end loop;
1325       end;
1326    end if;
1327
1328    --  If on VMS, or if VMS emulation is on, convert VMS style /qualifiers,
1329    --  filenames and pathnames to Unix style.
1330
1331    if Hostparm.OpenVMS
1332      or else To_Lower (Getenv ("EMULATE_VMS").all) = "true"
1333    then
1334       VMS_Conversion (The_Command);
1335
1336       B_Start := new String'("b__");
1337
1338    --  If not on VMS, scan the command line directly
1339
1340    else
1341       if Argument_Count = 0 then
1342          Non_VMS_Usage;
1343          return;
1344       else
1345          begin
1346             loop
1347                if Argument_Count > Command_Arg
1348                  and then Argument (Command_Arg) = "-v"
1349                then
1350                   Verbose_Mode := True;
1351                   Command_Arg := Command_Arg + 1;
1352
1353                elsif Argument_Count > Command_Arg
1354                  and then Argument (Command_Arg) = "-dn"
1355                then
1356                   Keep_Temporary_Files := True;
1357                   Command_Arg := Command_Arg + 1;
1358
1359                else
1360                   exit;
1361                end if;
1362             end loop;
1363
1364             The_Command := Real_Command_Type'Value (Argument (Command_Arg));
1365
1366             if Command_List (The_Command).VMS_Only then
1367                Non_VMS_Usage;
1368                Fail
1369                  ("Command """
1370                   & Command_List (The_Command).Cname.all
1371                   & """ can only be used on VMS");
1372             end if;
1373
1374          exception
1375             when Constraint_Error =>
1376
1377                --  Check if it is an alternate command
1378
1379                declare
1380                   Alternate : Alternate_Command;
1381
1382                begin
1383                   Alternate := Alternate_Command'Value
1384                                               (Argument (Command_Arg));
1385                   The_Command := Corresponding_To (Alternate);
1386
1387                exception
1388                   when Constraint_Error =>
1389                      Non_VMS_Usage;
1390                      Fail ("Unknown command: " & Argument (Command_Arg));
1391                end;
1392          end;
1393
1394          --  Get the arguments from the command line and from the eventual
1395          --  argument file(s) specified on the command line.
1396
1397          for Arg in Command_Arg + 1 .. Argument_Count loop
1398             declare
1399                The_Arg : constant String := Argument (Arg);
1400
1401             begin
1402                --  Check if an argument file is specified
1403
1404                if The_Arg (The_Arg'First) = '@' then
1405                   declare
1406                      Arg_File : Ada.Text_IO.File_Type;
1407                      Line     : String (1 .. 256);
1408                      Last     : Natural;
1409
1410                   begin
1411                      --  Open the file and fail if the file cannot be found
1412
1413                      begin
1414                         Open
1415                           (Arg_File, In_File,
1416                            The_Arg (The_Arg'First + 1 .. The_Arg'Last));
1417
1418                      exception
1419                         when others =>
1420                            Put
1421                              (Standard_Error, "Cannot open argument file """);
1422                            Put
1423                              (Standard_Error,
1424                               The_Arg (The_Arg'First + 1 .. The_Arg'Last));
1425
1426                            Put_Line (Standard_Error, """");
1427                            raise Error_Exit;
1428                      end;
1429
1430                      --  Read line by line and put the content of each non-
1431                      --  empty line in the Last_Switches table.
1432
1433                      while not End_Of_File (Arg_File) loop
1434                         Get_Line (Arg_File, Line, Last);
1435
1436                         if Last /= 0 then
1437                            Last_Switches.Increment_Last;
1438                            Last_Switches.Table (Last_Switches.Last) :=
1439                              new String'(Line (1 .. Last));
1440                         end if;
1441                      end loop;
1442
1443                      Close (Arg_File);
1444                   end;
1445
1446                else
1447                   --  It is not an argument file; just put the argument in
1448                   --  the Last_Switches table.
1449
1450                   Last_Switches.Increment_Last;
1451                   Last_Switches.Table (Last_Switches.Last) :=
1452                     new String'(The_Arg);
1453                end if;
1454             end;
1455          end loop;
1456       end if;
1457    end if;
1458
1459    declare
1460       Program   : String_Access;
1461       Exec_Path : String_Access;
1462
1463    begin
1464       if The_Command = Stack then
1465
1466          --  Never call gnatstack with a prefix
1467
1468          Program := new String'(Command_List (The_Command).Unixcmd.all);
1469
1470       else
1471          Program :=
1472            Program_Name (Command_List (The_Command).Unixcmd.all, "gnat");
1473       end if;
1474
1475       --  Locate the executable for the command
1476
1477       Exec_Path := Locate_Exec_On_Path (Program.all);
1478
1479       if Exec_Path = null then
1480          Put_Line (Standard_Error, "could not locate " & Program.all);
1481          raise Error_Exit;
1482       end if;
1483
1484       --  If there are switches for the executable, put them as first switches
1485
1486       if Command_List (The_Command).Unixsws /= null then
1487          for J in Command_List (The_Command).Unixsws'Range loop
1488             First_Switches.Increment_Last;
1489             First_Switches.Table (First_Switches.Last) :=
1490               Command_List (The_Command).Unixsws (J);
1491          end loop;
1492       end if;
1493
1494       --  For BIND, CHECK, ELIM, FIND, LINK, LIST, METRIC, PRETTY, STACK, STUB,
1495       --  SYNC and XREF, look for project file related switches.
1496
1497       case The_Command is
1498          when Bind =>
1499             Tool_Package_Name := Name_Binder;
1500             Packages_To_Check := Packages_To_Check_By_Binder;
1501          when Check =>
1502             Tool_Package_Name := Name_Check;
1503             Packages_To_Check := Packages_To_Check_By_Check;
1504          when Elim =>
1505             Tool_Package_Name := Name_Eliminate;
1506             Packages_To_Check := Packages_To_Check_By_Eliminate;
1507          when Find =>
1508             Tool_Package_Name := Name_Finder;
1509             Packages_To_Check := Packages_To_Check_By_Finder;
1510          when Link =>
1511             Tool_Package_Name := Name_Linker;
1512             Packages_To_Check := Packages_To_Check_By_Linker;
1513          when List =>
1514             Tool_Package_Name := Name_Gnatls;
1515             Packages_To_Check := Packages_To_Check_By_Gnatls;
1516          when Metric =>
1517             Tool_Package_Name := Name_Metrics;
1518             Packages_To_Check := Packages_To_Check_By_Metric;
1519          when Pretty =>
1520             Tool_Package_Name := Name_Pretty_Printer;
1521             Packages_To_Check := Packages_To_Check_By_Pretty;
1522          when Stack =>
1523             Tool_Package_Name := Name_Stack;
1524             Packages_To_Check := Packages_To_Check_By_Stack;
1525          when Stub =>
1526             Tool_Package_Name := Name_Gnatstub;
1527             Packages_To_Check := Packages_To_Check_By_Gnatstub;
1528          when Sync =>
1529             Tool_Package_Name := Name_Synchronize;
1530             Packages_To_Check := Packages_To_Check_By_Sync;
1531          when Xref =>
1532             Tool_Package_Name := Name_Cross_Reference;
1533             Packages_To_Check := Packages_To_Check_By_Xref;
1534          when others =>
1535             Tool_Package_Name := No_Name;
1536       end case;
1537
1538       if Tool_Package_Name /= No_Name then
1539
1540          --  Check that the switches are consistent. Detect project file
1541          --  related switches.
1542
1543          Inspect_Switches : declare
1544             Arg_Num : Positive := 1;
1545             Argv    : String_Access;
1546
1547             procedure Remove_Switch (Num : Positive);
1548             --  Remove a project related switch from table Last_Switches
1549
1550             -------------------
1551             -- Remove_Switch --
1552             -------------------
1553
1554             procedure Remove_Switch (Num : Positive) is
1555             begin
1556                Last_Switches.Table (Num .. Last_Switches.Last - 1) :=
1557                  Last_Switches.Table (Num + 1 .. Last_Switches.Last);
1558                Last_Switches.Decrement_Last;
1559             end Remove_Switch;
1560
1561          --  Start of processing for Inspect_Switches
1562
1563          begin
1564             while Arg_Num <= Last_Switches.Last loop
1565                Argv := Last_Switches.Table (Arg_Num);
1566
1567                if Argv (Argv'First) = '-' then
1568                   if Argv'Length = 1 then
1569                      Fail
1570                        ("switch character cannot be followed by a blank");
1571                   end if;
1572
1573                   --  The two style project files (-p and -P) cannot be used
1574                   --  together
1575
1576                   if (The_Command = Find or else The_Command = Xref)
1577                     and then Argv (2) = 'p'
1578                   then
1579                      Old_Project_File_Used := True;
1580                      if Project_File /= null then
1581                         Fail ("-P and -p cannot be used together");
1582                      end if;
1583                   end if;
1584
1585                   --  --subdirs=... Specify Subdirs
1586
1587                   if Argv'Length > Makeutl.Subdirs_Option'Length and then
1588                     Argv
1589                      (Argv'First ..
1590                       Argv'First + Makeutl.Subdirs_Option'Length - 1) =
1591                         Makeutl.Subdirs_Option
1592                   then
1593                      Subdirs :=
1594                        new String'
1595                          (Argv
1596                            (Argv'First + Makeutl.Subdirs_Option'Length ..
1597                             Argv'Last));
1598
1599                      Remove_Switch (Arg_Num);
1600
1601                   --  -aPdir  Add dir to the project search path
1602
1603                   elsif Argv'Length > 3
1604                     and then Argv (Argv'First + 1 .. Argv'First + 2) = "aP"
1605                   then
1606                      Add_Search_Project_Directory
1607                        (Project_Node_Tree, Argv (Argv'First + 3 .. Argv'Last));
1608
1609                      Remove_Switch (Arg_Num);
1610
1611                   --  -eL  Follow links for files
1612
1613                   elsif Argv.all = "-eL" then
1614                      Follow_Links_For_Files := True;
1615                      Follow_Links_For_Dirs  := True;
1616
1617                      Remove_Switch (Arg_Num);
1618
1619                   --  -vPx  Specify verbosity while parsing project files
1620
1621                   elsif Argv'Length = 4
1622                     and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP"
1623                   then
1624                      case Argv (Argv'Last) is
1625                         when '0' =>
1626                            Current_Verbosity := Prj.Default;
1627                         when '1' =>
1628                            Current_Verbosity := Prj.Medium;
1629                         when '2' =>
1630                            Current_Verbosity := Prj.High;
1631                         when others =>
1632                            Fail ("Invalid switch: " & Argv.all);
1633                      end case;
1634
1635                      Remove_Switch (Arg_Num);
1636
1637                   --  -Pproject_file  Specify project file to be used
1638
1639                   elsif Argv (Argv'First + 1) = 'P' then
1640
1641                      --  Only one -P switch can be used
1642
1643                      if Project_File /= null then
1644                         Fail
1645                           (Argv.all
1646                            & ": second project file forbidden (first is """
1647                            & Project_File.all
1648                            & """)");
1649
1650                      --  The two style project files (-p and -P) cannot be
1651                      --  used together.
1652
1653                      elsif Old_Project_File_Used then
1654                         Fail ("-p and -P cannot be used together");
1655
1656                      elsif Argv'Length = 2 then
1657
1658                         --  There is space between -P and the project file
1659                         --  name. -P cannot be the last option.
1660
1661                         if Arg_Num = Last_Switches.Last then
1662                            Fail ("project file name missing after -P");
1663
1664                         else
1665                            Remove_Switch (Arg_Num);
1666                            Argv := Last_Switches.Table (Arg_Num);
1667
1668                            --  After -P, there must be a project file name,
1669                            --  not another switch.
1670
1671                            if Argv (Argv'First) = '-' then
1672                               Fail ("project file name missing after -P");
1673
1674                            else
1675                               Project_File := new String'(Argv.all);
1676                            end if;
1677                         end if;
1678
1679                      else
1680                         --  No space between -P and project file name
1681
1682                         Project_File :=
1683                           new String'(Argv (Argv'First + 2 .. Argv'Last));
1684                      end if;
1685
1686                      Remove_Switch (Arg_Num);
1687
1688                   --  -Xexternal=value Specify an external reference to be
1689                   --                   used in project files
1690
1691                   elsif Argv'Length >= 5
1692                     and then Argv (Argv'First + 1) = 'X'
1693                   then
1694                      declare
1695                         Equal_Pos : constant Natural :=
1696                                       Index
1697                                         ('=',
1698                                          Argv (Argv'First + 2 .. Argv'Last));
1699                      begin
1700                         if Equal_Pos >= Argv'First + 3 and then
1701                           Equal_Pos /= Argv'Last then
1702                            Add (Project_Node_Tree,
1703                                 External_Name =>
1704                                   Argv (Argv'First + 2 .. Equal_Pos - 1),
1705                                 Value => Argv (Equal_Pos + 1 .. Argv'Last));
1706                         else
1707                            Fail
1708                              (Argv.all
1709                               & " is not a valid external assignment.");
1710                         end if;
1711                      end;
1712
1713                      Remove_Switch (Arg_Num);
1714
1715                   elsif
1716                     (The_Command = Check  or else
1717                      The_Command = Sync   or else
1718                      The_Command = Pretty or else
1719                      The_Command = Metric or else
1720                      The_Command = Stack  or else
1721                      The_Command = List)
1722                     and then Argv'Length = 2
1723                     and then Argv (2) = 'U'
1724                   then
1725                      All_Projects := True;
1726                      Remove_Switch (Arg_Num);
1727
1728                   else
1729                      Arg_Num := Arg_Num + 1;
1730                   end if;
1731
1732                elsif ((The_Command = Check and then Argv (Argv'First) /= '+')
1733                         or else The_Command = Sync
1734                         or else The_Command = Metric
1735                         or else The_Command = Pretty)
1736                  and then Project_File /= null
1737                  and then All_Projects
1738                then
1739                   if ASIS_Main /= null then
1740                      Fail ("cannot specify more than one main after -U");
1741                   else
1742                      ASIS_Main := Argv;
1743                      Remove_Switch (Arg_Num);
1744                   end if;
1745
1746                else
1747                   Arg_Num := Arg_Num + 1;
1748                end if;
1749             end loop;
1750          end Inspect_Switches;
1751       end if;
1752
1753       --  If there is a project file specified, parse it, get the switches
1754       --  for the tool and setup PATH environment variables.
1755
1756       if Project_File /= null then
1757          Prj.Pars.Set_Verbosity (To => Current_Verbosity);
1758
1759          Prj.Pars.Parse
1760            (Project           => Project,
1761             In_Tree           => Project_Tree,
1762             In_Node_Tree      => Project_Node_Tree,
1763             Project_File_Name => Project_File.all,
1764             Flags             => Gnatmake_Flags,
1765             Packages_To_Check => Packages_To_Check);
1766
1767          if Project = Prj.No_Project then
1768             Fail ("""" & Project_File.all & """ processing failed");
1769          end if;
1770
1771          --  Check if a package with the name of the tool is in the project
1772          --  file and if there is one, get the switches, if any, and scan them.
1773
1774          declare
1775             Pkg : constant Prj.Package_Id :=
1776                     Prj.Util.Value_Of
1777                       (Name        => Tool_Package_Name,
1778                        In_Packages => Project.Decl.Packages,
1779                        In_Tree     => Project_Tree);
1780
1781             Element : Package_Element;
1782
1783             Default_Switches_Array : Array_Element_Id;
1784
1785             The_Switches : Prj.Variable_Value;
1786             Current      : Prj.String_List_Id;
1787             The_String   : String_Element;
1788
1789          begin
1790             if Pkg /= No_Package then
1791                Element := Project_Tree.Packages.Table (Pkg);
1792
1793                --  Packages Gnatls and Gnatstack have a single attribute
1794                --  Switches, that is not an associative array.
1795
1796                if The_Command = List or else The_Command = Stack then
1797                   The_Switches :=
1798                     Prj.Util.Value_Of
1799                     (Variable_Name => Snames.Name_Switches,
1800                      In_Variables  => Element.Decl.Attributes,
1801                      In_Tree       => Project_Tree);
1802
1803                --  Packages Binder (for gnatbind), Cross_Reference (for
1804                --  gnatxref), Linker (for gnatlink), Finder (for gnatfind),
1805                --  Pretty_Printer (for gnatpp), Eliminate (for gnatelim), Check
1806                --  (for gnatcheck), and Metric (for gnatmetric) have an
1807                --  attributed Switches, an associative array, indexed by the
1808                --  name of the file.
1809
1810                --  They also have an attribute Default_Switches, indexed by the
1811                --  name of the programming language.
1812
1813                else
1814                   if The_Switches.Kind = Prj.Undefined then
1815                      Default_Switches_Array :=
1816                        Prj.Util.Value_Of
1817                          (Name      => Name_Default_Switches,
1818                           In_Arrays => Element.Decl.Arrays,
1819                           In_Tree   => Project_Tree);
1820                      The_Switches := Prj.Util.Value_Of
1821                        (Index     => Name_Ada,
1822                         Src_Index => 0,
1823                         In_Array  => Default_Switches_Array,
1824                         In_Tree   => Project_Tree);
1825                   end if;
1826                end if;
1827
1828                --  If there are switches specified in the package of the
1829                --  project file corresponding to the tool, scan them.
1830
1831                case The_Switches.Kind is
1832                   when Prj.Undefined =>
1833                      null;
1834
1835                   when Prj.Single =>
1836                      declare
1837                         Switch : constant String :=
1838                                    Get_Name_String (The_Switches.Value);
1839
1840                      begin
1841                         if Switch'Length > 0 then
1842                            First_Switches.Increment_Last;
1843                            First_Switches.Table (First_Switches.Last) :=
1844                              new String'(Switch);
1845                         end if;
1846                      end;
1847
1848                   when Prj.List =>
1849                      Current := The_Switches.Values;
1850                      while Current /= Prj.Nil_String loop
1851                         The_String := Project_Tree.String_Elements.
1852                                         Table (Current);
1853
1854                         declare
1855                            Switch : constant String :=
1856                              Get_Name_String (The_String.Value);
1857
1858                         begin
1859                            if Switch'Length > 0 then
1860                               First_Switches.Increment_Last;
1861                               First_Switches.Table (First_Switches.Last) :=
1862                                 new String'(Switch);
1863                            end if;
1864                         end;
1865
1866                         Current := The_String.Next;
1867                      end loop;
1868                end case;
1869             end if;
1870          end;
1871
1872          if The_Command = Bind
1873            or else The_Command = Link
1874            or else The_Command = Elim
1875          then
1876             Change_Dir (Get_Name_String (Project.Object_Directory.Name));
1877          end if;
1878
1879          --  Set up the env vars for project path files
1880
1881          Prj.Env.Set_Ada_Paths
1882            (Project, Project_Tree, Including_Libraries => False);
1883
1884          --  For gnatcheck, gnatstub, gnatmetric, gnatpp and gnatelim, create
1885          --  a configuration pragmas file, if necessary.
1886
1887          if The_Command = Pretty
1888            or else The_Command = Metric
1889            or else The_Command = Stub
1890            or else The_Command = Elim
1891            or else The_Command = Check
1892            or else The_Command = Sync
1893          then
1894             --  If there are switches in package Compiler, put them in the
1895             --  Carg_Switches table.
1896
1897             declare
1898                Pkg  : constant Prj.Package_Id :=
1899                         Prj.Util.Value_Of
1900                           (Name        => Name_Compiler,
1901                            In_Packages => Project.Decl.Packages,
1902                            In_Tree     => Project_Tree);
1903
1904                Element : Package_Element;
1905
1906                Switches_Array : Array_Element_Id;
1907
1908                The_Switches : Prj.Variable_Value;
1909                Current      : Prj.String_List_Id;
1910                The_String   : String_Element;
1911
1912                Main    : String_Access := null;
1913                Main_Id : Name_Id;
1914
1915             begin
1916                if Pkg /= No_Package then
1917
1918                   --  First, check if there is a single main specified.
1919
1920                   for J in 1  .. Last_Switches.Last loop
1921                      if Last_Switches.Table (J) (1) /= '-' then
1922                         if Main = null then
1923                            Main := Last_Switches.Table (J);
1924
1925                         else
1926                            Main := null;
1927                            exit;
1928                         end if;
1929                      end if;
1930                   end loop;
1931
1932                   Element := Project_Tree.Packages.Table (Pkg);
1933
1934                   --  If there is a single main and there is compilation
1935                   --  switches specified in the project file, use them.
1936
1937                   if Main /= null and then not All_Projects then
1938                      Name_Len := Main'Length;
1939                      Name_Buffer (1 .. Name_Len) := Main.all;
1940                      Canonical_Case_File_Name (Name_Buffer (1 .. Name_Len));
1941                      Main_Id := Name_Find;
1942
1943                      Switches_Array :=
1944                        Prj.Util.Value_Of
1945                          (Name      => Name_Switches,
1946                           In_Arrays => Element.Decl.Arrays,
1947                           In_Tree   => Project_Tree);
1948                      The_Switches := Prj.Util.Value_Of
1949                        (Index     => Main_Id,
1950                         Src_Index => 0,
1951                         In_Array  => Switches_Array,
1952                         In_Tree   => Project_Tree);
1953                   end if;
1954
1955                   --  Otherwise, get the Default_Switches ("Ada")
1956
1957                   if The_Switches.Kind = Undefined then
1958                      Switches_Array :=
1959                        Prj.Util.Value_Of
1960                          (Name      => Name_Default_Switches,
1961                           In_Arrays => Element.Decl.Arrays,
1962                           In_Tree   => Project_Tree);
1963                      The_Switches := Prj.Util.Value_Of
1964                        (Index     => Name_Ada,
1965                         Src_Index => 0,
1966                         In_Array  => Switches_Array,
1967                         In_Tree   => Project_Tree);
1968                   end if;
1969
1970                   --  If there are switches specified, put them in the
1971                   --  Carg_Switches table.
1972
1973                   case The_Switches.Kind is
1974                      when Prj.Undefined =>
1975                         null;
1976
1977                      when Prj.Single =>
1978                         declare
1979                            Switch : constant String :=
1980                                       Get_Name_String (The_Switches.Value);
1981                         begin
1982                            if Switch'Length > 0 then
1983                               Add_To_Carg_Switches (new String'(Switch));
1984                            end if;
1985                         end;
1986
1987                      when Prj.List =>
1988                         Current := The_Switches.Values;
1989                         while Current /= Prj.Nil_String loop
1990                            The_String :=
1991                              Project_Tree.String_Elements.Table (Current);
1992
1993                            declare
1994                               Switch : constant String :=
1995                                          Get_Name_String (The_String.Value);
1996                            begin
1997                               if Switch'Length > 0 then
1998                                  Add_To_Carg_Switches (new String'(Switch));
1999                               end if;
2000                            end;
2001
2002                            Current := The_String.Next;
2003                         end loop;
2004                   end case;
2005                end if;
2006             end;
2007
2008             --  If -cargs is one of the switches, move the following switches
2009             --  to the Carg_Switches table.
2010
2011             for J in 1 .. First_Switches.Last loop
2012                if First_Switches.Table (J).all = "-cargs" then
2013                   declare
2014                      K    : Positive;
2015                      Last : Natural;
2016
2017                   begin
2018                      --  Move the switches that are before -rules when the
2019                      --  command is CHECK.
2020
2021                      K := J + 1;
2022                      while K <= First_Switches.Last
2023                        and then
2024                         (The_Command /= Check
2025                            or else First_Switches.Table (K).all /= "-rules")
2026                      loop
2027                         Add_To_Carg_Switches (First_Switches.Table (K));
2028                         K := K + 1;
2029                      end loop;
2030
2031                      if K > First_Switches.Last then
2032                         First_Switches.Set_Last (J - 1);
2033
2034                      else
2035                         Last := J - 1;
2036                         while K <= First_Switches.Last loop
2037                            Last := Last + 1;
2038                            First_Switches.Table (Last) :=
2039                              First_Switches.Table (K);
2040                            K := K + 1;
2041                         end loop;
2042
2043                         First_Switches.Set_Last (Last);
2044                      end if;
2045                   end;
2046
2047                   exit;
2048                end if;
2049             end loop;
2050
2051             for J in 1 .. Last_Switches.Last loop
2052                if Last_Switches.Table (J).all = "-cargs" then
2053                   declare
2054                      K    : Positive;
2055                      Last : Natural;
2056
2057                   begin
2058                      --  Move the switches that are before -rules when the
2059                      --  command is CHECK.
2060
2061                      K := J + 1;
2062                      while K <= Last_Switches.Last
2063                        and then
2064                         (The_Command /= Check
2065                          or else
2066                          Last_Switches.Table (K).all /= "-rules")
2067                      loop
2068                         Add_To_Carg_Switches (Last_Switches.Table (K));
2069                         K := K + 1;
2070                      end loop;
2071
2072                      if K > Last_Switches.Last then
2073                         Last_Switches.Set_Last (J - 1);
2074
2075                      else
2076                         Last := J - 1;
2077                         while K <= Last_Switches.Last loop
2078                            Last := Last + 1;
2079                            Last_Switches.Table (Last) :=
2080                              Last_Switches.Table (K);
2081                            K := K + 1;
2082                         end loop;
2083
2084                         Last_Switches.Set_Last (Last);
2085                      end if;
2086                   end;
2087
2088                   exit;
2089                end if;
2090             end loop;
2091
2092             declare
2093                CP_File : constant Path_Name_Type := Configuration_Pragmas_File;
2094
2095             begin
2096                if CP_File /= No_Path then
2097                   if The_Command = Elim then
2098                      First_Switches.Increment_Last;
2099                      First_Switches.Table (First_Switches.Last)  :=
2100                        new String'("-C" & Get_Name_String (CP_File));
2101
2102                   else
2103                      Add_To_Carg_Switches
2104                        (new String'("-gnatec=" & Get_Name_String (CP_File)));
2105                   end if;
2106                end if;
2107             end;
2108          end if;
2109
2110          if The_Command = Link then
2111             Process_Link;
2112          end if;
2113
2114          if The_Command = Link or else The_Command = Bind then
2115
2116             --  For files that are specified as relative paths with directory
2117             --  information, we convert them to absolute paths, with parent
2118             --  being the current working directory if specified on the command
2119             --  line and the project directory if specified in the project
2120             --  file. This is what gnatmake is doing for linker and binder
2121             --  arguments.
2122
2123             for J in 1 .. Last_Switches.Last loop
2124                GNATCmd.Test_If_Relative_Path
2125                  (Last_Switches.Table (J), Current_Work_Dir);
2126             end loop;
2127
2128             Get_Name_String (Project.Directory.Name);
2129
2130             declare
2131                Project_Dir : constant String := Name_Buffer (1 .. Name_Len);
2132             begin
2133                for J in 1 .. First_Switches.Last loop
2134                   GNATCmd.Test_If_Relative_Path
2135                     (First_Switches.Table (J), Project_Dir);
2136                end loop;
2137             end;
2138
2139          elsif The_Command = Stub then
2140             declare
2141                File_Index : Integer := 0;
2142                Dir_Index  : Integer := 0;
2143                Last       : constant Integer := Last_Switches.Last;
2144                Lang       : constant Language_Ptr :=
2145                               Get_Language_From_Name (Project, "ada");
2146
2147             begin
2148                for Index in 1 .. Last loop
2149                   if Last_Switches.Table (Index)
2150                     (Last_Switches.Table (Index)'First) /= '-'
2151                   then
2152                      File_Index := Index;
2153                      exit;
2154                   end if;
2155                end loop;
2156
2157                --  If the project file naming scheme is not standard, and if
2158                --  the file name ends with the spec suffix, then indicate to
2159                --  gnatstub the name of the body file with a -o switch.
2160
2161                if not Is_Standard_GNAT_Naming (Lang.Config.Naming_Data) then
2162                   if File_Index /= 0 then
2163                      declare
2164                         Spec : constant String :=
2165                                  Base_Name
2166                                    (Last_Switches.Table (File_Index).all);
2167                         Last : Natural := Spec'Last;
2168
2169                      begin
2170                         Get_Name_String (Lang.Config.Naming_Data.Spec_Suffix);
2171
2172                         if Spec'Length > Name_Len
2173                           and then Spec (Last - Name_Len + 1 .. Last) =
2174                                                   Name_Buffer (1 .. Name_Len)
2175                         then
2176                            Last := Last - Name_Len;
2177                            Get_Name_String
2178                              (Lang.Config.Naming_Data.Body_Suffix);
2179                            Last_Switches.Increment_Last;
2180                            Last_Switches.Table (Last_Switches.Last) :=
2181                              new String'("-o");
2182                            Last_Switches.Increment_Last;
2183                            Last_Switches.Table (Last_Switches.Last) :=
2184                              new String'(Spec (Spec'First .. Last) &
2185                                            Name_Buffer (1 .. Name_Len));
2186                         end if;
2187                      end;
2188                   end if;
2189                end if;
2190
2191                --  Add the directory of the spec as the destination directory
2192                --  of the body, if there is no destination directory already
2193                --  specified.
2194
2195                if File_Index /= 0 then
2196                   for Index in File_Index + 1 .. Last loop
2197                      if Last_Switches.Table (Index)
2198                          (Last_Switches.Table (Index)'First) /= '-'
2199                      then
2200                         Dir_Index := Index;
2201                         exit;
2202                      end if;
2203                   end loop;
2204
2205                   if Dir_Index = 0 then
2206                      Last_Switches.Increment_Last;
2207                      Last_Switches.Table (Last_Switches.Last) :=
2208                        new String'
2209                              (Dir_Name (Last_Switches.Table (File_Index).all));
2210                   end if;
2211                end if;
2212             end;
2213          end if;
2214
2215          --  For gnatmetric, the generated files should be put in the object
2216          --  directory. This must be the first switch, because it may be
2217          --  overridden by a switch in package Metrics in the project file or
2218          --  by a command line option. Note that we don't add the -d= switch
2219          --  if there is no object directory available.
2220
2221          if The_Command = Metric
2222            and then Project.Object_Directory /= No_Path_Information
2223          then
2224             First_Switches.Increment_Last;
2225             First_Switches.Table (2 .. First_Switches.Last) :=
2226               First_Switches.Table (1 .. First_Switches.Last - 1);
2227             First_Switches.Table (1) :=
2228               new String'("-d=" &
2229                           Get_Name_String (Project.Object_Directory.Name));
2230          end if;
2231
2232          --  For gnat check, -rules and the following switches need to be the
2233          --  last options, so move all these switches to table Rules_Switches.
2234
2235          if The_Command = Check then
2236             declare
2237                New_Last : Natural;
2238                --  Set to rank of options preceding "-rules"
2239
2240                In_Rules_Switches : Boolean;
2241                --  Set to True when options "-rules" is found
2242
2243             begin
2244                New_Last := First_Switches.Last;
2245                In_Rules_Switches := False;
2246
2247                for J in 1 .. First_Switches.Last loop
2248                   if In_Rules_Switches then
2249                      Add_To_Rules_Switches (First_Switches.Table (J));
2250
2251                   elsif First_Switches.Table (J).all = "-rules" then
2252                      New_Last := J - 1;
2253                      In_Rules_Switches := True;
2254                   end if;
2255                end loop;
2256
2257                if In_Rules_Switches then
2258                   First_Switches.Set_Last (New_Last);
2259                end if;
2260
2261                New_Last := Last_Switches.Last;
2262                In_Rules_Switches := False;
2263
2264                for J in 1 .. Last_Switches.Last loop
2265                   if In_Rules_Switches then
2266                      Add_To_Rules_Switches (Last_Switches.Table (J));
2267
2268                   elsif Last_Switches.Table (J).all = "-rules" then
2269                      New_Last := J - 1;
2270                      In_Rules_Switches := True;
2271                   end if;
2272                end loop;
2273
2274                if In_Rules_Switches then
2275                   Last_Switches.Set_Last (New_Last);
2276                end if;
2277             end;
2278          end if;
2279
2280          --  For gnat check, sync, metric or pretty with -U + a main, get the
2281          --  list of sources from the closure and add them to the arguments.
2282
2283          if ASIS_Main /= null then
2284             Get_Closure;
2285
2286             --  On VMS, set up the env var again for source dirs file. This is
2287             --  because the call to gnatmake has set this env var to another
2288             --  file that has now been deleted.
2289
2290             if Hostparm.OpenVMS then
2291
2292                --  First make sure that the recorded file names are empty
2293
2294                Prj.Env.Initialize (Project_Tree);
2295
2296                Prj.Env.Set_Ada_Paths
2297                  (Project, Project_Tree, Including_Libraries => False);
2298             end if;
2299
2300          --  For gnat check, gnat sync, gnat pretty, gnat metric, gnat list,
2301          --  and gnat stack, if no file has been put on the command line, call
2302          --  tool with all the sources of the main project.
2303
2304          elsif The_Command = Check  or else
2305                The_Command = Sync   or else
2306                The_Command = Pretty or else
2307                The_Command = Metric or else
2308                The_Command = List   or else
2309                The_Command = Stack
2310          then
2311             Check_Files;
2312          end if;
2313       end if;
2314
2315       --  Gather all the arguments and invoke the executable
2316
2317       declare
2318          The_Args : Argument_List
2319                       (1 .. First_Switches.Last +
2320                             Last_Switches.Last +
2321                             Carg_Switches.Last +
2322                             Rules_Switches.Last);
2323          Arg_Num  : Natural := 0;
2324
2325       begin
2326          for J in 1 .. First_Switches.Last loop
2327             Arg_Num := Arg_Num + 1;
2328             The_Args (Arg_Num) := First_Switches.Table (J);
2329          end loop;
2330
2331          for J in 1 .. Last_Switches.Last loop
2332             Arg_Num := Arg_Num + 1;
2333             The_Args (Arg_Num) := Last_Switches.Table (J);
2334          end loop;
2335
2336          for J in 1 .. Carg_Switches.Last loop
2337             Arg_Num := Arg_Num + 1;
2338             The_Args (Arg_Num) := Carg_Switches.Table (J);
2339          end loop;
2340
2341          for J in 1 .. Rules_Switches.Last loop
2342             Arg_Num := Arg_Num + 1;
2343             The_Args (Arg_Num) := Rules_Switches.Table (J);
2344          end loop;
2345
2346          --  If Display_Command is on, only display the generated command
2347
2348          if Display_Command then
2349             Put (Standard_Error, "generated command -->");
2350             Put (Standard_Error, Exec_Path.all);
2351
2352             for Arg in The_Args'Range loop
2353                Put (Standard_Error, " ");
2354                Put (Standard_Error, The_Args (Arg).all);
2355             end loop;
2356
2357             Put (Standard_Error, "<--");
2358             New_Line (Standard_Error);
2359             raise Normal_Exit;
2360          end if;
2361
2362          if Verbose_Mode then
2363             Output.Write_Str (Exec_Path.all);
2364
2365             for Arg in The_Args'Range loop
2366                Output.Write_Char (' ');
2367                Output.Write_Str (The_Args (Arg).all);
2368             end loop;
2369
2370             Output.Write_Eol;
2371          end if;
2372
2373          My_Exit_Status :=
2374            Exit_Status (Spawn (Exec_Path.all, The_Args));
2375          raise Normal_Exit;
2376       end;
2377    end;
2378
2379 exception
2380    when Error_Exit =>
2381       if not Keep_Temporary_Files then
2382          Prj.Delete_All_Temp_Files (Project_Tree);
2383          Delete_Temp_Config_Files;
2384       end if;
2385
2386       Set_Exit_Status (Failure);
2387
2388    when Normal_Exit =>
2389       if not Keep_Temporary_Files then
2390          Prj.Delete_All_Temp_Files (Project_Tree);
2391          Delete_Temp_Config_Files;
2392       end if;
2393
2394       --  Since GNATCmd is normally called from DCL (the VMS shell), it must
2395       --  return an understandable VMS exit status. However the exit status
2396       --  returned *to* GNATCmd is a Posix style code, so we test it and return
2397       --  just a simple success or failure on VMS.
2398
2399       if Hostparm.OpenVMS and then My_Exit_Status /= Success then
2400          Set_Exit_Status (Failure);
2401       else
2402          Set_Exit_Status (My_Exit_Status);
2403       end if;
2404 end GNATCmd;