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-2018, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Gnatvsn;
  27 with Namet;    use Namet;
  28 with Opt;      use Opt;
  29 with Osint;    use Osint;
  30 with Output;   use Output;
  31 with Switch;   use Switch;
  32 with Table;
  33
  34 with Ada.Characters.Handling; use Ada.Characters.Handling;
  35 with Ada.Command_Line;        use Ada.Command_Line;
  36 with Ada.Text_IO;             use Ada.Text_IO;
  37
  38 with GNAT.OS_Lib;               use GNAT.OS_Lib;
  39
  40 procedure GNATCmd is
  41    Gprbuild : constant String := "gprbuild";
  42    Gprclean : constant String := "gprclean";
  43    Gprname  : constant String := "gprname";
  44    Gprls    : constant String := "gprls";
  45
  46    Error_Exit : exception;
  47    --  Raise this exception if error detected
  48
  49    type Command_Type is
  50      (Bind,
  51       Chop,
  52       Clean,
  53       Compile,
  54       Check,
  55       Elim,
  56       Find,
  57       Krunch,
  58       Link,
  59       List,
  60       Make,
  61       Metric,
  62       Name,
  63       Preprocess,
  64       Pretty,
  65       Stack,
  66       Stub,
  67       Test,
  68       Xref,
  69       Undefined);
  70
  71    subtype Real_Command_Type is Command_Type range Bind .. Xref;
  72    --  All real command types (excludes only Undefined).
  73
  74    type Alternate_Command is (Comp, Ls, Kr, Pp, Prep);
  75    --  Alternate command label
  76
  77    Corresponding_To : constant array (Alternate_Command) of Command_Type :=
  78      (Comp  => Compile,
  79       Ls    => List,
  80       Kr    => Krunch,
  81       Prep  => Preprocess,
  82       Pp    => Pretty);
  83    --  Mapping of alternate commands to commands
  84
  85    package First_Switches is new Table.Table
  86      (Table_Component_Type => String_Access,
  87       Table_Index_Type     => Integer,
  88       Table_Low_Bound      => 1,
  89       Table_Initial        => 20,
  90       Table_Increment      => 100,
  91       Table_Name           => "Gnatcmd.First_Switches");
  92    --  A table to keep the switches from the project file
  93
  94    package Last_Switches is new Table.Table
  95      (Table_Component_Type => String_Access,
  96       Table_Index_Type     => Integer,
  97       Table_Low_Bound      => 1,
  98       Table_Initial        => 20,
  99       Table_Increment      => 100,
 100       Table_Name           => "Gnatcmd.Last_Switches");
 101
 102    ----------------------------------
 103    -- Declarations for GNATCMD use --
 104    ----------------------------------
 105
 106    The_Command : Command_Type;
 107    --  The command specified in the invocation of the GNAT driver
 108
 109    Command_Arg : Positive := 1;
 110    --  The index of the command in the arguments of the GNAT driver
 111
 112    My_Exit_Status : Exit_Status := Success;
 113    --  The exit status of the spawned tool
 114
 115    type Command_Entry is record
 116       Cname : String_Access;
 117       --  Command name for GNAT xxx command
 118
 119       Unixcmd : String_Access;
 120       --  Corresponding Unix command
 121
 122       Unixsws : Argument_List_Access;
 123       --  List of switches to be used with the Unix command
 124    end record;
 125
 126    Command_List : constant array (Real_Command_Type) of Command_Entry :=
 127      (Bind =>
 128         (Cname    => new String'("BIND"),
 129          Unixcmd  => new String'("gnatbind"),
 130          Unixsws  => null),
 131
 132       Chop =>
 133         (Cname    => new String'("CHOP"),
 134          Unixcmd  => new String'("gnatchop"),
 135          Unixsws  => null),
 136
 137       Clean =>
 138         (Cname    => new String'("CLEAN"),
 139          Unixcmd  => new String'("gnatclean"),
 140          Unixsws  => null),
 141
 142       Compile =>
 143         (Cname    => new String'("COMPILE"),
 144          Unixcmd  => new String'("gnatmake"),
 145          Unixsws  => new Argument_List'(1 => new String'("-f"),
 146                                         2 => new String'("-u"),
 147                                         3 => new String'("-c"))),
 148
 149       Check =>
 150         (Cname    => new String'("CHECK"),
 151          Unixcmd  => new String'("gnatcheck"),
 152          Unixsws  => null),
 153
 154       Elim =>
 155         (Cname    => new String'("ELIM"),
 156          Unixcmd  => new String'("gnatelim"),
 157          Unixsws  => null),
 158
 159       Find =>
 160         (Cname    => new String'("FIND"),
 161          Unixcmd  => new String'("gnatfind"),
 162          Unixsws  => null),
 163
 164       Krunch =>
 165         (Cname    => new String'("KRUNCH"),
 166          Unixcmd  => new String'("gnatkr"),
 167          Unixsws  => null),
 168
 169       Link =>
 170         (Cname    => new String'("LINK"),
 171          Unixcmd  => new String'("gnatlink"),
 172          Unixsws  => null),
 173
 174       List =>
 175         (Cname    => new String'("LIST"),
 176          Unixcmd  => new String'("gnatls"),
 177          Unixsws  => null),
 178
 179       Make =>
 180         (Cname    => new String'("MAKE"),
 181          Unixcmd  => new String'("gnatmake"),
 182          Unixsws  => null),
 183
 184       Metric =>
 185         (Cname    => new String'("METRIC"),
 186          Unixcmd  => new String'("gnatmetric"),
 187          Unixsws  => null),
 188
 189       Name =>
 190         (Cname    => new String'("NAME"),
 191          Unixcmd  => new String'("gnatname"),
 192          Unixsws  => null),
 193
 194       Preprocess =>
 195         (Cname    => new String'("PREPROCESS"),
 196          Unixcmd  => new String'("gnatprep"),
 197          Unixsws  => null),
 198
 199       Pretty =>
 200         (Cname    => new String'("PRETTY"),
 201          Unixcmd  => new String'("gnatpp"),
 202          Unixsws  => null),
 203
 204       Stack =>
 205         (Cname    => new String'("STACK"),
 206          Unixcmd  => new String'("gnatstack"),
 207          Unixsws  => null),
 208
 209       Stub =>
 210         (Cname    => new String'("STUB"),
 211          Unixcmd  => new String'("gnatstub"),
 212          Unixsws  => null),
 213
 214       Test =>
 215         (Cname    => new String'("TEST"),
 216          Unixcmd  => new String'("gnattest"),
 217          Unixsws  => null),
 218
 219       Xref =>
 220         (Cname    => new String'("XREF"),
 221          Unixcmd  => new String'("gnatxref"),
 222          Unixsws  => null)
 223      );
 224
 225    -----------------------
 226    -- Local Subprograms --
 227    -----------------------
 228
 229    procedure Output_Version;
 230    --  Output the version of this program
 231
 232    procedure Usage;
 233    --  Display usage
 234
 235    --------------------
 236    -- Output_Version --
 237    --------------------
 238
 239    procedure Output_Version is
 240    begin
 241       Put ("GNAT ");
 242       Put_Line (Gnatvsn.Gnat_Version_String);
 243       Put_Line ("Copyright 1996-" & Gnatvsn.Current_Year
 244                 & ", Free Software Foundation, Inc.");
 245    end Output_Version;
 246
 247    -----------
 248    -- Usage --
 249    -----------
 250
 251    procedure Usage is
 252    begin
 253       Output_Version;
 254       New_Line;
 255       Put_Line ("List of available commands");
 256       New_Line;
 257
 258       for C in Command_List'Range loop
 259          Put ("gnat ");
 260          Put (To_Lower (Command_List (C).Cname.all));
 261          Set_Col (25);
 262          Put (Program_Name (Command_List (C).Unixcmd.all, "gnat").all);
 263
 264          declare
 265             Sws : Argument_List_Access renames Command_List (C).Unixsws;
 266          begin
 267             if Sws /= null then
 268                for J in Sws'Range loop
 269                   Put (' ');
 270                   Put (Sws (J).all);
 271                end loop;
 272             end if;
 273          end;
 274
 275          New_Line;
 276       end loop;
 277
 278       New_Line;
 279    end Usage;
 280
 281    procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage);
 282
 283 --  Start of processing for GNATCmd
 284
 285 begin
 286    --  All output from GNATCmd is debugging or error output: send to stderr
 287
 288    Set_Standard_Error;
 289
 290    --  Initializations
 291
 292    Last_Switches.Init;
 293    Last_Switches.Set_Last (0);
 294
 295    First_Switches.Init;
 296    First_Switches.Set_Last (0);
 297
 298    --  Put the command line in environment variable GNAT_DRIVER_COMMAND_LINE,
 299    --  so that the spawned tool may know the way the GNAT driver was invoked.
 300
 301    Name_Len := 0;
 302    Add_Str_To_Name_Buffer (Command_Name);
 303
 304    for J in 1 .. Argument_Count loop
 305       Add_Char_To_Name_Buffer (' ');
 306       Add_Str_To_Name_Buffer (Argument (J));
 307    end loop;
 308
 309    Setenv ("GNAT_DRIVER_COMMAND_LINE", Name_Buffer (1 .. Name_Len));
 310
 311    --  Add the directory where the GNAT driver is invoked in front of the path,
 312    --  if the GNAT driver is invoked with directory information.
 313
 314    declare
 315       Command : constant String := Command_Name;
 316
 317    begin
 318       for Index in reverse Command'Range loop
 319          if Command (Index) = Directory_Separator then
 320             declare
 321                Absolute_Dir : constant String :=
 322                  Normalize_Pathname (Command (Command'First .. Index));
 323                PATH         : constant String :=
 324                  Absolute_Dir & Path_Separator & Getenv ("PATH").all;
 325             begin
 326                Setenv ("PATH", PATH);
 327             end;
 328
 329             exit;
 330          end if;
 331       end loop;
 332    end;
 333
 334    --  Scan the command line
 335
 336    --  First, scan to detect --version and/or --help
 337
 338    Check_Version_And_Help ("GNAT", "1996");
 339
 340    begin
 341       loop
 342          if Command_Arg <= Argument_Count
 343            and then Argument (Command_Arg) = "-v"
 344          then
 345             Verbose_Mode := True;
 346             Command_Arg := Command_Arg + 1;
 347
 348          elsif Command_Arg <= Argument_Count
 349            and then Argument (Command_Arg) = "-dn"
 350          then
 351             Keep_Temporary_Files := True;
 352             Command_Arg := Command_Arg + 1;
 353
 354          else
 355             exit;
 356          end if;
 357       end loop;
 358
 359       --  If there is no command, just output the usage
 360
 361       if Command_Arg > Argument_Count then
 362          Usage;
 363          return;
 364       end if;
 365
 366       The_Command := Real_Command_Type'Value (Argument (Command_Arg));
 367
 368    exception
 369       when Constraint_Error =>
 370
 371          --  Check if it is an alternate command
 372
 373          declare
 374             Alternate : Alternate_Command;
 375
 376          begin
 377             Alternate := Alternate_Command'Value (Argument (Command_Arg));
 378             The_Command := Corresponding_To (Alternate);
 379
 380          exception
 381             when Constraint_Error =>
 382                Usage;
 383                Fail ("unknown command: " & Argument (Command_Arg));
 384          end;
 385    end;
 386
 387    --  Get the arguments from the command line and from the eventual
 388    --  argument file(s) specified on the command line.
 389
 390    for Arg in Command_Arg + 1 .. Argument_Count loop
 391       declare
 392          The_Arg : constant String := Argument (Arg);
 393
 394       begin
 395          --  Check if an argument file is specified
 396
 397          if The_Arg'Length > 0 and then The_Arg (The_Arg'First) = '@' then
 398             declare
 399                Arg_File : Ada.Text_IO.File_Type;
 400                Line     : String (1 .. 256);
 401                Last     : Natural;
 402
 403             begin
 404                --  Open the file and fail if the file cannot be found
 405
 406                begin
 407                   Open (Arg_File, In_File,
 408                         The_Arg (The_Arg'First + 1 .. The_Arg'Last));
 409
 410                exception
 411                   when others =>
 412                      Put (Standard_Error, "Cannot open argument file """);
 413                      Put (Standard_Error,
 414                           The_Arg (The_Arg'First + 1 .. The_Arg'Last));
 415                      Put_Line (Standard_Error, """");
 416                      raise Error_Exit;
 417                end;
 418
 419                --  Read line by line and put the content of each non-
 420                --  empty line in the Last_Switches table.
 421
 422                while not End_Of_File (Arg_File) loop
 423                   Get_Line (Arg_File, Line, Last);
 424
 425                   if Last /= 0 then
 426                      Last_Switches.Increment_Last;
 427                      Last_Switches.Table (Last_Switches.Last) :=
 428                        new String'(Line (1 .. Last));
 429                   end if;
 430                end loop;
 431
 432                Close (Arg_File);
 433             end;
 434
 435          elsif The_Arg'Length > 0 then
 436             --  It is not an argument file; just put the argument in
 437             --  the Last_Switches table.
 438
 439             Last_Switches.Increment_Last;
 440             Last_Switches.Table (Last_Switches.Last) := new String'(The_Arg);
 441          end if;
 442       end;
 443    end loop;
 444
 445    declare
 446       Program    : String_Access;
 447       Exec_Path  : String_Access;
 448       Get_Target : Boolean := False;
 449
 450    begin
 451       if The_Command = Stack then
 452
 453          --  Never call gnatstack with a prefix
 454
 455          Program := new String'(Command_List (The_Command).Unixcmd.all);
 456
 457       else
 458          Program :=
 459            Program_Name (Command_List (The_Command).Unixcmd.all, "gnat");
 460
 461          --  If we want to invoke gnatmake/gnatclean with -P, then check if
 462          --  gprbuild/gprclean is available; if it is, use gprbuild/gprclean
 463          --  instead of gnatmake/gnatclean.
 464          --  Ditto for gnatname -> gprname and gnatls -> gprls.
 465
 466          if The_Command = Make
 467            or else The_Command = Compile
 468            or else The_Command = Bind
 469            or else The_Command = Link
 470            or else The_Command = Clean
 471            or else The_Command = Name
 472            or else The_Command = List
 473          then
 474             declare
 475                Switch        : String_Access;
 476                Call_GPR_Tool : Boolean := False;
 477             begin
 478                for J in 1 .. Last_Switches.Last loop
 479                   Switch := Last_Switches.Table (J);
 480
 481                   if Switch'Length >= 2
 482                     and then Switch (Switch'First .. Switch'First + 1) = "-P"
 483                   then
 484                      Call_GPR_Tool := True;
 485                      exit;
 486                   end if;
 487                end loop;
 488
 489                if Call_GPR_Tool then
 490                   case The_Command is
 491                      when Bind
 492                         | Compile
 493                         | Link
 494                         | Make
 495                      =>
 496                         if Locate_Exec_On_Path (Gprbuild) /= null then
 497                            Program    := new String'(Gprbuild);
 498                            Get_Target := True;
 499
 500                            if The_Command = Bind then
 501                               First_Switches.Append (new String'("-b"));
 502                            elsif The_Command = Link then
 503                               First_Switches.Append (new String'("-l"));
 504                            end if;
 505
 506                         elsif The_Command = Bind then
 507                            Fail
 508                              ("'gnat bind -P' is no longer supported;" &
 509                               " use 'gprbuild -b' instead.");
 510
 511                         elsif The_Command = Link then
 512                            Fail
 513                              ("'gnat Link -P' is no longer supported;" &
 514                               " use 'gprbuild -l' instead.");
 515                         end if;
 516
 517                      when Clean =>
 518                         if Locate_Exec_On_Path (Gprclean) /= null then
 519                            Program := new String'(Gprclean);
 520                            Get_Target := True;
 521                         end if;
 522
 523                      when Name =>
 524                         if Locate_Exec_On_Path (Gprname) /= null then
 525                            Program := new String'(Gprname);
 526                            Get_Target := True;
 527                         end if;
 528
 529                      when List =>
 530                         if Locate_Exec_On_Path (Gprls) /= null then
 531                            Program := new String'(Gprls);
 532                            Get_Target := True;
 533                         end if;
 534
 535                      when others =>
 536                         null;
 537                   end case;
 538
 539                   if Get_Target then
 540                      Find_Program_Name;
 541
 542                      if Name_Len > 5 then
 543                         First_Switches.Append
 544                           (new String'
 545                              ("--target=" & Name_Buffer (1 .. Name_Len - 5)));
 546                      end if;
 547                   end if;
 548                end if;
 549             end;
 550          end if;
 551       end if;
 552
 553       --  Locate the executable for the command
 554
 555       Exec_Path := Locate_Exec_On_Path (Program.all);
 556
 557       if Exec_Path = null then
 558          Put_Line (Standard_Error, "could not locate " & Program.all);
 559          raise Error_Exit;
 560       end if;
 561
 562       --  If there are switches for the executable, put them as first switches
 563
 564       if Command_List (The_Command).Unixsws /= null then
 565          for J in Command_List (The_Command).Unixsws'Range loop
 566             First_Switches.Increment_Last;
 567             First_Switches.Table (First_Switches.Last) :=
 568               Command_List (The_Command).Unixsws (J);
 569          end loop;
 570       end if;
 571
 572       --  For FIND and XREF, look for switch -P. If it is specified, then
 573       --  report an error indicating that the command is no longer supporting
 574       --  project files.
 575
 576       if The_Command = Find or else The_Command = Xref then
 577          declare
 578             Argv : String_Access;
 579          begin
 580             for Arg_Num in 1 .. Last_Switches.Last loop
 581                Argv := Last_Switches.Table (Arg_Num);
 582
 583                if Argv'Length >= 2 and then
 584                   Argv (Argv'First .. Argv'First + 1) = "-P"
 585                then
 586                   if The_Command = Find then
 587                      Fail ("'gnat find -P' is no longer supported;");
 588                   else
 589                      Fail ("'gnat xref -P' is no longer supported;");
 590                   end if;
 591                end if;
 592             end loop;
 593          end;
 594       end if;
 595
 596       --  Gather all the arguments and invoke the executable
 597
 598       declare
 599          The_Args : Argument_List
 600                       (1 .. First_Switches.Last + Last_Switches.Last);
 601          Arg_Num  : Natural := 0;
 602
 603       begin
 604          for J in 1 .. First_Switches.Last loop
 605             Arg_Num := Arg_Num + 1;
 606             The_Args (Arg_Num) := First_Switches.Table (J);
 607          end loop;
 608
 609          for J in 1 .. Last_Switches.Last loop
 610             Arg_Num := Arg_Num + 1;
 611             The_Args (Arg_Num) := Last_Switches.Table (J);
 612          end loop;
 613
 614          if Verbose_Mode then
 615             Put (Exec_Path.all);
 616
 617             for Arg in The_Args'Range loop
 618                Put (" " & The_Args (Arg).all);
 619             end loop;
 620
 621             New_Line;
 622          end if;
 623
 624          My_Exit_Status := Exit_Status (Spawn (Exec_Path.all, The_Args));
 625
 626          Set_Exit_Status (My_Exit_Status);
 627       end;
 628    end;
 629
 630 exception
 631    when Error_Exit =>
 632       Set_Exit_Status (Failure);
 633 end GNATCmd;