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-2019, 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; 33 34with Ada.Characters.Handling; use Ada.Characters.Handling; 35with Ada.Command_Line; use Ada.Command_Line; 36with Ada.Text_IO; use Ada.Text_IO; 37 38with GNAT.OS_Lib; use GNAT.OS_Lib; 39 40procedure 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 285begin 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 630exception 631 when Error_Exit => 632 Set_Exit_Status (Failure); 633end GNATCmd; 634