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