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-2003 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 2, 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 COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- GNAT was originally developed by the GNAT team at New York University. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27with GNAT.Directory_Operations; use GNAT.Directory_Operations; 28 29with Csets; 30with MLib.Tgt; use MLib.Tgt; 31with MLib.Utl; 32with Namet; use Namet; 33with Opt; 34with Osint; use Osint; 35with Output; 36with Prj; use Prj; 37with Prj.Env; 38with Prj.Ext; use Prj.Ext; 39with Prj.Pars; 40with Prj.Util; use Prj.Util; 41with Snames; use Snames; 42with Table; 43with Types; use Types; 44with Hostparm; use Hostparm; 45-- Used to determine if we are in VMS or not for error message purposes 46 47with Ada.Characters.Handling; use Ada.Characters.Handling; 48with Ada.Command_Line; use Ada.Command_Line; 49with Ada.Text_IO; use Ada.Text_IO; 50 51with GNAT.OS_Lib; use GNAT.OS_Lib; 52 53with Table; 54 55with VMS_Conv; use VMS_Conv; 56 57procedure GNATCmd is 58 Project_File : String_Access; 59 Project : Prj.Project_Id; 60 Current_Verbosity : Prj.Verbosity := Prj.Default; 61 Tool_Package_Name : Name_Id := No_Name; 62 63 -- This flag indicates a switch -p (for gnatxref and gnatfind) for 64 -- an old fashioned project file. -p cannot be used in conjonction 65 -- with -P. 66 67 Old_Project_File_Used : Boolean := False; 68 69 -- A table to keep the switches from the project file 70 71 package First_Switches is new Table.Table 72 (Table_Component_Type => String_Access, 73 Table_Index_Type => Integer, 74 Table_Low_Bound => 1, 75 Table_Initial => 20, 76 Table_Increment => 100, 77 Table_Name => "Gnatcmd.First_Switches"); 78 79 package Library_Paths is new Table.Table ( 80 Table_Component_Type => String_Access, 81 Table_Index_Type => Integer, 82 Table_Low_Bound => 1, 83 Table_Initial => 20, 84 Table_Increment => 100, 85 Table_Name => "Make.Library_Path"); 86 87 -- Packages of project files to pass to Prj.Pars.Parse, depending on the 88 -- tool. We allocate objects because we cannot declare aliased objects 89 -- as we are in a procedure, not a library level package. 90 91 Naming_String : constant String_Access := new String'("naming"); 92 Binder_String : constant String_Access := new String'("binder"); 93 Eliminate_String : constant String_Access := new String'("eliminate"); 94 Finder_String : constant String_Access := new String'("finder"); 95 Linker_String : constant String_Access := new String'("linker"); 96 Gnatls_String : constant String_Access := new String'("gnatls"); 97 Pretty_String : constant String_Access := new String'("pretty_printer"); 98 Gnatstub_String : constant String_Access := new String'("gnatstub"); 99 Xref_String : constant String_Access := new String'("cross_reference"); 100 101 Packages_To_Check_By_Binder : constant String_List_Access := 102 new String_List'((Naming_String, Binder_String)); 103 104 Packages_To_Check_By_Eliminate : constant String_List_Access := 105 new String_List'((Naming_String, Eliminate_String)); 106 107 Packages_To_Check_By_Finder : constant String_List_Access := 108 new String_List'((Naming_String, Finder_String)); 109 110 Packages_To_Check_By_Linker : constant String_List_Access := 111 new String_List'((Naming_String, Linker_String)); 112 113 Packages_To_Check_By_Gnatls : constant String_List_Access := 114 new String_List'((Naming_String, Gnatls_String)); 115 116 Packages_To_Check_By_Pretty : constant String_List_Access := 117 new String_List'((Naming_String, Pretty_String)); 118 119 Packages_To_Check_By_Gnatstub : constant String_List_Access := 120 new String_List'((Naming_String, Gnatstub_String)); 121 122 Packages_To_Check_By_Xref : constant String_List_Access := 123 new String_List'((Naming_String, Xref_String)); 124 125 Packages_To_Check : String_List_Access := Prj.All_Packages; 126 127 ---------------------------------- 128 -- Declarations for GNATCMD use -- 129 ---------------------------------- 130 131 The_Command : Command_Type; 132 133 Command_Arg : Positive := 1; 134 135 My_Exit_Status : Exit_Status := Success; 136 137 Current_Work_Dir : constant String := Get_Current_Dir; 138 139 ----------------------- 140 -- Local Subprograms -- 141 ----------------------- 142 143 procedure Check_Relative_Executable (Name : in out String_Access); 144 -- Check if an executable is specified as a relative path. 145 -- If it is, and the path contains directory information, fail. 146 -- Otherwise, prepend the exec directory. 147 -- This procedure is only used for GNAT LINK when a project file 148 -- is specified. 149 150 function Configuration_Pragmas_File return Name_Id; 151 -- Return an argument, if there is a configuration pragmas file to be 152 -- specified for Project, otherwise return No_Name. 153 -- Used for gnatstub (GNAT STUB), gnatpp (GNAT PRETTY) and gnatelim 154 -- (GNAT ELIM). 155 156 procedure Delete_Temp_Config_Files; 157 -- Delete all temporary config files 158 159 function Index (Char : Character; Str : String) return Natural; 160 -- Returns the first occurrence of Char in Str. 161 -- Returns 0 if Char is not in Str. 162 163 procedure Non_VMS_Usage; 164 -- Display usage for platforms other than VMS 165 166 procedure Set_Library_For 167 (Project : Project_Id; 168 There_Are_Libraries : in out Boolean); 169 -- If Project is a library project, add the correct 170 -- -L and -l switches to the linker invocation. 171 172 procedure Set_Libraries is 173 new For_Every_Project_Imported (Boolean, Set_Library_For); 174 -- Add the -L and -l switches to the linker for all 175 -- of the library projects. 176 177 procedure Test_If_Relative_Path 178 (Switch : in out String_Access; 179 Parent : String); 180 -- Test if Switch is a relative search path switch. 181 -- If it is and it includes directory information, prepend the path with 182 -- Parent.This subprogram is only called when using project files. 183 184 ------------------------------- 185 -- Check_Relative_Executable -- 186 ------------------------------- 187 188 procedure Check_Relative_Executable (Name : in out String_Access) is 189 Exec_File_Name : constant String := Name.all; 190 191 begin 192 if not Is_Absolute_Path (Exec_File_Name) then 193 for Index in Exec_File_Name'Range loop 194 if Exec_File_Name (Index) = Directory_Separator then 195 Fail ("relative executable (""" & 196 Exec_File_Name & 197 """) with directory part not allowed " & 198 "when using project files"); 199 end if; 200 end loop; 201 202 Get_Name_String (Projects.Table 203 (Project).Exec_Directory); 204 205 if Name_Buffer (Name_Len) /= Directory_Separator then 206 Name_Len := Name_Len + 1; 207 Name_Buffer (Name_Len) := Directory_Separator; 208 end if; 209 210 Name_Buffer (Name_Len + 1 .. 211 Name_Len + Exec_File_Name'Length) := 212 Exec_File_Name; 213 Name_Len := Name_Len + Exec_File_Name'Length; 214 Name := new String'(Name_Buffer (1 .. Name_Len)); 215 end if; 216 end Check_Relative_Executable; 217 218 -------------------------------- 219 -- Configuration_Pragmas_File -- 220 -------------------------------- 221 222 function Configuration_Pragmas_File return Name_Id is 223 begin 224 Prj.Env.Create_Config_Pragmas_File 225 (Project, Project, Include_Config_Files => False); 226 return Projects.Table (Project).Config_File_Name; 227 end Configuration_Pragmas_File; 228 229 ------------------------------ 230 -- Delete_Temp_Config_Files -- 231 ------------------------------ 232 233 procedure Delete_Temp_Config_Files is 234 Success : Boolean; 235 236 begin 237 if Project /= No_Project then 238 for Prj in 1 .. Projects.Last loop 239 if Projects.Table (Prj).Config_File_Temp then 240 if Opt.Verbose_Mode then 241 Output.Write_Str ("Deleting temp configuration file """); 242 Output.Write_Str (Get_Name_String 243 (Projects.Table (Prj).Config_File_Name)); 244 Output.Write_Line (""""); 245 end if; 246 247 Delete_File 248 (Name => Get_Name_String 249 (Projects.Table (Prj).Config_File_Name), 250 Success => Success); 251 end if; 252 end loop; 253 end if; 254 end Delete_Temp_Config_Files; 255 256 ----------- 257 -- Index -- 258 ----------- 259 260 function Index (Char : Character; Str : String) return Natural is 261 begin 262 for Index in Str'Range loop 263 if Str (Index) = Char then 264 return Index; 265 end if; 266 end loop; 267 268 return 0; 269 end Index; 270 271 --------------------- 272 -- Set_Library_For -- 273 --------------------- 274 275 procedure Set_Library_For 276 (Project : Project_Id; 277 There_Are_Libraries : in out Boolean) 278 is 279 Path_Option : constant String_Access := 280 MLib.Tgt.Linker_Library_Path_Option; 281 282 begin 283 -- Case of library project 284 285 if Projects.Table (Project).Library then 286 There_Are_Libraries := True; 287 288 -- Add the -L switch 289 290 Last_Switches.Increment_Last; 291 Last_Switches.Table (Last_Switches.Last) := 292 new String'("-L" & 293 Get_Name_String 294 (Projects.Table (Project).Library_Dir)); 295 296 -- Add the -l switch 297 298 Last_Switches.Increment_Last; 299 Last_Switches.Table (Last_Switches.Last) := 300 new String'("-l" & 301 Get_Name_String 302 (Projects.Table (Project).Library_Name)); 303 304 -- Add the directory to table Library_Paths, to be processed later 305 -- if library is not static and if Path_Option is not null. 306 307 if Projects.Table (Project).Library_Kind /= Static 308 and then Path_Option /= null 309 then 310 Library_Paths.Increment_Last; 311 Library_Paths.Table (Library_Paths.Last) := 312 new String'(Get_Name_String 313 (Projects.Table (Project).Library_Dir)); 314 end if; 315 316 end if; 317 end Set_Library_For; 318 319 --------------------------- 320 -- Test_If_Relative_Path -- 321 --------------------------- 322 323 procedure Test_If_Relative_Path 324 (Switch : in out String_Access; 325 Parent : String) 326 is 327 begin 328 if Switch /= null then 329 330 declare 331 Sw : String (1 .. Switch'Length); 332 Start : Positive := 1; 333 334 begin 335 Sw := Switch.all; 336 337 if Sw (1) = '-' then 338 if Sw'Length >= 3 339 and then (Sw (2) = 'A' 340 or else Sw (2) = 'I' 341 or else Sw (2) = 'L') 342 then 343 Start := 3; 344 345 if Sw = "-I-" then 346 return; 347 end if; 348 349 elsif Sw'Length >= 4 350 and then (Sw (2 .. 3) = "aL" 351 or else Sw (2 .. 3) = "aO" 352 or else Sw (2 .. 3) = "aI") 353 then 354 Start := 4; 355 356 elsif Sw'Length >= 7 357 and then Sw (2 .. 6) = "-RTS=" 358 then 359 Start := 7; 360 else 361 return; 362 end if; 363 end if; 364 365 -- If the path is relative, test if it includes directory 366 -- information. If it does, prepend Parent to the path. 367 368 if not Is_Absolute_Path (Sw (Start .. Sw'Last)) then 369 for J in Start .. Sw'Last loop 370 if Sw (J) = Directory_Separator then 371 Switch := 372 new String' 373 (Sw (1 .. Start - 1) & 374 Parent & 375 Directory_Separator & 376 Sw (Start .. Sw'Last)); 377 return; 378 end if; 379 end loop; 380 end if; 381 end; 382 end if; 383 end Test_If_Relative_Path; 384 385 ------------------- 386 -- Non_VMS_Usage -- 387 ------------------- 388 389 procedure Non_VMS_Usage is 390 begin 391 Output_Version; 392 New_Line; 393 Put_Line ("List of available commands"); 394 New_Line; 395 396 for C in Command_List'Range loop 397 if not Command_List (C).VMS_Only then 398 Put ("GNAT " & Command_List (C).Cname.all); 399 Set_Col (25); 400 Put (Command_List (C).Unixcmd.all); 401 402 declare 403 Sws : Argument_List_Access renames Command_List (C).Unixsws; 404 begin 405 if Sws /= null then 406 for J in Sws'Range loop 407 Put (' '); 408 Put (Sws (J).all); 409 end loop; 410 end if; 411 end; 412 413 New_Line; 414 end if; 415 end loop; 416 417 New_Line; 418 Put_Line ("Commands FIND, LIST, PRETTY, STUB and XREF accept " & 419 "project file switches -vPx, -Pprj and -Xnam=val"); 420 New_Line; 421 end Non_VMS_Usage; 422 423 ------------------------------------- 424 -- Start of processing for GNATCmd -- 425 ------------------------------------- 426 427begin 428 -- Initializations 429 430 Namet.Initialize; 431 Csets.Initialize; 432 433 Snames.Initialize; 434 435 Prj.Initialize; 436 437 Last_Switches.Init; 438 Last_Switches.Set_Last (0); 439 440 First_Switches.Init; 441 First_Switches.Set_Last (0); 442 443 VMS_Conv.Initialize; 444 445 -- If on VMS, or if VMS emulation is on, convert VMS style /qualifiers, 446 -- filenames and pathnames to Unix style. 447 448 if Hostparm.OpenVMS 449 or else To_Lower (Getenv ("EMULATE_VMS").all) = "true" 450 then 451 VMS_Conversion (The_Command); 452 453 -- If not on VMS, scan the command line directly 454 455 else 456 if Argument_Count = 0 then 457 Non_VMS_Usage; 458 return; 459 else 460 begin 461 if Argument_Count > 1 and then Argument (1) = "-v" then 462 Opt.Verbose_Mode := True; 463 Command_Arg := 2; 464 end if; 465 466 The_Command := Real_Command_Type'Value (Argument (Command_Arg)); 467 468 if Command_List (The_Command).VMS_Only then 469 Non_VMS_Usage; 470 Fail 471 ("Command """, 472 Command_List (The_Command).Cname.all, 473 """ can only be used on VMS"); 474 end if; 475 476 exception 477 when Constraint_Error => 478 479 -- Check if it is an alternate command 480 481 declare 482 Alternate : Alternate_Command; 483 484 begin 485 Alternate := Alternate_Command'Value 486 (Argument (Command_Arg)); 487 The_Command := Corresponding_To (Alternate); 488 489 exception 490 when Constraint_Error => 491 Non_VMS_Usage; 492 Fail ("Unknown command: ", Argument (Command_Arg)); 493 end; 494 end; 495 496 for Arg in Command_Arg + 1 .. Argument_Count loop 497 Last_Switches.Increment_Last; 498 Last_Switches.Table (Last_Switches.Last) := 499 new String'(Argument (Arg)); 500 end loop; 501 end if; 502 end if; 503 504 declare 505 Program : constant String := 506 Program_Name (Command_List (The_Command).Unixcmd.all).all; 507 508 Exec_Path : String_Access; 509 510 begin 511 -- Locate the executable for the command 512 513 Exec_Path := Locate_Exec_On_Path (Program); 514 515 if Exec_Path = null then 516 Put_Line (Standard_Error, "Couldn't locate " & Program); 517 raise Error_Exit; 518 end if; 519 520 -- If there are switches for the executable, put them as first switches 521 522 if Command_List (The_Command).Unixsws /= null then 523 for J in Command_List (The_Command).Unixsws'Range loop 524 First_Switches.Increment_Last; 525 First_Switches.Table (First_Switches.Last) := 526 Command_List (The_Command).Unixsws (J); 527 end loop; 528 end if; 529 530 -- For BIND, FIND, LINK, LIST, PRETTY ad XREF, look for project file 531 -- related switches. 532 533 if The_Command = Bind 534 or else The_Command = Elim 535 or else The_Command = Find 536 or else The_Command = Link 537 or else The_Command = List 538 or else The_Command = Xref 539 or else The_Command = Pretty 540 or else The_Command = Stub 541 then 542 case The_Command is 543 when Bind => 544 Tool_Package_Name := Name_Binder; 545 Packages_To_Check := Packages_To_Check_By_Binder; 546 when Elim => 547 Tool_Package_Name := Name_Eliminate; 548 Packages_To_Check := Packages_To_Check_By_Eliminate; 549 when Find => 550 Tool_Package_Name := Name_Finder; 551 Packages_To_Check := Packages_To_Check_By_Finder; 552 when Link => 553 Tool_Package_Name := Name_Linker; 554 Packages_To_Check := Packages_To_Check_By_Linker; 555 when List => 556 Tool_Package_Name := Name_Gnatls; 557 Packages_To_Check := Packages_To_Check_By_Gnatls; 558 when Pretty => 559 Tool_Package_Name := Name_Pretty_Printer; 560 Packages_To_Check := Packages_To_Check_By_Pretty; 561 when Stub => 562 Tool_Package_Name := Name_Gnatstub; 563 Packages_To_Check := Packages_To_Check_By_Gnatstub; 564 when Xref => 565 Tool_Package_Name := Name_Cross_Reference; 566 Packages_To_Check := Packages_To_Check_By_Xref; 567 when others => 568 null; 569 end case; 570 571 -- Check that the switches are consistent. 572 -- Detect project file related switches. 573 574 Inspect_Switches : 575 declare 576 Arg_Num : Positive := 1; 577 Argv : String_Access; 578 579 procedure Remove_Switch (Num : Positive); 580 -- Remove a project related switch from table Last_Switches 581 582 ------------------- 583 -- Remove_Switch -- 584 ------------------- 585 586 procedure Remove_Switch (Num : Positive) is 587 begin 588 Last_Switches.Table (Num .. Last_Switches.Last - 1) := 589 Last_Switches.Table (Num + 1 .. Last_Switches.Last); 590 Last_Switches.Decrement_Last; 591 end Remove_Switch; 592 593 -- Start of processing for Inspect_Switches 594 595 begin 596 while Arg_Num <= Last_Switches.Last loop 597 Argv := Last_Switches.Table (Arg_Num); 598 599 if Argv (Argv'First) = '-' then 600 if Argv'Length = 1 then 601 Fail 602 ("switch character cannot be followed by a blank"); 603 end if; 604 605 -- The two style project files (-p and -P) cannot be used 606 -- together 607 608 if (The_Command = Find or else The_Command = Xref) 609 and then Argv (2) = 'p' 610 then 611 Old_Project_File_Used := True; 612 if Project_File /= null then 613 Fail ("-P and -p cannot be used together"); 614 end if; 615 end if; 616 617 -- -vPx Specify verbosity while parsing project files 618 619 if Argv'Length = 4 620 and then Argv (Argv'First + 1 .. Argv'First + 2) = "vP" 621 then 622 case Argv (Argv'Last) is 623 when '0' => 624 Current_Verbosity := Prj.Default; 625 when '1' => 626 Current_Verbosity := Prj.Medium; 627 when '2' => 628 Current_Verbosity := Prj.High; 629 when others => 630 Fail ("Invalid switch: ", Argv.all); 631 end case; 632 633 Remove_Switch (Arg_Num); 634 635 -- -Pproject_file Specify project file to be used 636 637 elsif Argv (Argv'First + 1) = 'P' then 638 639 -- Only one -P switch can be used 640 641 if Project_File /= null then 642 Fail 643 (Argv.all, 644 ": second project file forbidden (first is """, 645 Project_File.all & """)"); 646 647 -- The two style project files (-p and -P) cannot be 648 -- used together. 649 650 elsif Old_Project_File_Used then 651 Fail ("-p and -P cannot be used together"); 652 653 elsif Argv'Length = 2 then 654 -- There is space between -P and the project file 655 -- name. -P cannot be the last option. 656 657 if Arg_Num = Last_Switches.Last then 658 Fail ("project file name missing after -P"); 659 660 else 661 Remove_Switch (Arg_Num); 662 Argv := Last_Switches.Table (Arg_Num); 663 664 -- After -P, there must be a project file name, 665 -- not another switch. 666 667 if Argv (Argv'First) = '-' then 668 Fail ("project file name missing after -P"); 669 670 else 671 Project_File := new String'(Argv.all); 672 end if; 673 end if; 674 675 else 676 -- No space between -P and project file name 677 678 Project_File := 679 new String'(Argv (Argv'First + 2 .. Argv'Last)); 680 end if; 681 682 Remove_Switch (Arg_Num); 683 684 -- -Xexternal=value Specify an external reference to be 685 -- used in project files 686 687 elsif Argv'Length >= 5 688 and then Argv (Argv'First + 1) = 'X' 689 then 690 declare 691 Equal_Pos : constant Natural := 692 Index ('=', Argv (Argv'First + 2 .. Argv'Last)); 693 begin 694 if Equal_Pos >= Argv'First + 3 and then 695 Equal_Pos /= Argv'Last then 696 Add (External_Name => 697 Argv (Argv'First + 2 .. Equal_Pos - 1), 698 Value => Argv (Equal_Pos + 1 .. Argv'Last)); 699 else 700 Fail 701 (Argv.all, 702 " is not a valid external assignment."); 703 end if; 704 end; 705 706 Remove_Switch (Arg_Num); 707 708 else 709 Arg_Num := Arg_Num + 1; 710 end if; 711 712 else 713 Arg_Num := Arg_Num + 1; 714 end if; 715 end loop; 716 end Inspect_Switches; 717 end if; 718 719 -- If there is a project file specified, parse it, get the switches 720 -- for the tool and setup PATH environment variables. 721 722 if Project_File /= null then 723 Prj.Pars.Set_Verbosity (To => Current_Verbosity); 724 725 Prj.Pars.Parse 726 (Project => Project, 727 Project_File_Name => Project_File.all, 728 Packages_To_Check => Packages_To_Check); 729 730 if Project = Prj.No_Project then 731 Fail ("""", Project_File.all, """ processing failed"); 732 end if; 733 734 -- Check if a package with the name of the tool is in the project 735 -- file and if there is one, get the switches, if any, and scan them. 736 737 declare 738 Data : constant Prj.Project_Data := 739 Prj.Projects.Table (Project); 740 741 Pkg : constant Prj.Package_Id := 742 Prj.Util.Value_Of 743 (Name => Tool_Package_Name, 744 In_Packages => Data.Decl.Packages); 745 746 Element : Package_Element; 747 748 Default_Switches_Array : Array_Element_Id; 749 750 The_Switches : Prj.Variable_Value; 751 Current : Prj.String_List_Id; 752 The_String : String_Element; 753 754 begin 755 if Pkg /= No_Package then 756 Element := Packages.Table (Pkg); 757 758 -- Packages Gnatls has a single attribute Switches, that is 759 -- not an associative array. 760 761 if The_Command = List then 762 The_Switches := 763 Prj.Util.Value_Of 764 (Variable_Name => Snames.Name_Switches, 765 In_Variables => Element.Decl.Attributes); 766 767 -- Packages Binder (for gnatbind), Cross_Reference (for 768 -- gnatxref), Linker (for gnatlink) Finder (for gnatfind), 769 -- Pretty_Printer (for gnatpp) and Eliminate (for gnatelim) 770 -- have an attributed Switches, an associative array, indexed 771 -- by the name of the file. 772 -- They also have an attribute Default_Switches, indexed 773 -- by the name of the programming language. 774 775 else 776 if The_Switches.Kind = Prj.Undefined then 777 Default_Switches_Array := 778 Prj.Util.Value_Of 779 (Name => Name_Default_Switches, 780 In_Arrays => Packages.Table (Pkg).Decl.Arrays); 781 The_Switches := Prj.Util.Value_Of 782 (Index => Name_Ada, 783 In_Array => Default_Switches_Array); 784 end if; 785 end if; 786 787 -- If there are switches specified in the package of the 788 -- project file corresponding to the tool, scan them. 789 790 case The_Switches.Kind is 791 when Prj.Undefined => 792 null; 793 794 when Prj.Single => 795 declare 796 Switch : constant String := 797 Get_Name_String (The_Switches.Value); 798 799 begin 800 if Switch'Length > 0 then 801 First_Switches.Increment_Last; 802 First_Switches.Table (First_Switches.Last) := 803 new String'(Switch); 804 end if; 805 end; 806 807 when Prj.List => 808 Current := The_Switches.Values; 809 while Current /= Prj.Nil_String loop 810 The_String := String_Elements.Table (Current); 811 812 declare 813 Switch : constant String := 814 Get_Name_String (The_String.Value); 815 816 begin 817 if Switch'Length > 0 then 818 First_Switches.Increment_Last; 819 First_Switches.Table (First_Switches.Last) := 820 new String'(Switch); 821 end if; 822 end; 823 824 Current := The_String.Next; 825 end loop; 826 end case; 827 end if; 828 end; 829 830 if The_Command = Bind 831 or else The_Command = Link 832 or else The_Command = Elim 833 then 834 Change_Dir 835 (Get_Name_String 836 (Projects.Table (Project).Object_Directory)); 837 end if; 838 839 -- Set up the env vars for project path files 840 841 Prj.Env.Set_Ada_Paths (Project, Including_Libraries => False); 842 843 -- For gnatstub, gnatpp and gnatelim, create a configuration pragmas 844 -- file, if necessary. 845 846 if The_Command = Pretty 847 or else The_Command = Stub 848 or else The_Command = Elim 849 then 850 declare 851 CP_File : constant Name_Id := Configuration_Pragmas_File; 852 853 begin 854 if CP_File /= No_Name then 855 First_Switches.Increment_Last; 856 857 if The_Command = Elim then 858 First_Switches.Table (First_Switches.Last) := 859 new String'("-C" & Get_Name_String (CP_File)); 860 861 else 862 First_Switches.Table (First_Switches.Last) := 863 new String'("-gnatec=" & Get_Name_String (CP_File)); 864 end if; 865 end if; 866 end; 867 end if; 868 869 if The_Command = Link then 870 871 -- Add the default search directories, to be able to find 872 -- libgnat in call to MLib.Utl.Lib_Directory. 873 874 Add_Default_Search_Dirs; 875 876 declare 877 There_Are_Libraries : Boolean := False; 878 Path_Option : constant String_Access := 879 MLib.Tgt.Linker_Library_Path_Option; 880 881 begin 882 Library_Paths.Set_Last (0); 883 884 -- Check if there are library project files 885 886 if MLib.Tgt.Support_For_Libraries /= MLib.Tgt.None then 887 Set_Libraries (Project, There_Are_Libraries); 888 end if; 889 890 -- If there are, add the necessary additional switches 891 892 if There_Are_Libraries then 893 894 -- Add -L<lib_dir> -lgnarl -lgnat -Wl,-rpath,<lib_dir> 895 896 Last_Switches.Increment_Last; 897 Last_Switches.Table (Last_Switches.Last) := 898 new String'("-L" & MLib.Utl.Lib_Directory); 899 Last_Switches.Increment_Last; 900 Last_Switches.Table (Last_Switches.Last) := 901 new String'("-lgnarl"); 902 Last_Switches.Increment_Last; 903 Last_Switches.Table (Last_Switches.Last) := 904 new String'("-lgnat"); 905 906 -- If Path_Option is not null, create the switch 907 -- ("-Wl,-rpath," or equivalent) with all the library dirs 908 -- plus the standard GNAT library dir. 909 910 if Path_Option /= null then 911 declare 912 Option : String_Access; 913 Length : Natural := Path_Option'Length; 914 Current : Natural; 915 916 begin 917 -- First, compute the exact length for the switch 918 919 for Index in 920 Library_Paths.First .. Library_Paths.Last 921 loop 922 -- Add the length of the library dir plus one 923 -- for the directory separator. 924 925 Length := 926 Length + 927 Library_Paths.Table (Index)'Length + 1; 928 end loop; 929 930 -- Finally, add the length of the standard GNAT 931 -- library dir. 932 933 Length := Length + MLib.Utl.Lib_Directory'Length; 934 Option := new String (1 .. Length); 935 Option (1 .. Path_Option'Length) := Path_Option.all; 936 Current := Path_Option'Length; 937 938 -- Put each library dir followed by a dir separator 939 940 for Index in 941 Library_Paths.First .. Library_Paths.Last 942 loop 943 Option 944 (Current + 1 .. 945 Current + 946 Library_Paths.Table (Index)'Length) := 947 Library_Paths.Table (Index).all; 948 Current := 949 Current + 950 Library_Paths.Table (Index)'Length + 1; 951 Option (Current) := Path_Separator; 952 end loop; 953 954 -- Finally put the standard GNAT library dir 955 956 Option 957 (Current + 1 .. 958 Current + MLib.Utl.Lib_Directory'Length) := 959 MLib.Utl.Lib_Directory; 960 961 -- And add the switch to the last switches 962 963 Last_Switches.Increment_Last; 964 Last_Switches.Table (Last_Switches.Last) := 965 Option; 966 end; 967 end if; 968 end if; 969 end; 970 971 -- Check if the first ALI file specified can be found, either 972 -- in the object directory of the main project or in an object 973 -- directory of a project file extended by the main project. 974 -- If the ALI file can be found, replace its name with its 975 -- absolute path. 976 977 declare 978 Skip_Executable : Boolean := False; 979 980 begin 981 Switch_Loop : for J in 1 .. Last_Switches.Last loop 982 983 -- If we have an executable just reset the flag 984 985 if Skip_Executable then 986 Skip_Executable := False; 987 988 -- If -o, set flag so that next switch is not processed 989 990 elsif Last_Switches.Table (J).all = "-o" then 991 Skip_Executable := True; 992 993 -- Normal case 994 995 else 996 declare 997 Switch : constant String := 998 Last_Switches.Table (J).all; 999 1000 ALI_File : constant String (1 .. Switch'Length + 4) := 1001 Switch & ".ali"; 1002 1003 Last : Natural := Switch'Length; 1004 Test_Existence : Boolean := False; 1005 1006 begin 1007 -- Skip real switches 1008 1009 if Switch'Length /= 0 and then 1010 Switch (Switch'First) /= '-' 1011 then 1012 -- Append ".ali" if file name does not end with it 1013 1014 if Switch'Length <= 4 or else 1015 Switch (Switch'Last - 3 .. Switch'Last) /= ".ali" 1016 then 1017 Last := ALI_File'Last; 1018 end if; 1019 1020 -- If file name includes directory information, 1021 -- stop if ALI file exists. 1022 1023 if Is_Absolute_Path (ALI_File (1 .. Last)) then 1024 Test_Existence := True; 1025 1026 else 1027 for K in Switch'Range loop 1028 if Switch (K) = '/' or else 1029 Switch (K) = Directory_Separator 1030 then 1031 Test_Existence := True; 1032 exit; 1033 end if; 1034 end loop; 1035 end if; 1036 1037 if Test_Existence then 1038 if Is_Regular_File (ALI_File (1 .. Last)) then 1039 exit Switch_Loop; 1040 end if; 1041 1042 else 1043 -- Look in the object directories if the ALI 1044 -- file exists. 1045 1046 declare 1047 Prj : Project_Id := Project; 1048 begin 1049 Project_Loop : 1050 loop 1051 declare 1052 Dir : constant String := 1053 Get_Name_String 1054 (Projects.Table (Prj). 1055 Object_Directory); 1056 begin 1057 if Is_Regular_File 1058 (Dir & Directory_Separator & 1059 ALI_File (1 .. Last)) 1060 then 1061 -- We have found the correct 1062 -- project, so we replace the file 1063 -- with the absolute path. 1064 1065 Last_Switches.Table (J) := 1066 new String' 1067 (Dir & Directory_Separator & 1068 ALI_File (1 .. Last)); 1069 1070 -- And we are done 1071 1072 exit Switch_Loop; 1073 end if; 1074 end; 1075 1076 -- Go to the project being extended, 1077 -- if any. 1078 1079 Prj := Projects.Table (Prj).Extends; 1080 exit Project_Loop when Prj = No_Project; 1081 end loop Project_Loop; 1082 end; 1083 end if; 1084 end if; 1085 end; 1086 end if; 1087 end loop Switch_Loop; 1088 end; 1089 1090 -- If a relative path output file has been specified, we add 1091 -- the exec directory. 1092 1093 declare 1094 Look_For_Executable : Boolean := True; 1095 1096 begin 1097 1098 for J in reverse 1 .. Last_Switches.Last - 1 loop 1099 if Last_Switches.Table (J).all = "-o" then 1100 Check_Relative_Executable 1101 (Name => Last_Switches.Table (J + 1)); 1102 Look_For_Executable := False; 1103 exit; 1104 end if; 1105 end loop; 1106 1107 if Look_For_Executable then 1108 for J in reverse 1 .. First_Switches.Last - 1 loop 1109 if First_Switches.Table (J).all = "-o" then 1110 Look_For_Executable := False; 1111 Check_Relative_Executable 1112 (Name => First_Switches.Table (J + 1)); 1113 exit; 1114 end if; 1115 end loop; 1116 end if; 1117 1118 -- If no executable is specified, then find the name 1119 -- of the first ALI file on the command line and issue 1120 -- a -o switch with the absolute path of the executable 1121 -- in the exec directory. 1122 1123 if Look_For_Executable then 1124 for J in 1 .. Last_Switches.Last loop 1125 declare 1126 Arg : constant String_Access := 1127 Last_Switches.Table (J); 1128 Last : Natural := 0; 1129 1130 begin 1131 if Arg'Length /= 0 and then Arg (Arg'First) /= '-' then 1132 if Arg'Length > 4 1133 and then Arg (Arg'Last - 3 .. Arg'Last) = ".ali" 1134 then 1135 Last := Arg'Last - 4; 1136 1137 elsif Is_Regular_File (Arg.all & ".ali") then 1138 Last := Arg'Last; 1139 end if; 1140 1141 if Last /= 0 then 1142 declare 1143 Executable_Name : constant String := 1144 Base_Name (Arg (Arg'First .. Last)); 1145 begin 1146 Last_Switches.Increment_Last; 1147 Last_Switches.Table (Last_Switches.Last) := 1148 new String'("-o"); 1149 Get_Name_String 1150 (Projects.Table (Project).Exec_Directory); 1151 Last_Switches.Increment_Last; 1152 Last_Switches.Table (Last_Switches.Last) := 1153 new String'(Name_Buffer (1 .. Name_Len) & 1154 Directory_Separator & 1155 Executable_Name & 1156 Get_Executable_Suffix.all); 1157 exit; 1158 end; 1159 end if; 1160 end if; 1161 end; 1162 end loop; 1163 end if; 1164 end; 1165 end if; 1166 1167 if The_Command = Link or The_Command = Bind then 1168 1169 -- For files that are specified as relative paths with directory 1170 -- information, we convert them to absolute paths, with parent 1171 -- being the current working directory if specified on the command 1172 -- line and the project directory if specified in the project 1173 -- file. This is what gnatmake is doing for linker and binder 1174 -- arguments. 1175 1176 for J in 1 .. Last_Switches.Last loop 1177 Test_If_Relative_Path 1178 (Last_Switches.Table (J), Current_Work_Dir); 1179 end loop; 1180 1181 Get_Name_String (Projects.Table (Project).Directory); 1182 1183 declare 1184 Project_Dir : constant String := Name_Buffer (1 .. Name_Len); 1185 1186 begin 1187 for J in 1 .. First_Switches.Last loop 1188 Test_If_Relative_Path 1189 (First_Switches.Table (J), Project_Dir); 1190 end loop; 1191 end; 1192 1193 elsif The_Command = Stub then 1194 declare 1195 Data : constant Prj.Project_Data := 1196 Prj.Projects.Table (Project); 1197 File_Index : Integer := 0; 1198 Dir_Index : Integer := 0; 1199 Last : constant Integer := Last_Switches.Last; 1200 1201 begin 1202 for Index in 1 .. Last loop 1203 if Last_Switches.Table (Index) 1204 (Last_Switches.Table (Index)'First) /= '-' 1205 then 1206 File_Index := Index; 1207 exit; 1208 end if; 1209 end loop; 1210 1211 -- If the naming scheme of the project file is not standard, 1212 -- and if the file name ends with the spec suffix, then 1213 -- indicate to gnatstub the name of the body file with 1214 -- a -o switch. 1215 1216 if Data.Naming.Current_Spec_Suffix /= 1217 Prj.Default_Ada_Spec_Suffix 1218 then 1219 if File_Index /= 0 then 1220 declare 1221 Spec : constant String := 1222 Base_Name (Last_Switches.Table (File_Index).all); 1223 Last : Natural := Spec'Last; 1224 1225 begin 1226 Get_Name_String (Data.Naming.Current_Spec_Suffix); 1227 1228 if Spec'Length > Name_Len 1229 and then Spec (Last - Name_Len + 1 .. Last) = 1230 Name_Buffer (1 .. Name_Len) 1231 then 1232 Last := Last - Name_Len; 1233 Get_Name_String (Data.Naming.Current_Body_Suffix); 1234 Last_Switches.Increment_Last; 1235 Last_Switches.Table (Last_Switches.Last) := 1236 new String'("-o"); 1237 Last_Switches.Increment_Last; 1238 Last_Switches.Table (Last_Switches.Last) := 1239 new String'(Spec (Spec'First .. Last) & 1240 Name_Buffer (1 .. Name_Len)); 1241 end if; 1242 end; 1243 end if; 1244 end if; 1245 1246 -- Add the directory of the spec as the destination directory 1247 -- of the body, if there is no destination directory already 1248 -- specified. 1249 1250 if File_Index /= 0 then 1251 for Index in File_Index + 1 .. Last loop 1252 if Last_Switches.Table (Index) 1253 (Last_Switches.Table (Index)'First) /= '-' 1254 then 1255 Dir_Index := Index; 1256 exit; 1257 end if; 1258 end loop; 1259 1260 if Dir_Index = 0 then 1261 Last_Switches.Increment_Last; 1262 Last_Switches.Table (Last_Switches.Last) := 1263 new String' 1264 (Dir_Name (Last_Switches.Table (File_Index).all)); 1265 end if; 1266 end if; 1267 end; 1268 end if; 1269 end if; 1270 1271 -- Gather all the arguments and invoke the executable 1272 1273 declare 1274 The_Args : Argument_List 1275 (1 .. First_Switches.Last + Last_Switches.Last); 1276 Arg_Num : Natural := 0; 1277 begin 1278 for J in 1 .. First_Switches.Last loop 1279 Arg_Num := Arg_Num + 1; 1280 The_Args (Arg_Num) := First_Switches.Table (J); 1281 end loop; 1282 1283 for J in 1 .. Last_Switches.Last loop 1284 Arg_Num := Arg_Num + 1; 1285 The_Args (Arg_Num) := Last_Switches.Table (J); 1286 end loop; 1287 1288 -- If Display_Command is on, only display the generated command 1289 1290 if Display_Command then 1291 Put (Standard_Error, "generated command -->"); 1292 Put (Standard_Error, Exec_Path.all); 1293 1294 for Arg in The_Args'Range loop 1295 Put (Standard_Error, " "); 1296 Put (Standard_Error, The_Args (Arg).all); 1297 end loop; 1298 1299 Put (Standard_Error, "<--"); 1300 New_Line (Standard_Error); 1301 raise Normal_Exit; 1302 end if; 1303 1304 if Opt.Verbose_Mode then 1305 Output.Write_Str (Exec_Path.all); 1306 1307 for Arg in The_Args'Range loop 1308 Output.Write_Char (' '); 1309 Output.Write_Str (The_Args (Arg).all); 1310 end loop; 1311 1312 Output.Write_Eol; 1313 end if; 1314 1315 My_Exit_Status := 1316 Exit_Status (Spawn (Exec_Path.all, The_Args)); 1317 raise Normal_Exit; 1318 end; 1319 end; 1320 1321exception 1322 when Error_Exit => 1323 Prj.Env.Delete_All_Path_Files; 1324 Delete_Temp_Config_Files; 1325 Set_Exit_Status (Failure); 1326 1327 when Normal_Exit => 1328 Prj.Env.Delete_All_Path_Files; 1329 Delete_Temp_Config_Files; 1330 1331 -- Since GNATCmd is normally called from DCL (the VMS shell), 1332 -- it must return an understandable VMS exit status. However 1333 -- the exit status returned *to* GNATCmd is a Posix style code, 1334 -- so we test it and return just a simple success or failure on VMS. 1335 1336 if Hostparm.OpenVMS and then My_Exit_Status /= Success then 1337 Set_Exit_Status (Failure); 1338 else 1339 Set_Exit_Status (My_Exit_Status); 1340 end if; 1341 1342end GNATCmd; 1343