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