1------------------------------------------------------------------------------ 2-- -- 3-- GPR TECHNOLOGY -- 4-- -- 5-- Copyright (C) 2006-2016, AdaCore -- 6-- -- 7-- This is free software; you can redistribute it and/or modify it under -- 8-- terms of the GNU General Public License as published by the Free Soft- -- 9-- ware Foundation; either version 3, or (at your option) any later ver- -- 10-- sion. This software is distributed in the hope that it will be useful, -- 11-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 12-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 13-- License for more details. You should have received a copy of the GNU -- 14-- General Public License distributed with GNAT; see file COPYING. If not, -- 15-- see <http://www.gnu.org/licenses/>. -- 16-- -- 17------------------------------------------------------------------------------ 18 19-- gprbind is the executable called by gprmake to bind Ada sources. It is 20-- the driver for gnatbind. It gets its input from gprmake through the 21-- binding exchange file and gives back its results through the same file. 22 23with Ada.Command_Line; use Ada.Command_Line; 24with Ada.Directories; 25with Ada.Text_IO; use Ada.Text_IO; 26 27with GNAT.Directory_Operations; use GNAT.Directory_Operations; 28with GNAT.OS_Lib; use GNAT.OS_Lib; 29 30with Gprexch; use Gprexch; 31with Gpr_Build_Util; use Gpr_Build_Util; 32with Gpr_Util; use Gpr_Util; 33with GPR; use GPR; 34with GPR.ALI; use GPR.ALI; 35with GPR.Names; use GPR.Names; 36with GPR.Osint; use GPR.Osint; 37with GPR.Tempdir; 38with GNAT.Table; 39with GPR.Util; use GPR.Util; 40 41procedure Gprbind is 42 43 Shared_Libgcc_Default : Character; 44 for Shared_Libgcc_Default'Size use Character'Size; 45 pragma Import 46 (C, Shared_Libgcc_Default, "__gnat_shared_libgcc_default"); 47 48 Executable_Suffix : constant String_Access := Get_Executable_Suffix; 49 -- The suffix of executables on this platforms 50 51 GNATBIND : String_Access := new String'("gnatbind"); 52 -- The file name of the gnatbind executable. May be modified by an option 53 -- in the Minimum_Binder_Options. 54 55 Gnatbind_Prefix_Equal : constant String := "gnatbind_prefix="; 56 -- Start of the option to specify a prefix for the gnatbind executable 57 58 Gnatbind_Path_Equal : constant String := "--gnatbind_path="; 59 -- Start of the option to specify the absolute path of gnatbind 60 61 Ada_Binder_Equal : constant String := "ada_binder="; 62 -- Start of the option to specify the full name of the Ada binder 63 -- executable. Introduced for GNAAMP, where it is gnaambind. 64 65 Quiet_Output : Boolean := False; 66 Verbose_Mode : Boolean := False; 67 68 Dash_O_Specified : Boolean := False; 69 Dash_O_File_Specified : Boolean := False; 70 71 There_Are_Stand_Alone_Libraries : Boolean := False; 72 -- Set to True if the corresponding label is in the exchange file 73 74 No_Main_Option : constant String := "-n"; 75 Dash_o : constant String := "-o"; 76 Dash_shared : constant String := "-shared"; 77 Dash_x : constant String := "-x"; 78 Dash_Fequal : constant String := "-F="; 79 Dash_OO : constant String := "-O"; 80 81 -- Minimum switches to be used to compile the binder generated file 82 83 Dash_c : constant String := "-c"; 84 Dash_gnatA : constant String := "-gnatA"; 85 Dash_gnatWb : constant String := "-gnatWb"; 86 Dash_gnatiw : constant String := "-gnatiw"; 87 Dash_gnatws : constant String := "-gnatws"; 88 89 GCC_Version : Character := '0'; 90 Gcc_Version_String : constant String := "gcc version "; 91 92 Shared_Libgcc : constant String := "-shared-libgcc"; 93 Static_Libgcc : constant String := "-static-libgcc"; 94 95 Libgcc_Specified : Boolean := False; 96 -- True if -shared-libgcc or -static-libgcc is used 97 98 IO_File : File_Type; 99 -- The file to get the inputs and to put the results of the binding 100 101 Line : String (1 .. 1_000); 102 Last : Natural; 103 104 Exchange_File_Name : String_Access; 105 Ada_Compiler_Path : String_Access; 106 FULL_GNATBIND : String_Access; 107 Gnatbind_Path : String_Access; 108 Gnatbind_Path_Specified : Boolean := False; 109 110 Compiler_Options : String_List_Access := new String_List (1 .. 100); 111 Last_Compiler_Option : Natural := 0; 112 Compiler_Trailing_Options : String_List_Access := new String_List (1 .. 10); 113 Last_Compiler_Trailing_Option : Natural := 0; 114 115 Gnatbind_Options : String_List_Access := new String_List (1 .. 100); 116 Last_Gnatbind_Option : Natural := 0; 117 118 Main_ALI : String_Access := null; 119 120 Main_Base_Name : String_Access := null; 121 Binder_Generated_File : String_Access := null; 122 BG_File : File_Type; 123 124 Mapping_File : String_Access := null; 125 126 Success : Boolean := False; 127 Return_Code : Integer; 128 129 Adalib_Dir : String_Access; 130 Prefix_Path : String_Access; 131 Lib_Path : String_Access; 132 133 Static_Libs : Boolean := True; 134 135 Current_Section : Binding_Section := No_Binding_Section; 136 137 All_Binding_Options : Boolean; 138 Get_Option : Boolean; 139 Xlinker_Seen : Boolean; 140 Stack_Equal_Seen : Boolean; 141 142 GNAT_Version : String_Access := new String'("000"); 143 -- The version of GNAT, coming from the Toolchain_Version for Ada 144 145 GNAT_Version_Set : Boolean := False; 146 -- True when the toolchain version is in the input exchange file 147 148 Delete_Temp_Files : Boolean := True; 149 150 FD_Objects : File_Descriptor; 151 Objects_Path : Path_Name_Type; 152 Objects_File : File_Type; 153 154 Ada_Object_Suffix : String_Access := Get_Object_Suffix; 155 156 Display_Line : String_Access := new String (1 .. 1_000); 157 Display_Last : Natural := 0; 158 -- A String buffer to store temporarily the displayed gnatbind command 159 -- invoked by gprbind. 160 161 procedure Add_To_Display_Line (S : String); 162 -- Add an argument to the Display_Line 163 164 package Binding_Options_Table is new GNAT.Table 165 (Table_Component_Type => String_Access, 166 Table_Index_Type => Natural, 167 Table_Low_Bound => 1, 168 Table_Initial => 10, 169 Table_Increment => 100); 170 171 Binding_Option_Dash_V_Specified : Boolean := False; 172 -- Set to True if -v is specified in the binding options 173 174 GNAT_6_Or_Higher : Boolean := False; 175 -- Set to True when GNAT version is neither 3.xx nor 5.xx 176 177 GNAT_6_4_Or_Higher : Boolean := False; 178 -- Set to True when GNAT_6_Or_Higher is True and if GNAT version is 6.xy 179 -- with x >= 4. 180 181 package ALI_Files_Table is new GNAT.Table 182 (Table_Component_Type => String_Access, 183 Table_Index_Type => Natural, 184 Table_Low_Bound => 1, 185 Table_Initial => 10, 186 Table_Increment => 100); 187 188 type Path_And_Stamp is record 189 Path : String_Access; 190 Stamp : String_Access; 191 end record; 192 193 package Project_Paths is new GNAT.Table 194 (Table_Component_Type => Path_And_Stamp, 195 Table_Index_Type => Natural, 196 Table_Low_Bound => 1, 197 Table_Initial => 10, 198 Table_Increment => 100); 199 200 type Bound_File; 201 type Bound_File_Access is access Bound_File; 202 type Bound_File is record 203 Name : String_Access; 204 Next : Bound_File_Access; 205 end record; 206 207 Bound_Files : Bound_File_Access; 208 209 ------------------------- 210 -- Add_To_Display_Line -- 211 ------------------------- 212 213 procedure Add_To_Display_Line (S : String) is 214 begin 215 while Display_Last + 1 + S'Length > Display_Line'Last loop 216 declare 217 New_Buffer : constant String_Access := 218 new String (1 .. 2 * Display_Line'Length); 219 begin 220 New_Buffer (1 .. Display_Last) := 221 Display_Line (1 .. Display_Last); 222 Free (Display_Line); 223 Display_Line := New_Buffer; 224 end; 225 end loop; 226 227 if Display_Last > 0 then 228 Display_Last := Display_Last + 1; 229 Display_Line (Display_Last) := ' '; 230 end if; 231 232 Display_Line (Display_Last + 1 .. Display_Last + S'Length) := S; 233 Display_Last := Display_Last + S'Length; 234 end Add_To_Display_Line; 235 236begin 237 Set_Program_Name ("gprbind"); 238 239 -- As the section header has alreading been displayed when gprlib was 240 -- invoked, indicate that it should not be displayed again. 241 242 GPR.Set (Section => GPR.Bind); 243 244 if Argument_Count /= 1 then 245 Fail_Program (null, "incorrect invocation"); 246 end if; 247 248 Exchange_File_Name := new String'(Argument (1)); 249 250 -- DEBUG: save a copy of the exchange file 251 252 declare 253 Gprbind_Debug : constant String := Getenv ("GPRBIND_DEBUG").all; 254 255 begin 256 if Gprbind_Debug = "TRUE" then 257 Copy_File 258 (Exchange_File_Name.all, 259 Exchange_File_Name.all & "__saved", 260 Success, 261 Mode => Overwrite, 262 Preserve => Time_Stamps); 263 end if; 264 end; 265 266 -- Open the binding exchange file 267 268 begin 269 Open (IO_File, In_File, Exchange_File_Name.all); 270 exception 271 when others => 272 Fail_Program (null, "could not read " & Exchange_File_Name.all); 273 end; 274 275 -- Get the information from the binding exchange file 276 277 while not End_Of_File (IO_File) loop 278 Get_Line (IO_File, Line, Last); 279 280 if Last > 0 then 281 if Line (1) = '[' then 282 Current_Section := Get_Binding_Section (Line (1 .. Last)); 283 284 case Current_Section is 285 when No_Binding_Section => 286 Fail_Program 287 (null, "unknown section: " & Line (1 .. Last)); 288 289 when Quiet => 290 Quiet_Output := True; 291 Verbose_Mode := False; 292 293 when Verbose => 294 Quiet_Output := False; 295 Verbose_Mode := True; 296 297 when Shared_Libs => 298 Static_Libs := False; 299 300 when Gprexch.There_Are_Stand_Alone_Libraries => 301 There_Are_Stand_Alone_Libraries := True; 302 303 when others => 304 null; 305 end case; 306 307 else 308 case Current_Section is 309 when No_Binding_Section => 310 Fail_Program 311 (null, "no section specified: " & Line (1 .. Last)); 312 313 when Quiet => 314 Fail_Program (null, "quiet section should be empty"); 315 316 when Verbose => 317 Fail_Program (null, "verbose section should be empty"); 318 319 when Shared_Libs => 320 Fail_Program 321 (null, "shared libs section should be empty"); 322 323 when Gprexch.There_Are_Stand_Alone_Libraries => 324 Fail_Program 325 (null, "stand-alone libraries section should be empty"); 326 327 when Gprexch.Main_Base_Name => 328 if Main_Base_Name /= null then 329 Fail_Program 330 (null, "main base name specified multiple times"); 331 end if; 332 333 Main_Base_Name := new String'(Line (1 .. Last)); 334 335 when Gprexch.Mapping_File => 336 Mapping_File := new String'(Line (1 .. Last)); 337 338 when Compiler_Path => 339 if Ada_Compiler_Path /= null then 340 Fail_Program 341 (null, "compiler path specified multiple times"); 342 end if; 343 344 Ada_Compiler_Path := new String'(Line (1 .. Last)); 345 346 when Compiler_Leading_Switches => 347 Add 348 (Line (1 .. Last), 349 Compiler_Options, Last_Compiler_Option); 350 351 when Compiler_Trailing_Switches => 352 Add 353 (Line (1 .. Last), 354 Compiler_Trailing_Options, Last_Compiler_Trailing_Option); 355 356 when Main_Dependency_File => 357 if Main_ALI /= null then 358 Fail_Program 359 (null, "main ALI file specified multiple times"); 360 end if; 361 362 Main_ALI := new String'(Line (1 .. Last)); 363 364 when Dependency_Files => 365 ALI_Files_Table.Append (new String'(Line (1 .. Last))); 366 367 when Binding_Options => 368 -- Check if a gnatbind absolute is specified 369 370 if Last > Gnatbind_Path_Equal'Length 371 and then Line (1 .. Gnatbind_Path_Equal'Length) = 372 Gnatbind_Path_Equal 373 then 374 Gnatbind_Path := new String' 375 (Line (Gnatbind_Path_Equal'Length + 1 .. Last)); 376 Gnatbind_Path_Specified := True; 377 378 -- Check if a gnatbind prefix is specified 379 380 elsif Last >= Gnatbind_Prefix_Equal'Length 381 and then Line (1 .. Gnatbind_Prefix_Equal'Length) = 382 Gnatbind_Prefix_Equal 383 then 384 -- Ignore an empty prefix 385 386 if Last > Gnatbind_Prefix_Equal'Length then 387 -- There is always a '-' between <prefix> and 388 -- "gnatbind". Add one if not already in <prefix>. 389 390 if Line (Last) /= '-' then 391 Last := Last + 1; 392 Line (Last) := '-'; 393 end if; 394 395 GNATBIND := new String' 396 (Line (Gnatbind_Prefix_Equal'Length + 1 .. Last) & 397 "gnatbind"); 398 end if; 399 400 elsif Last > Ada_Binder_Equal'Length 401 and then Line (1 .. Ada_Binder_Equal'Length) = 402 Ada_Binder_Equal 403 then 404 GNATBIND := new String' 405 (Line (Ada_Binder_Equal'Length + 1 .. Last)); 406 407 -- When -O is used, instead of -O=file, -v is ignored to 408 -- avoid polluting the output. Record occurence of -v and 409 -- check the GNAT version later. 410 411 elsif Line (1 .. Last) = "-v" then 412 Binding_Option_Dash_V_Specified := True; 413 414 -- Ignore -C, as the generated sources are always in Ada 415 416 elsif Line (1 .. Last) /= "-C" then 417 Binding_Options_Table.Append 418 (new String'(Line (1 .. Last))); 419 end if; 420 421 when Project_Files => 422 if End_Of_File (IO_File) then 423 Fail_Program 424 (null, "no time stamp for " & Line (1 .. Last)); 425 426 else 427 declare 428 PS : Path_And_Stamp; 429 430 begin 431 PS.Path := new String'(Line (1 .. Last)); 432 Get_Line (IO_File, Line, Last); 433 PS.Stamp := new String'(Line (1 .. Last)); 434 Project_Paths.Append (PS); 435 end; 436 end if; 437 438 when Gprexch.Toolchain_Version => 439 if End_Of_File (IO_File) then 440 Fail_Program 441 (null, 442 "no toolchain version for language " & 443 Line (1 .. Last)); 444 445 elsif Line (1 .. Last) = "ada" then 446 Get_Line (IO_File, Line, Last); 447 448 if Last > 5 and then Line (1 .. 5) = "GNAT " then 449 GNAT_Version := new String'(Line (6 .. Last)); 450 GNAT_Version_Set := True; 451 end if; 452 453 else 454 Skip_Line (IO_File); 455 end if; 456 457 when Gprexch.Delete_Temp_Files => 458 begin 459 Delete_Temp_Files := Boolean'Value (Line (1 .. Last)); 460 461 exception 462 when Constraint_Error => 463 null; 464 end; 465 466 when Gprexch.Object_File_Suffix => 467 if End_Of_File (IO_File) then 468 Fail_Program 469 (null, 470 "no object file suffix for language " & 471 Line (1 .. Last)); 472 473 elsif Line (1 .. Last) = "ada" then 474 Get_Line (IO_File, Line, Last); 475 Ada_Object_Suffix := new String'(Line (1 .. Last)); 476 477 else 478 Skip_Line (IO_File); 479 end if; 480 481 when Nothing_To_Bind | 482 Generated_Object_File | 483 Generated_Source_Files | 484 Bound_Object_Files | 485 Resulting_Options | 486 Run_Path_Option => 487 null; 488 end case; 489 end if; 490 end if; 491 end loop; 492 493 if Main_Base_Name = null then 494 Fail_Program (null, "no main base name specified"); 495 496 else 497 Binder_Generated_File := 498 new String'("b__" & Main_Base_Name.all & ".adb"); 499 end if; 500 501 Close (IO_File); 502 503 -- Modify binding option -A=<file> if <file> is not an absolute path 504 505 if Project_Paths.Last >= 1 then 506 declare 507 Project_Dir : constant String := 508 Ada.Directories.Containing_Directory 509 (Project_Paths.Table (1).Path.all); 510 begin 511 for J in 1 .. Binding_Options_Table.Last loop 512 if Binding_Options_Table.Table (J)'Length >= 4 and then 513 Binding_Options_Table.Table (J) (1 .. 3) = "-A=" 514 then 515 declare 516 File : constant String := 517 Binding_Options_Table.Table (J) 518 (4 .. Binding_Options_Table.Table (J)'Length); 519 begin 520 if not Is_Absolute_Path (File) then 521 declare 522 New_File : constant String := 523 Normalize_Pathname (File, Project_Dir); 524 begin 525 Binding_Options_Table.Table (J) := 526 new String'("-A=" & New_File); 527 end; 528 end if; 529 end; 530 end if; 531 end loop; 532 end; 533 end if; 534 535 -- Check if GNAT version is 6.4 or higher 536 537 if GNAT_Version_Set 538 and then 539 GNAT_Version'Length > 2 540 and then 541 GNAT_Version.all /= "000" 542 and then 543 GNAT_Version (GNAT_Version'First .. GNAT_Version'First + 1) /= "3." 544 and then 545 GNAT_Version (GNAT_Version'First .. GNAT_Version'First + 1) /= "5." 546 then 547 GNAT_6_Or_Higher := True; 548 549 if GNAT_Version (GNAT_Version'First .. GNAT_Version'First + 1) /= "6." 550 or else 551 GNAT_Version.all >= "6.4" 552 then 553 GNAT_6_4_Or_Higher := True; 554 end if; 555 end if; 556 557 -- Check if binding option -v was specified and issue it only if the GNAT 558 -- version is 6.4 or higher, otherwise the output of gnatbind -O will be 559 -- polluted. 560 561 if Binding_Option_Dash_V_Specified and then GNAT_6_4_Or_Higher then 562 Binding_Options_Table.Append (new String'("-v")); 563 end if; 564 565 if not Static_Libs then 566 Add (Dash_shared, Gnatbind_Options, Last_Gnatbind_Option); 567 end if; 568 569 -- Specify the name of the generated file to gnatbind 570 571 Add (Dash_o, Gnatbind_Options, Last_Gnatbind_Option); 572 Add 573 (Binder_Generated_File.all, 574 Gnatbind_Options, 575 Last_Gnatbind_Option); 576 577 if not Is_Regular_File (Ada_Compiler_Path.all) then 578 Fail_Program (null, "could not find the Ada compiler"); 579 end if; 580 581 if Main_ALI /= null then 582 Add (Main_ALI.all, Gnatbind_Options, Last_Gnatbind_Option); 583 end if; 584 585 -- If there are Stand-Alone Libraries, invoke gnatbind with -F (generate 586 -- checks of elaboration flags) to avoid multiple elaborations. 587 588 if There_Are_Stand_Alone_Libraries 589 and then GNAT_Version_Set 590 and then GNAT_Version'Length > 2 591 and then GNAT_Version (GNAT_Version'First .. GNAT_Version'First + 1) /= 592 "3." 593 then 594 Add ("-F", Gnatbind_Options, Last_Gnatbind_Option); 595 end if; 596 597 for J in 1 .. ALI_Files_Table.Last loop 598 Add (ALI_Files_Table.Table (J), Gnatbind_Options, Last_Gnatbind_Option); 599 end loop; 600 601 for J in 1 .. Binding_Options_Table.Last loop 602 Add 603 (Binding_Options_Table.Table (J), 604 Gnatbind_Options, 605 Last_Gnatbind_Option); 606 607 if Binding_Options_Table.Table (J).all = Dash_OO then 608 Dash_O_Specified := True; 609 610 elsif Binding_Options_Table.Table (J)'Length >= 4 and then 611 Binding_Options_Table.Table (J) (1 .. 3) = Dash_OO & '=' 612 then 613 Dash_O_Specified := True; 614 Dash_O_File_Specified := True; 615 Name_Len := 0; 616 Add_Str_To_Name_Buffer 617 (Binding_Options_Table.Table (J) 618 (4 .. Binding_Options_Table.Table (J)'Last)); 619 Objects_Path := Name_Find; 620 end if; 621 end loop; 622 623 -- Add -x at the end, so that if -s is specified in the binding options, 624 -- gnatbind does not try to look for sources, as the binder mapping file 625 -- specified by -F- is not for sources, but for ALI files. 626 627 Add (Dash_x, Gnatbind_Options, Last_Gnatbind_Option); 628 629 if Ada_Compiler_Path = null or else 630 Is_Absolute_Path (GNATBIND.all) 631 then 632 FULL_GNATBIND := GNATBIND; 633 634 else 635 FULL_GNATBIND := 636 new String' 637 (Dir_Name (Ada_Compiler_Path.all) & 638 Directory_Separator & 639 GNATBIND.all); 640 end if; 641 642 if Gnatbind_Path_Specified then 643 FULL_GNATBIND := Gnatbind_Path; 644 end if; 645 646 Gnatbind_Path := Locate_Exec_On_Path (FULL_GNATBIND.all); 647 648 -- If gnatbind is not found and its full path was not specified, check for 649 -- gnatbind on the path. 650 651 if Gnatbind_Path = null and then not Gnatbind_Path_Specified then 652 Gnatbind_Path := Locate_Exec_On_Path (GNATBIND.all); 653 end if; 654 655 if Gnatbind_Path = null then 656 -- Make sure Namelen has a non negative value 657 658 Name_Len := 0; 659 660 declare 661 Path_Of_Gnatbind : String_Access := GNATBIND; 662 begin 663 664 if Gnatbind_Path_Specified then 665 Path_Of_Gnatbind := FULL_GNATBIND; 666 end if; 667 668 Finish_Program 669 (null, 670 Osint.E_Fatal, 671 "could not locate " & Path_Of_Gnatbind.all); 672 end; 673 674 else 675 -- Normalize the path, so that gnaampbind does not complain about not 676 -- being in a "bin" directory. But don't resolve symbolic links, 677 -- because in GNAT 5.01a1 and previous releases, gnatbind was a symbolic 678 -- link for .gnat_wrapper. 679 680 Gnatbind_Path := 681 new String' 682 (Normalize_Pathname (Gnatbind_Path.all, Resolve_Links => False)); 683 end if; 684 685 if Main_ALI = null then 686 Add (No_Main_Option, Gnatbind_Options, Last_Gnatbind_Option); 687 end if; 688 689 -- Add the switch -F=<mapping file> if the mapping file was specified 690 -- and the version of GNAT is recent enough. 691 692 if Mapping_File /= null 693 and then GNAT_Version_Set 694 and then GNAT_Version'Length > 2 695 and then GNAT_Version (GNAT_Version'First .. GNAT_Version'First + 1) /= 696 "3." 697 then 698 Add (Dash_Fequal & Mapping_File.all, 699 Gnatbind_Options, 700 Last_Gnatbind_Option); 701 end if; 702 703 -- Create temporary file to get the list of objects 704 705 if not Dash_O_File_Specified then 706 Tempdir.Create_Temp_File (FD_Objects, Objects_Path); 707 end if; 708 709 if GNAT_6_4_Or_Higher then 710 if not Dash_O_File_Specified then 711 Add 712 (Dash_OO & "=" & Get_Name_String (Objects_Path), 713 Gnatbind_Options, 714 Last_Gnatbind_Option); 715 Close (FD_Objects); 716 end if; 717 718 elsif not Dash_O_Specified then 719 Add (Dash_OO, Gnatbind_Options, Last_Gnatbind_Option); 720 end if; 721 722 if not Quiet_Output then 723 if Verbose_Mode then 724 Display_Last := 0; 725 Add_To_Display_Line (Gnatbind_Path.all); 726 727 for Option in 1 .. Last_Gnatbind_Option loop 728 Add_To_Display_Line (Gnatbind_Options (Option).all); 729 end loop; 730 731 Put_Line (Display_Line (1 .. Display_Last)); 732 733 else 734 if Main_ALI /= null then 735 Display 736 (Section => GPR.Bind, 737 Command => "Ada", 738 Argument => Base_Name (Main_ALI.all)); 739 740 elsif ALI_Files_Table.Last > 0 then 741 Display 742 (Section => GPR.Bind, 743 Command => "Ada", 744 Argument => 745 Base_Name (ALI_Files_Table.Table (1).all) & 746 " " & 747 No_Main_Option); 748 end if; 749 end if; 750 end if; 751 752 declare 753 Size : Natural := 0; 754 755 begin 756 for J in 1 .. Last_Gnatbind_Option loop 757 Size := Size + Gnatbind_Options (J)'Length + 1; 758 end loop; 759 760 -- Invoke gnatbind with the arguments if the size is not too large or 761 -- if the version of GNAT is not recent enough. 762 763 if not GNAT_6_Or_Higher or else Size <= Maximum_Size then 764 if not GNAT_6_4_Or_Higher then 765 Spawn 766 (Gnatbind_Path.all, 767 Gnatbind_Options (1 .. Last_Gnatbind_Option), 768 FD_Objects, 769 Return_Code, 770 Err_To_Out => False); 771 Success := Return_Code = 0; 772 773 else 774 Return_Code := 775 Spawn 776 (Gnatbind_Path.all, 777 Gnatbind_Options (1 .. Last_Gnatbind_Option)); 778 end if; 779 780 else 781 -- Otherwise create a temporary response file 782 783 declare 784 FD : File_Descriptor; 785 Path : Path_Name_Type; 786 Args : Argument_List (1 .. 1); 787 EOL : constant String (1 .. 1) := (1 => ASCII.LF); 788 Status : Integer; 789 Quotes_Needed : Boolean; 790 Last_Char : Natural; 791 Ch : Character; 792 793 begin 794 Tempdir.Create_Temp_File (FD, Path); 795 Args (1) := new String'("@" & Get_Name_String (Path)); 796 797 for J in 1 .. Last_Gnatbind_Option loop 798 799 -- Check if the argument should be quoted 800 801 Quotes_Needed := False; 802 Last_Char := Gnatbind_Options (J)'Length; 803 804 for K in Gnatbind_Options (J)'Range loop 805 Ch := Gnatbind_Options (J) (K); 806 807 if Ch = ' ' or else Ch = ASCII.HT or else Ch = '"' then 808 Quotes_Needed := True; 809 exit; 810 end if; 811 end loop; 812 813 if Quotes_Needed then 814 815 -- Quote the argument, doubling '"' 816 817 declare 818 Arg : String (1 .. Gnatbind_Options (J)'Length * 2 + 2); 819 820 begin 821 Arg (1) := '"'; 822 Last_Char := 1; 823 824 for K in Gnatbind_Options (J)'Range loop 825 Ch := Gnatbind_Options (J) (K); 826 Last_Char := Last_Char + 1; 827 Arg (Last_Char) := Ch; 828 829 if Ch = '"' then 830 Last_Char := Last_Char + 1; 831 Arg (Last_Char) := '"'; 832 end if; 833 end loop; 834 835 Last_Char := Last_Char + 1; 836 Arg (Last_Char) := '"'; 837 838 Status := Write (FD, Arg'Address, Last_Char); 839 end; 840 841 else 842 Status := Write 843 (FD, 844 Gnatbind_Options (J) (Gnatbind_Options (J)'First)'Address, 845 Last_Char); 846 end if; 847 848 if Status /= Last_Char then 849 Fail_Program (null, "disk full"); 850 end if; 851 852 Status := Write (FD, EOL (1)'Address, 1); 853 854 if Status /= 1 then 855 Fail_Program (null, "disk full"); 856 end if; 857 end loop; 858 859 Close (FD); 860 861 -- And invoke gnatbind with this this response file 862 863 if not GNAT_6_4_Or_Higher then 864 Spawn 865 (Gnatbind_Path.all, 866 Args, 867 FD_Objects, 868 Return_Code, 869 Err_To_Out => False); 870 871 else 872 Return_Code := Spawn (Gnatbind_Path.all, Args); 873 end if; 874 875 if Delete_Temp_Files then 876 declare 877 Succ : Boolean; 878 pragma Warnings (Off, Succ); 879 880 begin 881 Delete_File (Get_Name_String (Path), Succ); 882 end; 883 end if; 884 end; 885 end if; 886 end; 887 888 if not GNAT_6_4_Or_Higher and then not Dash_O_File_Specified then 889 Close (FD_Objects); 890 end if; 891 892 if Return_Code /= 0 then 893 if Delete_Temp_Files and not Dash_O_File_Specified then 894 Delete_File (Get_Name_String (Objects_Path), Success); 895 end if; 896 897 Fail_Program (null, "invocation of gnatbind failed"); 898 end if; 899 900 Add (Dash_c, Compiler_Options, Last_Compiler_Option); 901 Add (Dash_gnatA, Compiler_Options, Last_Compiler_Option); 902 Add (Dash_gnatWb, Compiler_Options, Last_Compiler_Option); 903 Add (Dash_gnatiw, Compiler_Options, Last_Compiler_Option); 904 Add (Dash_gnatws, Compiler_Options, Last_Compiler_Option); 905 906 -- Read the ALI file of the first ALI file. Fetch the back end switches 907 -- from this ALI file and use these switches to compile the binder 908 -- generated file. 909 910 if Main_ALI /= null or else ALI_Files_Table.Last >= 1 then 911 Initialize_ALI; 912 Name_Len := 0; 913 914 if Main_ALI /= null then 915 Add_Str_To_Name_Buffer (Main_ALI.all); 916 917 else 918 Add_Str_To_Name_Buffer (ALI_Files_Table.Table (1).all); 919 end if; 920 921 declare 922 F : constant File_Name_Type := Name_Find; 923 T : Text_Buffer_Ptr; 924 A : ALI_Id; 925 926 begin 927 -- Load the ALI file 928 929 T := Osint.Read_Library_Info (F, True); 930 931 -- Read it. Note that we ignore errors, since we only want very 932 -- limited information from the ali file, and likely a slightly 933 -- wrong version will be just fine, though in normal operation 934 -- we don't expect this to happen. 935 936 A := Scan_ALI 937 (F, 938 T, 939 Ignore_ED => False, 940 Err => False, 941 Read_Lines => "A"); 942 943 if A /= No_ALI_Id then 944 for 945 Index in Units.Table (ALIs.Table (A).First_Unit).First_Arg .. 946 Units.Table (ALIs.Table (A).First_Unit).Last_Arg 947 loop 948 -- Do not compile with the front end switches 949 950 declare 951 Arg : String_Access renames Args.Table (Index); 952 Argv : constant String (1 .. Arg'Length) := Arg.all; 953 begin 954 if (Argv'Last <= 2 or else Argv (1 .. 2) /= "-I") 955 and then 956 (Argv'Last <= 5 or else Argv (1 .. 5) /= "-gnat") 957 and then 958 (Argv'Last <= 6 or else Argv (1 .. 6) /= "--RTS=") 959 then 960 Add 961 (String_Access (Arg), 962 Compiler_Options, 963 Last_Compiler_Option); 964 end if; 965 end; 966 end loop; 967 end if; 968 end; 969 end if; 970 971 Add (Binder_Generated_File, Compiler_Options, Last_Compiler_Option); 972 973 declare 974 Object : constant String := 975 "b__" & Main_Base_Name.all & Ada_Object_Suffix.all; 976 begin 977 Add 978 (Dash_o, 979 Compiler_Options, 980 Last_Compiler_Option); 981 Add 982 (Object, 983 Compiler_Options, 984 Last_Compiler_Option); 985 986 if Verbose_Mode then 987 Name_Len := 0; 988 989 Add_Str_To_Name_Buffer (Ada_Compiler_Path.all); 990 991 -- Remove the executable suffix, if present 992 993 if Executable_Suffix'Length > 0 994 and then 995 Name_Len > Executable_Suffix'Length 996 and then 997 Name_Buffer 998 (Name_Len - Executable_Suffix'Length + 1 .. Name_Len) = 999 Executable_Suffix.all 1000 then 1001 Name_Len := Name_Len - Executable_Suffix'Length; 1002 end if; 1003 1004 Display_Last := 0; 1005 Add_To_Display_Line (Name_Buffer (1 .. Name_Len)); 1006 1007 for Option in 1 .. Last_Compiler_Option loop 1008 Add_To_Display_Line (Compiler_Options (Option).all); 1009 end loop; 1010 1011 Put_Line (Display_Line (1 .. Display_Last)); 1012 end if; 1013 1014 -- Add the trailing options, if any 1015 1016 for J in 1 .. Last_Compiler_Trailing_Option loop 1017 Add 1018 (Compiler_Trailing_Options (J), 1019 Compiler_Options, 1020 Last_Compiler_Option); 1021 end loop; 1022 1023 Spawn 1024 (Ada_Compiler_Path.all, 1025 Compiler_Options (1 .. Last_Compiler_Option), 1026 Success); 1027 1028 if not Success then 1029 Fail_Program (null, "compilation of binder generated file failed"); 1030 end if; 1031 1032 -- Find the GCC version 1033 1034 Spawn 1035 (Program_Name => Ada_Compiler_Path.all, 1036 Args => (1 => new String'("-v")), 1037 Output_File => Exchange_File_Name.all, 1038 Success => Success, 1039 Return_Code => Return_Code, 1040 Err_To_Out => True); 1041 1042 if Success then 1043 Open (IO_File, In_File, Exchange_File_Name.all); 1044 while not End_Of_File (IO_File) loop 1045 Get_Line (IO_File, Line, Last); 1046 1047 if Last > Gcc_Version_String'Length and then 1048 Line (1 .. Gcc_Version_String'Length) = Gcc_Version_String 1049 then 1050 GCC_Version := Line (Gcc_Version_String'Length + 1); 1051 exit; 1052 end if; 1053 end loop; 1054 1055 Close (IO_File); 1056 end if; 1057 1058 Create (IO_File, Out_File, Exchange_File_Name.all); 1059 1060 -- First, the generated object file 1061 1062 Put_Line (IO_File, Binding_Label (Generated_Object_File)); 1063 Put_Line (IO_File, Object); 1064 1065 -- Repeat the project paths with their time stamps 1066 1067 Put_Line (IO_File, Binding_Label (Project_Files)); 1068 1069 for J in 1 .. Project_Paths.Last loop 1070 Put_Line (IO_File, Project_Paths.Table (J).Path.all); 1071 Put_Line (IO_File, Project_Paths.Table (J).Stamp.all); 1072 end loop; 1073 1074 -- Get the bound object files from the Object file 1075 1076 Open (Objects_File, In_File, Get_Name_String (Objects_Path)); 1077 1078 Put_Line (IO_File, Binding_Label (Bound_Object_Files)); 1079 1080 while not End_Of_File (Objects_File) loop 1081 Get_Line (Objects_File, Line, Last); 1082 1083 -- Only put in the exchange file the path of the object files. 1084 -- Output anything else on standard output. 1085 1086 if Is_Regular_File (Line (1 .. Last)) then 1087 Put_Line (IO_File, Line (1 .. Last)); 1088 1089 Bound_Files := new Bound_File' 1090 (Name => new String'(Line (1 .. Last)), Next => Bound_Files); 1091 1092 if Dash_O_Specified and then not Dash_O_File_Specified then 1093 Put_Line (Line (1 .. Last)); 1094 end if; 1095 1096 elsif not Dash_O_File_Specified then 1097 Put_Line (Line (1 .. Last)); 1098 end if; 1099 end loop; 1100 1101 Close (Objects_File); 1102 1103 if Delete_Temp_Files and then not Dash_O_File_Specified then 1104 Delete_File (Get_Name_String (Objects_Path), Success); 1105 end if; 1106 1107 -- For the benefit of gprclean, the generated files other than the 1108 -- generated object file. 1109 1110 Put_Line (IO_File, Binding_Label (Generated_Source_Files)); 1111 Put_Line (IO_File, "b__" & Main_Base_Name.all & ".ads"); 1112 Put_Line (IO_File, Binder_Generated_File.all); 1113 Put_Line (IO_File, "b__" & Main_Base_Name.all & ".ali"); 1114 1115 -- Get the options from the binder generated file 1116 1117 Open (BG_File, In_File, Binder_Generated_File.all); 1118 1119 while not End_Of_File (BG_File) loop 1120 Get_Line (BG_File, Line, Last); 1121 exit when Line (1 .. Last) = Begin_Info; 1122 end loop; 1123 1124 if not End_Of_File (BG_File) then 1125 Put_Line (IO_File, Binding_Label (Resulting_Options)); 1126 1127 All_Binding_Options := False; 1128 Xlinker_Seen := False; 1129 Stack_Equal_Seen := False; 1130 loop 1131 Get_Line (BG_File, Line, Last); 1132 exit when Line (1 .. Last) = End_Info; 1133 Line (1 .. Last - 8) := Line (9 .. Last); 1134 Last := Last - 8; 1135 1136 if Line (1) = '-' then 1137 -- After the first switch, we take all options, because some 1138 -- of the options specified in pragma Linker_Options may not 1139 -- start with '-'. 1140 All_Binding_Options := True; 1141 end if; 1142 1143 Get_Option := 1144 All_Binding_Options 1145 or else 1146 (Base_Name (Line (1 .. Last)) = "g-trasym.o") 1147 or else 1148 (Base_Name (Line (1 .. Last)) = "g-trasym.obj"); 1149 -- g-trasym is a special case as it is not included in libgnat 1150 1151 -- Avoid duplication of object file 1152 1153 if Get_Option then 1154 declare 1155 BF : Bound_File_Access := Bound_Files; 1156 1157 begin 1158 while BF /= null loop 1159 if BF.Name.all = Line (1 .. Last) then 1160 Get_Option := False; 1161 exit; 1162 1163 else 1164 BF := BF.Next; 1165 end if; 1166 end loop; 1167 end; 1168 end if; 1169 1170 if Get_Option then 1171 if Line (1 .. Last) = "-Xlinker" then 1172 Xlinker_Seen := True; 1173 1174 elsif Xlinker_Seen then 1175 Xlinker_Seen := False; 1176 1177 -- Make sure that only the first switch --stack= is put in 1178 -- the exchange file. 1179 1180 if Last > 8 and then Line (1 .. 8) = "--stack=" then 1181 if not Stack_Equal_Seen then 1182 Stack_Equal_Seen := True; 1183 Put_Line (IO_File, "-Xlinker"); 1184 Put_Line (IO_File, Line (1 .. Last)); 1185 end if; 1186 1187 else 1188 Put_Line (IO_File, "-Xlinker"); 1189 Put_Line (IO_File, Line (1 .. Last)); 1190 end if; 1191 1192 elsif Last > 12 and then Line (1 .. 12) = "-Wl,--stack=" then 1193 if not Stack_Equal_Seen then 1194 Stack_Equal_Seen := True; 1195 Put_Line (IO_File, Line (1 .. Last)); 1196 end if; 1197 1198 elsif Last >= 3 and then Line (1 .. 2) = "-L" then 1199 -- Set Adalib_Dir only if libgnat is found inside. 1200 if Is_Regular_File 1201 (Line (3 .. Last) & Directory_Separator & "libgnat.a") 1202 then 1203 Adalib_Dir := new String'(Line (3 .. Last)); 1204 1205 if Verbose_Mode then 1206 Put_Line ("Adalib_Dir = """ & Adalib_Dir.all & '"'); 1207 end if; 1208 1209 -- Build the Prefix_Path, where to look for some 1210 -- archives: libaddr2line.a, libbfd.a, libgnatmon.a, 1211 -- libgnalasup.a and libiberty.a. It contains three 1212 -- directories: $(adalib)/.., $(adalib)/../.. and the 1213 -- subdirectory "lib" ancestor of $(adalib). 1214 1215 declare 1216 Dir_Last : Positive; 1217 Prev_Dir_Last : Positive; 1218 First : Positive; 1219 Prev_Dir_First : Positive; 1220 Nmb : Natural; 1221 begin 1222 Name_Len := 0; 1223 Add_Str_To_Name_Buffer (Line (3 .. Last)); 1224 1225 while Name_Buffer (Name_Len) = Directory_Separator 1226 or else Name_Buffer (Name_Len) = '/' 1227 loop 1228 Name_Len := Name_Len - 1; 1229 end loop; 1230 1231 while Name_Buffer (Name_Len) /= Directory_Separator 1232 and then Name_Buffer (Name_Len) /= '/' 1233 loop 1234 Name_Len := Name_Len - 1; 1235 end loop; 1236 1237 while Name_Buffer (Name_Len) = Directory_Separator 1238 or else Name_Buffer (Name_Len) = '/' 1239 loop 1240 Name_Len := Name_Len - 1; 1241 end loop; 1242 1243 Dir_Last := Name_Len; 1244 Nmb := 0; 1245 1246 Dir_Loop : loop 1247 Prev_Dir_Last := Dir_Last; 1248 First := Dir_Last - 1; 1249 while First > 3 1250 and then 1251 Name_Buffer (First) /= Directory_Separator 1252 and then 1253 Name_Buffer (First) /= '/' 1254 loop 1255 First := First - 1; 1256 end loop; 1257 1258 Prev_Dir_First := First + 1; 1259 1260 exit Dir_Loop when First <= 3; 1261 1262 Dir_Last := First - 1; 1263 while Name_Buffer (Dir_Last) = Directory_Separator 1264 or else Name_Buffer (Dir_Last) = '/' 1265 loop 1266 Dir_Last := Dir_Last - 1; 1267 end loop; 1268 1269 Nmb := Nmb + 1; 1270 1271 if Nmb <= 1 then 1272 Add_Char_To_Name_Buffer (Path_Separator); 1273 Add_Str_To_Name_Buffer 1274 (Name_Buffer (1 .. Dir_Last)); 1275 1276 elsif Name_Buffer (Prev_Dir_First .. Prev_Dir_Last) 1277 = "lib" 1278 then 1279 Add_Char_To_Name_Buffer (Path_Separator); 1280 Add_Str_To_Name_Buffer 1281 (Name_Buffer (1 .. Prev_Dir_Last)); 1282 exit Dir_Loop; 1283 end if; 1284 end loop Dir_Loop; 1285 1286 Prefix_Path := 1287 new String'(Name_Buffer (1 .. Name_Len)); 1288 1289 if Verbose_Mode then 1290 Put_Line 1291 ("Prefix_Path = """ & Prefix_Path.all & '"'); 1292 end if; 1293 end; 1294 end if; 1295 Put_Line (IO_File, Line (1 .. Last)); 1296 1297 elsif Line (1 .. Last) = Static_Libgcc then 1298 Put_Line (IO_File, Line (1 .. Last)); 1299 Libgcc_Specified := True; 1300 1301 elsif Line (1 .. Last) = Shared_Libgcc then 1302 Put_Line (IO_File, Line (1 .. Last)); 1303 Libgcc_Specified := True; 1304 1305 elsif Line (1 .. Last) = "-static" then 1306 Static_Libs := True; 1307 Put_Line (IO_File, Line (1 .. Last)); 1308 1309 if Shared_Libgcc_Default = 'T' 1310 and then GCC_Version >= '3' 1311 and then not Libgcc_Specified 1312 then 1313 Put_Line (IO_File, Static_Libgcc); 1314 end if; 1315 1316 elsif Line (1 .. Last) = "-shared" then 1317 Static_Libs := False; 1318 Put_Line (IO_File, Line (1 .. Last)); 1319 1320 if GCC_Version >= '3' 1321 and then not Libgcc_Specified 1322 then 1323 Put_Line (IO_File, Shared_Libgcc); 1324 end if; 1325 1326 -- For a number of archives, we need to indicate the full 1327 -- path of the archive, if we find it, to be sure that the 1328 -- correct archive is used by the linker. 1329 1330 elsif Line (1 .. Last) = "-lgnat" then 1331 if Adalib_Dir = null then 1332 if Verbose_Mode then 1333 Put_Line ("No Adalib_Dir"); 1334 end if; 1335 1336 Put_Line (IO_File, "-lgnat"); 1337 1338 elsif Static_Libs then 1339 Put_Line (IO_File, Adalib_Dir.all & "libgnat.a"); 1340 1341 else 1342 Put_Line (IO_File, "-lgnat"); 1343 end if; 1344 1345 elsif Line (1 .. Last) = "-lgnarl" and then 1346 Static_Libs and then 1347 Adalib_Dir /= null 1348 then 1349 Put_Line (IO_File, Adalib_Dir.all & "libgnarl.a"); 1350 1351 elsif Line (1 .. Last) = "-laddr2line" 1352 and then Prefix_Path /= null 1353 then 1354 Lib_Path := Locate_Regular_File 1355 ("libaddr2line.a", Prefix_Path.all); 1356 1357 if Lib_Path /= null then 1358 Put_Line (IO_File, Lib_Path.all); 1359 Free (Lib_Path); 1360 1361 else 1362 Put_Line (IO_File, Line (1 .. Last)); 1363 end if; 1364 1365 elsif Line (1 .. Last) = "-lbfd" 1366 and then Prefix_Path /= null 1367 then 1368 Lib_Path := Locate_Regular_File 1369 ("libbfd.a", Prefix_Path.all); 1370 1371 if Lib_Path /= null then 1372 Put_Line (IO_File, Lib_Path.all); 1373 Free (Lib_Path); 1374 1375 else 1376 Put_Line (IO_File, Line (1 .. Last)); 1377 end if; 1378 1379 elsif Line (1 .. Last) = "-lgnalasup" 1380 and then Prefix_Path /= null 1381 then 1382 Lib_Path := Locate_Regular_File 1383 ("libgnalasup.a", Prefix_Path.all); 1384 1385 if Lib_Path /= null then 1386 Put_Line (IO_File, Lib_Path.all); 1387 Free (Lib_Path); 1388 1389 else 1390 Put_Line (IO_File, Line (1 .. Last)); 1391 end if; 1392 1393 elsif Line (1 .. Last) = "-lgnatmon" 1394 and then Prefix_Path /= null 1395 then 1396 Lib_Path := Locate_Regular_File 1397 ("libgnatmon.a", Prefix_Path.all); 1398 1399 if Lib_Path /= null then 1400 Put_Line (IO_File, Lib_Path.all); 1401 Free (Lib_Path); 1402 1403 else 1404 Put_Line (IO_File, Line (1 .. Last)); 1405 end if; 1406 1407 elsif Line (1 .. Last) = "-liberty" 1408 and then Prefix_Path /= null 1409 then 1410 Lib_Path := Locate_Regular_File 1411 ("libiberty.a", Prefix_Path.all); 1412 1413 if Lib_Path /= null then 1414 Put_Line (IO_File, Lib_Path.all); 1415 Free (Lib_Path); 1416 1417 else 1418 Put_Line (IO_File, Line (1 .. Last)); 1419 end if; 1420 1421 else 1422 Put_Line (IO_File, Line (1 .. Last)); 1423 end if; 1424 end if; 1425 end loop; 1426 end if; 1427 1428 Close (BG_File); 1429 1430 if not Static_Libs 1431 and then Adalib_Dir /= null 1432 then 1433 Put_Line (IO_File, Binding_Label (Run_Path_Option)); 1434 Put_Line (IO_File, Adalib_Dir.all); 1435 Name_Len := Adalib_Dir'Length; 1436 Name_Buffer (1 .. Name_Len) := Adalib_Dir.all; 1437 1438 for J in reverse 2 .. Name_Len - 4 loop 1439 if Name_Buffer (J) = Directory_Separator and then 1440 Name_Buffer (J + 4) = Directory_Separator and then 1441 Name_Buffer (J + 1 .. J + 3) = "lib" 1442 then 1443 Name_Len := J + 3; 1444 Put_Line (IO_File, Name_Buffer (1 .. Name_Len)); 1445 exit; 1446 end if; 1447 end loop; 1448 end if; 1449 1450 Close (IO_File); 1451 end; 1452end Gprbind; 1453