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