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