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