gcc/ada/gnatcmd.adb

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