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