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 26with Gnatvsn; 27with Namet; use Namet; 28with Opt; use Opt; 29with Osint; use Osint; 30with Output; use Output; 31with Switch; use Switch; 32with Table; 33with Usage; 34 35with Ada.Characters.Handling; use Ada.Characters.Handling; 36with Ada.Command_Line; use Ada.Command_Line; 37with Ada.Text_IO; use Ada.Text_IO; 38 39with GNAT.OS_Lib; use GNAT.OS_Lib; 40 41procedure 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 292begin 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 648exception 649 when Error_Exit => 650 Set_Exit_Status (Failure); 651end GNATCmd; 652