1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- G N A T L I N K -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1996-2015, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26-- Gnatlink usage: please consult the gnat documentation 27 28with ALI; use ALI; 29with Csets; 30with Gnatvsn; use Gnatvsn; 31with Indepsw; use Indepsw; 32with Namet; use Namet; 33with Opt; 34with Osint; use Osint; 35with Output; use Output; 36with Snames; 37with Switch; use Switch; 38with System; use System; 39with Table; 40with Targparm; use Targparm; 41with Types; 42 43with Ada.Command_Line; use Ada.Command_Line; 44with Ada.Exceptions; use Ada.Exceptions; 45 46with System.OS_Lib; use System.OS_Lib; 47with System.CRTL; 48 49with Interfaces.C_Streams; use Interfaces.C_Streams; 50with Interfaces.C.Strings; use Interfaces.C.Strings; 51 52procedure Gnatlink is 53 pragma Ident (Gnatvsn.Gnat_Static_Version_String); 54 55 Shared_Libgcc_String : constant String := "-shared-libgcc"; 56 Shared_Libgcc : constant String_Access := 57 new String'(Shared_Libgcc_String); 58 -- Used to invoke gcc when the binder is invoked with -shared 59 60 Static_Libgcc_String : constant String := "-static-libgcc"; 61 Static_Libgcc : constant String_Access := 62 new String'(Static_Libgcc_String); 63 -- Used to invoke gcc when shared libs are not used 64 65 package Gcc_Linker_Options is new Table.Table ( 66 Table_Component_Type => String_Access, 67 Table_Index_Type => Integer, 68 Table_Low_Bound => 1, 69 Table_Initial => 20, 70 Table_Increment => 100, 71 Table_Name => "Gnatlink.Gcc_Linker_Options"); 72 -- Comments needed ??? 73 74 package Libpath is new Table.Table ( 75 Table_Component_Type => Character, 76 Table_Index_Type => Integer, 77 Table_Low_Bound => 1, 78 Table_Initial => 4096, 79 Table_Increment => 100, 80 Table_Name => "Gnatlink.Libpath"); 81 -- Comments needed ??? 82 83 package Linker_Options is new Table.Table ( 84 Table_Component_Type => String_Access, 85 Table_Index_Type => Integer, 86 Table_Low_Bound => 1, 87 Table_Initial => 20, 88 Table_Increment => 100, 89 Table_Name => "Gnatlink.Linker_Options"); 90 -- Comments needed ??? 91 92 package Linker_Objects is new Table.Table ( 93 Table_Component_Type => String_Access, 94 Table_Index_Type => Integer, 95 Table_Low_Bound => 1, 96 Table_Initial => 20, 97 Table_Increment => 100, 98 Table_Name => "Gnatlink.Linker_Objects"); 99 -- This table collects the objects file to be passed to the linker. In the 100 -- case where the linker command line is too long then programs objects 101 -- are put on the Response_File_Objects table. Note that the binder object 102 -- file and the user's objects remain in this table. This is very 103 -- important because on the GNU linker command line the -L switch is not 104 -- used to look for objects files but -L switch is used to look for 105 -- objects listed in the response file. This is not a problem with the 106 -- applications objects as they are specified with a full name. 107 108 package Response_File_Objects is new Table.Table ( 109 Table_Component_Type => String_Access, 110 Table_Index_Type => Integer, 111 Table_Low_Bound => 1, 112 Table_Initial => 20, 113 Table_Increment => 100, 114 Table_Name => "Gnatlink.Response_File_Objects"); 115 -- This table collects the objects file that are to be put in the response 116 -- file. Only application objects are collected there (see details in 117 -- Linker_Objects table comments) 118 119 package Binder_Options_From_ALI is new Table.Table ( 120 Table_Component_Type => String_Access, 121 Table_Index_Type => Integer, 122 Table_Low_Bound => 1, -- equals low bound of Argument_List for Spawn 123 Table_Initial => 20, 124 Table_Increment => 100, 125 Table_Name => "Gnatlink.Binder_Options_From_ALI"); 126 -- This table collects the switches from the ALI file of the main 127 -- subprogram. 128 129 package Binder_Options is new Table.Table ( 130 Table_Component_Type => String_Access, 131 Table_Index_Type => Integer, 132 Table_Low_Bound => 1, -- equals low bound of Argument_List for Spawn 133 Table_Initial => 20, 134 Table_Increment => 100, 135 Table_Name => "Gnatlink.Binder_Options"); 136 -- This table collects the arguments to be passed to compile the binder 137 -- generated file. 138 139 Gcc : String_Access := Program_Name ("gcc", "gnatlink"); 140 141 Read_Mode : constant String := "r" & ASCII.NUL; 142 143 Begin_Info : constant String := "-- BEGIN Object file/option list"; 144 End_Info : constant String := "-- END Object file/option list "; 145 146 Gcc_Path : String_Access; 147 Linker_Path : String_Access; 148 Output_File_Name : String_Access; 149 Ali_File_Name : String_Access; 150 Binder_Spec_Src_File : String_Access; 151 Binder_Body_Src_File : String_Access; 152 Binder_Ali_File : String_Access; 153 Binder_Obj_File : String_Access; 154 155 Base_Command_Name : String_Access; 156 157 Tname : Temp_File_Name; 158 Tname_FD : File_Descriptor := Invalid_FD; 159 -- Temporary file used by linker to pass list of object files on 160 -- certain systems with limitations on size of arguments. 161 162 Debug_Flag_Present : Boolean := False; 163 Verbose_Mode : Boolean := False; 164 Very_Verbose_Mode : Boolean := False; 165 166 Standard_Gcc : Boolean := True; 167 168 Compile_Bind_File : Boolean := True; 169 -- Set to False if bind file is not to be compiled 170 171 Create_Map_File : Boolean := False; 172 -- Set to True by switch -M. The map file name is derived from 173 -- the ALI file name (mainprog.ali => mainprog.map). 174 175 Object_List_File_Supported : Boolean; 176 for Object_List_File_Supported'Size use Character'Size; 177 pragma Import 178 (C, Object_List_File_Supported, "__gnat_objlist_file_supported"); 179 -- Predicate indicating whether the linker has an option whereby the 180 -- names of object files can be passed to the linker in a file. 181 182 Object_File_Option_Ptr : Interfaces.C.Strings.chars_ptr; 183 pragma Import (C, Object_File_Option_Ptr, "__gnat_object_file_option"); 184 -- Pointer to a string representing the linker option which specifies 185 -- the response file. 186 187 Object_File_Option : constant String := Value (Object_File_Option_Ptr); 188 -- The linker option which specifies the response file as a string 189 190 Using_GNU_response_file : constant Boolean := 191 Object_File_Option'Length > 0 192 and then Object_File_Option (Object_File_Option'Last) = '@'; 193 -- Whether a GNU response file is used 194 195 Object_List_File_Required : Boolean := False; 196 -- Set to True to force generation of a response file 197 198 Shared_Libgcc_Default : Character; 199 for Shared_Libgcc_Default'Size use Character'Size; 200 pragma Import 201 (C, Shared_Libgcc_Default, "__gnat_shared_libgcc_default"); 202 -- Indicates wether libgcc should be statically linked (use 'T') or 203 -- dynamically linked (use 'H') by default. 204 205 function Base_Name (File_Name : String) return String; 206 -- Return just the file name part without the extension (if present) 207 208 procedure Check_Existing_Executable (File_Name : String); 209 -- Delete any existing executable to avoid accidentally updating the target 210 -- of a symbolic link, but produce a Fatail_Error if File_Name matches any 211 -- of the source file names. This avoids overwriting of extensionless 212 -- source files by accident on systems where executables do not have 213 -- extensions. 214 215 procedure Delete (Name : String); 216 -- Wrapper to unlink as status is ignored by this application 217 218 procedure Error_Msg (Message : String); 219 -- Output the error or warning Message 220 221 procedure Exit_With_Error (Error : String); 222 -- Output Error and exit program with a fatal condition 223 224 procedure Process_Args; 225 -- Go through all the arguments and build option tables 226 227 procedure Process_Binder_File (Name : String); 228 -- Reads the binder file and extracts linker arguments 229 230 procedure Usage; 231 -- Display usage 232 233 procedure Write_Header; 234 -- Show user the program name, version and copyright 235 236 procedure Write_Usage; 237 -- Show user the program options 238 239 --------------- 240 -- Base_Name -- 241 --------------- 242 243 function Base_Name (File_Name : String) return String is 244 Findex1 : Natural; 245 Findex2 : Natural; 246 247 begin 248 Findex1 := File_Name'First; 249 250 -- The file might be specified by a full path name. However, 251 -- we want the path to be stripped away. 252 253 for J in reverse File_Name'Range loop 254 if Is_Directory_Separator (File_Name (J)) then 255 Findex1 := J + 1; 256 exit; 257 end if; 258 end loop; 259 260 Findex2 := File_Name'Last; 261 while Findex2 > Findex1 and then File_Name (Findex2) /= '.' loop 262 Findex2 := Findex2 - 1; 263 end loop; 264 265 if Findex2 = Findex1 then 266 Findex2 := File_Name'Last + 1; 267 end if; 268 269 return File_Name (Findex1 .. Findex2 - 1); 270 end Base_Name; 271 272 ------------------------------- 273 -- Check_Existing_Executable -- 274 ------------------------------- 275 276 procedure Check_Existing_Executable (File_Name : String) is 277 Ename : String := File_Name; 278 Efile : File_Name_Type; 279 Sfile : File_Name_Type; 280 281 begin 282 Canonical_Case_File_Name (Ename); 283 Name_Len := 0; 284 Add_Str_To_Name_Buffer (Ename); 285 Efile := Name_Find; 286 287 for J in Units.Table'First .. Units.Last loop 288 Sfile := Units.Table (J).Sfile; 289 if Sfile = Efile then 290 Exit_With_Error 291 ("executable name """ & File_Name & """ matches " 292 & "source file name """ & Get_Name_String (Sfile) & """"); 293 end if; 294 end loop; 295 296 Delete (File_Name); 297 end Check_Existing_Executable; 298 299 ------------ 300 -- Delete -- 301 ------------ 302 303 procedure Delete (Name : String) is 304 Status : int; 305 pragma Unreferenced (Status); 306 begin 307 Status := unlink (Name'Address); 308 -- Is it really right to ignore an error here ??? 309 end Delete; 310 311 --------------- 312 -- Error_Msg -- 313 --------------- 314 315 procedure Error_Msg (Message : String) is 316 begin 317 Write_Str (Base_Command_Name.all); 318 Write_Str (": "); 319 Write_Str (Message); 320 Write_Eol; 321 end Error_Msg; 322 323 --------------------- 324 -- Exit_With_Error -- 325 --------------------- 326 327 procedure Exit_With_Error (Error : String) is 328 begin 329 Error_Msg (Error); 330 Exit_Program (E_Fatal); 331 end Exit_With_Error; 332 333 ------------------ 334 -- Process_Args -- 335 ------------------ 336 337 procedure Process_Args is 338 Next_Arg : Integer; 339 340 Skip_Next : Boolean := False; 341 -- Set to true if the next argument is to be added into the list of 342 -- linker's argument without parsing it. 343 344 procedure Check_Version_And_Help is new Check_Version_And_Help_G (Usage); 345 346 -- Start of processing for Process_Args 347 348 begin 349 -- First, check for --version and --help 350 351 Check_Version_And_Help ("GNATLINK", "1996"); 352 353 -- Loop through arguments of gnatlink command 354 355 Next_Arg := 1; 356 loop 357 exit when Next_Arg > Argument_Count; 358 359 Process_One_Arg : declare 360 Arg : constant String := Argument (Next_Arg); 361 362 begin 363 -- Case of argument which is a switch 364 365 -- We definitely need section by section comments here ??? 366 367 if Skip_Next then 368 369 -- This argument must not be parsed, just add it to the 370 -- list of linker's options. 371 372 Skip_Next := False; 373 374 Linker_Options.Increment_Last; 375 Linker_Options.Table (Linker_Options.Last) := 376 new String'(Arg); 377 378 elsif Arg'Length /= 0 and then Arg (1) = '-' then 379 if Arg'Length > 4 and then Arg (2 .. 5) = "gnat" then 380 Exit_With_Error 381 ("invalid switch: """ & Arg & """ (gnat not needed here)"); 382 end if; 383 384 if Arg = "-Xlinker" then 385 386 -- Next argument should be sent directly to the linker. 387 -- We do not want to parse it here. 388 389 Skip_Next := True; 390 391 Linker_Options.Increment_Last; 392 Linker_Options.Table (Linker_Options.Last) := 393 new String'(Arg); 394 395 elsif Arg (2) = 'g' 396 and then (Arg'Length < 5 or else Arg (2 .. 5) /= "gnat") 397 then 398 Debug_Flag_Present := True; 399 400 Linker_Options.Increment_Last; 401 Linker_Options.Table (Linker_Options.Last) := 402 new String'(Arg); 403 404 Binder_Options.Increment_Last; 405 Binder_Options.Table (Binder_Options.Last) := 406 Linker_Options.Table (Linker_Options.Last); 407 408 elsif Arg'Length >= 3 and then Arg (2) = 'M' then 409 declare 410 Switches : String_List_Access; 411 412 begin 413 Convert (Map_File, Arg (3 .. Arg'Last), Switches); 414 415 if Switches /= null then 416 for J in Switches'Range loop 417 Linker_Options.Increment_Last; 418 Linker_Options.Table (Linker_Options.Last) := 419 Switches (J); 420 end loop; 421 end if; 422 end; 423 424 elsif Arg'Length = 2 then 425 case Arg (2) is 426 when 'b' => 427 Linker_Options.Increment_Last; 428 Linker_Options.Table (Linker_Options.Last) := 429 new String'(Arg); 430 431 Binder_Options.Increment_Last; 432 Binder_Options.Table (Binder_Options.Last) := 433 Linker_Options.Table (Linker_Options.Last); 434 435 Next_Arg := Next_Arg + 1; 436 437 if Next_Arg > Argument_Count then 438 Exit_With_Error ("Missing argument for -b"); 439 end if; 440 441 Get_Machine_Name : declare 442 Name_Arg : constant String_Access := 443 new String'(Argument (Next_Arg)); 444 445 begin 446 Linker_Options.Increment_Last; 447 Linker_Options.Table (Linker_Options.Last) := 448 Name_Arg; 449 450 Binder_Options.Increment_Last; 451 Binder_Options.Table (Binder_Options.Last) := 452 Name_Arg; 453 454 end Get_Machine_Name; 455 456 when 'f' => 457 if Object_List_File_Supported then 458 Object_List_File_Required := True; 459 else 460 Exit_With_Error 461 ("Object list file not supported on this target"); 462 end if; 463 464 when 'M' => 465 Create_Map_File := True; 466 467 when 'n' => 468 Compile_Bind_File := False; 469 470 when 'o' => 471 Next_Arg := Next_Arg + 1; 472 473 if Next_Arg > Argument_Count then 474 Exit_With_Error ("Missing argument for -o"); 475 end if; 476 477 Output_File_Name := 478 new String'(Executable_Name 479 (Argument (Next_Arg), 480 Only_If_No_Suffix => True)); 481 482 when 'P' => 483 Opt.CodePeer_Mode := True; 484 485 when 'R' => 486 Opt.Run_Path_Option := False; 487 488 when 'v' => 489 490 -- Support "double" verbose mode. Second -v 491 -- gets sent to the linker and binder phases. 492 493 if Verbose_Mode then 494 Very_Verbose_Mode := True; 495 496 Linker_Options.Increment_Last; 497 Linker_Options.Table (Linker_Options.Last) := 498 new String'(Arg); 499 500 Binder_Options.Increment_Last; 501 Binder_Options.Table (Binder_Options.Last) := 502 Linker_Options.Table (Linker_Options.Last); 503 504 else 505 Verbose_Mode := True; 506 507 end if; 508 509 when others => 510 Linker_Options.Increment_Last; 511 Linker_Options.Table (Linker_Options.Last) := 512 new String'(Arg); 513 514 end case; 515 516 elsif Arg (2) = 'B' then 517 Linker_Options.Increment_Last; 518 Linker_Options.Table (Linker_Options.Last) := 519 new String'(Arg); 520 521 Binder_Options.Increment_Last; 522 Binder_Options.Table (Binder_Options.Last) := 523 Linker_Options.Table (Linker_Options.Last); 524 525 elsif Arg'Length >= 7 and then Arg (1 .. 7) = "--LINK=" then 526 if Arg'Length = 7 then 527 Exit_With_Error ("Missing argument for --LINK="); 528 end if; 529 530 Linker_Path := 531 System.OS_Lib.Locate_Exec_On_Path (Arg (8 .. Arg'Last)); 532 533 if Linker_Path = null then 534 Exit_With_Error 535 ("Could not locate linker: " & Arg (8 .. Arg'Last)); 536 end if; 537 538 elsif Arg'Length > 6 and then Arg (1 .. 6) = "--GCC=" then 539 declare 540 Program_Args : constant Argument_List_Access := 541 Argument_String_To_List 542 (Arg (7 .. Arg'Last)); 543 544 begin 545 if Program_Args.all (1).all /= Gcc.all then 546 Gcc := new String'(Program_Args.all (1).all); 547 Standard_Gcc := False; 548 end if; 549 550 -- Set appropriate flags for switches passed 551 552 for J in 2 .. Program_Args.all'Last loop 553 declare 554 Arg : constant String := Program_Args.all (J).all; 555 AF : constant Integer := Arg'First; 556 557 begin 558 if Arg'Length /= 0 and then Arg (AF) = '-' then 559 if Arg (AF + 1) = 'g' 560 and then (Arg'Length = 2 561 or else Arg (AF + 2) in '0' .. '3' 562 or else Arg (AF + 2 .. Arg'Last) = "coff") 563 then 564 Debug_Flag_Present := True; 565 end if; 566 end if; 567 568 -- Add directory to source search dirs so that 569 -- Get_Target_Parameters can find system.ads 570 571 if Arg (AF .. AF + 1) = "-I" 572 and then Arg'Length > 2 573 then 574 Add_Src_Search_Dir (Arg (AF + 2 .. Arg'Last)); 575 end if; 576 577 -- Pass to gcc for compiling binder generated file 578 -- No use passing libraries, it will just generate 579 -- a warning 580 581 if not (Arg (AF .. AF + 1) = "-l" 582 or else Arg (AF .. AF + 1) = "-L") 583 then 584 Binder_Options.Increment_Last; 585 Binder_Options.Table (Binder_Options.Last) := 586 new String'(Arg); 587 end if; 588 589 -- Pass to gcc for linking program 590 591 Gcc_Linker_Options.Increment_Last; 592 Gcc_Linker_Options.Table 593 (Gcc_Linker_Options.Last) := new String'(Arg); 594 end; 595 end loop; 596 end; 597 598 -- Send all multi-character switches not recognized as 599 -- a special case by gnatlink to the linker/loader stage. 600 601 else 602 Linker_Options.Increment_Last; 603 Linker_Options.Table (Linker_Options.Last) := 604 new String'(Arg); 605 end if; 606 607 -- Here if argument is a file name rather than a switch 608 609 else 610 -- If explicit ali file, capture it 611 612 if Arg'Length > 4 613 and then Arg (Arg'Last - 3 .. Arg'Last) = ".ali" 614 then 615 if Ali_File_Name = null then 616 Ali_File_Name := new String'(Arg); 617 else 618 Exit_With_Error ("cannot handle more than one ALI file"); 619 end if; 620 621 -- If target object file, record object file 622 623 elsif Arg'Length > Get_Target_Object_Suffix.all'Length 624 and then Arg 625 (Arg'Last - 626 Get_Target_Object_Suffix.all'Length + 1 .. Arg'Last) 627 = Get_Target_Object_Suffix.all 628 then 629 Linker_Objects.Increment_Last; 630 Linker_Objects.Table (Linker_Objects.Last) := 631 new String'(Arg); 632 633 -- If host object file, record object file 634 635 elsif Arg'Length > Get_Object_Suffix.all'Length 636 and then Arg 637 (Arg'Last - Get_Object_Suffix.all'Length + 1 .. Arg'Last) 638 = Get_Object_Suffix.all 639 then 640 Linker_Objects.Increment_Last; 641 Linker_Objects.Table (Linker_Objects.Last) := 642 new String'(Arg); 643 644 -- If corresponding ali file exists, capture it 645 646 elsif Ali_File_Name = null 647 and then Is_Regular_File (Arg & ".ali") 648 then 649 Ali_File_Name := new String'(Arg & ".ali"); 650 651 -- Otherwise assume this is a linker options entry, but 652 -- see below for interesting adjustment to this assumption. 653 654 else 655 Linker_Options.Increment_Last; 656 Linker_Options.Table (Linker_Options.Last) := 657 new String'(Arg); 658 end if; 659 end if; 660 end Process_One_Arg; 661 662 Next_Arg := Next_Arg + 1; 663 end loop; 664 665 -- Compile the bind file with warnings suppressed, because 666 -- otherwise the with of the main program may cause junk warnings. 667 668 Binder_Options.Increment_Last; 669 Binder_Options.Table (Binder_Options.Last) := new String'("-gnatws"); 670 671 -- If we did not get an ali file at all, and we had at least one 672 -- linker option, then assume that was the intended ali file after 673 -- all, so that we get a nicer message later on. 674 675 if Ali_File_Name = null 676 and then Linker_Options.Last >= Linker_Options.First 677 then 678 Ali_File_Name := 679 new String'(Linker_Options.Table (Linker_Options.First).all 680 & ".ali"); 681 end if; 682 end Process_Args; 683 684 ------------------------- 685 -- Process_Binder_File -- 686 ------------------------- 687 688 procedure Process_Binder_File (Name : String) is 689 Fd : FILEs; 690 -- Binder file's descriptor 691 692 Link_Bytes : Integer := 0; 693 -- Projected number of bytes for the linker command line 694 695 Link_Max : Integer; 696 pragma Import (C, Link_Max, "__gnat_link_max"); 697 -- Maximum number of bytes on the command line supported by the OS 698 -- linker. Passed this limit the response file mechanism must be used 699 -- if supported. 700 701 Next_Line : String (1 .. 1000); 702 -- Current line value 703 704 Nlast : Integer; 705 Nfirst : Integer; 706 -- Current line slice (the slice does not contain line terminator) 707 708 Last : Integer; 709 -- Current line last character for shared libraries (without version) 710 711 Objs_Begin : Integer := 0; 712 -- First object file index in Linker_Objects table 713 714 Objs_End : Integer := 0; 715 -- Last object file index in Linker_Objects table 716 717 Status : int; 718 pragma Warnings (Off, Status); 719 -- Used for various Interfaces.C_Streams calls 720 721 Closing_Status : Boolean; 722 pragma Warnings (Off, Closing_Status); 723 -- For call to Close 724 725 GNAT_Static : Boolean := False; 726 -- Save state of -static option 727 728 GNAT_Shared : Boolean := False; 729 -- Save state of -shared option 730 731 Xlinker_Was_Previous : Boolean := False; 732 -- Indicate that "-Xlinker" was the option preceding the current option. 733 -- If True, then the current option is never suppressed. 734 735 -- Rollback data 736 737 -- These data items are used to store current binder file context. The 738 -- context is composed of the file descriptor position and the current 739 -- line together with the slice indexes (first and last position) for 740 -- this line. The rollback data are used by the Store_File_Context and 741 -- Rollback_File_Context routines below. The file context mechanism 742 -- interact only with the Get_Next_Line call. For example: 743 744 -- Store_File_Context; 745 -- Get_Next_Line; 746 -- Rollback_File_Context; 747 -- Get_Next_Line; 748 749 -- Both Get_Next_Line calls above will read the exact same data from 750 -- the file. In other words, Next_Line, Nfirst and Nlast variables 751 -- will be set with the exact same values. 752 753 RB_File_Pos : long; -- File position 754 RB_Next_Line : String (1 .. 1000); -- Current line content 755 RB_Nlast : Integer; -- Slice last index 756 RB_Nfirst : Integer; -- Slice first index 757 758 Run_Path_Option_Ptr : Interfaces.C.Strings.chars_ptr; 759 pragma Import (C, Run_Path_Option_Ptr, "__gnat_run_path_option"); 760 -- Pointer to string representing the native linker option which 761 -- specifies the path where the dynamic loader should find shared 762 -- libraries. Equal to null string if this system doesn't support it. 763 764 Libgcc_Subdir_Ptr : Interfaces.C.Strings.chars_ptr; 765 pragma Import (C, Libgcc_Subdir_Ptr, "__gnat_default_libgcc_subdir"); 766 -- Pointer to string indicating the installation subdirectory where 767 -- a default shared libgcc might be found. 768 769 Object_Library_Ext_Ptr : Interfaces.C.Strings.chars_ptr; 770 pragma Import 771 (C, Object_Library_Ext_Ptr, "__gnat_object_library_extension"); 772 -- Pointer to string specifying the default extension for 773 -- object libraries, e.g. Unix uses ".a". 774 775 Separate_Run_Path_Options : Boolean; 776 for Separate_Run_Path_Options'Size use Character'Size; 777 pragma Import 778 (C, Separate_Run_Path_Options, "__gnat_separate_run_path_options"); 779 -- Whether separate rpath options should be emitted for each directory 780 781 procedure Get_Next_Line; 782 -- Read the next line from the binder file without the line 783 -- terminator. 784 785 function Index (S, Pattern : String) return Natural; 786 -- Return the last occurrence of Pattern in S, or 0 if none 787 788 procedure Store_File_Context; 789 -- Store current file context, Fd position and current line data. 790 -- The file context is stored into the rollback data above (RB_*). 791 -- Store_File_Context can be called at any time, only the last call 792 -- will be used (i.e. this routine overwrites the file context). 793 794 procedure Rollback_File_Context; 795 -- Restore file context from rollback data. This routine must be called 796 -- after Store_File_Context. The binder file context will be restored 797 -- with the data stored by the last Store_File_Context call. 798 799 procedure Write_RF (S : String); 800 -- Write a string to the response file and check if it was successful. 801 -- Fail the program if it was not successful (disk full). 802 803 ------------------- 804 -- Get_Next_Line -- 805 ------------------- 806 807 procedure Get_Next_Line is 808 Fchars : chars; 809 810 begin 811 Fchars := fgets (Next_Line'Address, Next_Line'Length, Fd); 812 813 if Fchars = System.Null_Address then 814 Exit_With_Error ("Error reading binder output"); 815 end if; 816 817 Nfirst := Next_Line'First; 818 Nlast := Nfirst; 819 while Nlast <= Next_Line'Last 820 and then Next_Line (Nlast) /= ASCII.LF 821 and then Next_Line (Nlast) /= ASCII.CR 822 loop 823 Nlast := Nlast + 1; 824 end loop; 825 826 Nlast := Nlast - 1; 827 end Get_Next_Line; 828 829 ----------- 830 -- Index -- 831 ----------- 832 833 function Index (S, Pattern : String) return Natural is 834 Len : constant Natural := Pattern'Length; 835 836 begin 837 for J in reverse S'First .. S'Last - Len + 1 loop 838 if Pattern = S (J .. J + Len - 1) then 839 return J; 840 end if; 841 end loop; 842 843 return 0; 844 end Index; 845 846 --------------------------- 847 -- Rollback_File_Context -- 848 --------------------------- 849 850 procedure Rollback_File_Context is 851 begin 852 Next_Line := RB_Next_Line; 853 Nfirst := RB_Nfirst; 854 Nlast := RB_Nlast; 855 Status := fseek (Fd, RB_File_Pos, Interfaces.C_Streams.SEEK_SET); 856 857 if Status = -1 then 858 Exit_With_Error ("Error setting file position"); 859 end if; 860 end Rollback_File_Context; 861 862 ------------------------ 863 -- Store_File_Context -- 864 ------------------------ 865 866 procedure Store_File_Context is 867 use type System.CRTL.long; 868 869 begin 870 RB_Next_Line := Next_Line; 871 RB_Nfirst := Nfirst; 872 RB_Nlast := Nlast; 873 RB_File_Pos := ftell (Fd); 874 875 if RB_File_Pos = -1 then 876 Exit_With_Error ("Error getting file position"); 877 end if; 878 end Store_File_Context; 879 880 -------------- 881 -- Write_RF -- 882 -------------- 883 884 procedure Write_RF (S : String) is 885 Success : Boolean := True; 886 Back_Slash : constant Character := '\'; 887 888 begin 889 -- If a GNU response file is used, space and backslash need to be 890 -- escaped because they are interpreted as a string separator and 891 -- an escape character respectively by the underlying mechanism. 892 -- On the other hand, quote and double-quote are not escaped since 893 -- they are interpreted as string delimiters on both sides. 894 895 if Using_GNU_response_file then 896 for J in S'Range loop 897 if S (J) = ' ' or else S (J) = '\' then 898 if Write (Tname_FD, Back_Slash'Address, 1) /= 1 then 899 Success := False; 900 end if; 901 end if; 902 903 if Write (Tname_FD, S (J)'Address, 1) /= 1 then 904 Success := False; 905 end if; 906 end loop; 907 908 else 909 if Write (Tname_FD, S'Address, S'Length) /= S'Length then 910 Success := False; 911 end if; 912 end if; 913 914 if Write (Tname_FD, ASCII.LF'Address, 1) /= 1 then 915 Success := False; 916 end if; 917 918 if not Success then 919 Exit_With_Error ("Error generating response file: disk full"); 920 end if; 921 end Write_RF; 922 923 -- Start of processing for Process_Binder_File 924 925 begin 926 Fd := fopen (Name'Address, Read_Mode'Address); 927 928 if Fd = NULL_Stream then 929 Exit_With_Error ("Failed to open binder output"); 930 end if; 931 932 -- Skip up to the Begin Info line 933 934 loop 935 Get_Next_Line; 936 exit when Next_Line (Nfirst .. Nlast) = Begin_Info; 937 end loop; 938 939 loop 940 Get_Next_Line; 941 942 -- Go to end when end line is reached (this will happen in 943 -- High_Integrity_Mode where no -L switches are generated) 944 945 exit when Next_Line (Nfirst .. Nlast) = End_Info; 946 947 Next_Line (Nfirst .. Nlast - 8) := Next_Line (Nfirst + 8 .. Nlast); 948 Nlast := Nlast - 8; 949 950 -- Go to next section when switches are reached 951 952 exit when Next_Line (1) = '-'; 953 954 -- Otherwise we have another object file to collect 955 956 Linker_Objects.Increment_Last; 957 958 -- Mark the positions of first and last object files in case they 959 -- need to be placed with a named file on systems having linker 960 -- line limitations. 961 962 if Objs_Begin = 0 then 963 Objs_Begin := Linker_Objects.Last; 964 end if; 965 966 Linker_Objects.Table (Linker_Objects.Last) := 967 new String'(Next_Line (Nfirst .. Nlast)); 968 969 -- Nlast - Nfirst + 1, for the size, plus one for the space between 970 -- each arguments. 971 972 Link_Bytes := Link_Bytes + Nlast - Nfirst + 2; 973 end loop; 974 975 Objs_End := Linker_Objects.Last; 976 977 -- Continue to compute the Link_Bytes, the linker options are part of 978 -- command line length. 979 980 Store_File_Context; 981 982 while Next_Line (Nfirst .. Nlast) /= End_Info loop 983 Link_Bytes := Link_Bytes + Nlast - Nfirst + 2; 984 Get_Next_Line; 985 end loop; 986 987 Rollback_File_Context; 988 989 -- On systems that have limitations on handling very long linker lines 990 -- we make use of the system linker option which takes a list of object 991 -- file names from a file instead of the command line itself. What we do 992 -- is to replace the list of object files by the special linker option 993 -- which then reads the object file list from a file instead. The option 994 -- to read from a file instead of the command line is only triggered if 995 -- a conservative threshold is passed. 996 997 if Object_List_File_Required 998 or else (Object_List_File_Supported 999 and then Link_Bytes > Link_Max) 1000 then 1001 -- Create a temporary file containing the Ada user object files 1002 -- needed by the link. This list is taken from the bind file and is 1003 -- output one object per line for maximal compatibility with linkers 1004 -- supporting this option. 1005 1006 Create_Temp_File (Tname_FD, Tname); 1007 1008 -- ??? File descriptor should be checked to not be Invalid_FD. 1009 -- ??? Status of Write and Close operations should be checked, and 1010 -- failure should occur if a status is wrong. 1011 1012 for J in Objs_Begin .. Objs_End loop 1013 Write_RF (Linker_Objects.Table (J).all); 1014 1015 Response_File_Objects.Increment_Last; 1016 Response_File_Objects.Table (Response_File_Objects.Last) := 1017 Linker_Objects.Table (J); 1018 end loop; 1019 1020 Close (Tname_FD, Closing_Status); 1021 1022 -- Add the special objects list file option together with the name 1023 -- of the temporary file (removing the null character) to the objects 1024 -- file table. 1025 1026 Linker_Objects.Table (Objs_Begin) := 1027 new String'(Object_File_Option & 1028 Tname (Tname'First .. Tname'Last - 1)); 1029 1030 -- The slots containing these object file names are then removed 1031 -- from the objects table so they do not appear in the link. They are 1032 -- removed by moving up the linker options and non-Ada object files 1033 -- appearing after the Ada object list in the table. 1034 1035 declare 1036 N : Integer; 1037 1038 begin 1039 N := Objs_End - Objs_Begin + 1; 1040 1041 for J in Objs_End + 1 .. Linker_Objects.Last loop 1042 Linker_Objects.Table (J - N + 1) := Linker_Objects.Table (J); 1043 end loop; 1044 1045 Linker_Objects.Set_Last (Linker_Objects.Last - N + 1); 1046 end; 1047 end if; 1048 1049 -- Process switches and options 1050 1051 if Next_Line (Nfirst .. Nlast) /= End_Info then 1052 Xlinker_Was_Previous := False; 1053 1054 loop 1055 if Xlinker_Was_Previous 1056 or else Next_Line (Nfirst .. Nlast) = "-Xlinker" 1057 then 1058 Linker_Options.Increment_Last; 1059 Linker_Options.Table (Linker_Options.Last) := 1060 new String'(Next_Line (Nfirst .. Nlast)); 1061 1062 elsif Next_Line (Nfirst .. Nlast) = "-static" then 1063 GNAT_Static := True; 1064 1065 elsif Next_Line (Nfirst .. Nlast) = "-shared" then 1066 GNAT_Shared := True; 1067 1068 -- Add binder options only if not already set on the command line. 1069 -- This rule is a way to control the linker options order. 1070 1071 else 1072 if Nlast > Nfirst + 2 and then 1073 Next_Line (Nfirst .. Nfirst + 1) = "-L" 1074 then 1075 -- Construct a library search path for use later to locate 1076 -- static gnatlib libraries. 1077 1078 if Libpath.Last > 1 then 1079 Libpath.Increment_Last; 1080 Libpath.Table (Libpath.Last) := Path_Separator; 1081 end if; 1082 1083 for I in Nfirst + 2 .. Nlast loop 1084 Libpath.Increment_Last; 1085 Libpath.Table (Libpath.Last) := Next_Line (I); 1086 end loop; 1087 1088 Linker_Options.Increment_Last; 1089 1090 Linker_Options.Table (Linker_Options.Last) := 1091 new String'(Next_Line (Nfirst .. Nlast)); 1092 1093 elsif Next_Line (Nfirst .. Nlast) = "-lgnarl" 1094 or else Next_Line (Nfirst .. Nlast) = "-lgnat" 1095 or else 1096 Next_Line 1097 (1 .. Natural'Min (Nlast, 8 + Library_Version'Length)) = 1098 Shared_Lib ("gnarl") 1099 or else 1100 Next_Line 1101 (1 .. Natural'Min (Nlast, 7 + Library_Version'Length)) = 1102 Shared_Lib ("gnat") 1103 then 1104 -- If it is a shared library, remove the library version. 1105 -- We will be looking for the static version of the library 1106 -- as it is in the same directory as the shared version. 1107 1108 if Next_Line (Nlast - Library_Version'Length + 1 .. Nlast) = 1109 Library_Version 1110 then 1111 -- Set Last to point to last character before the 1112 -- library version. 1113 1114 Last := Nlast - Library_Version'Length - 1; 1115 else 1116 Last := Nlast; 1117 end if; 1118 1119 -- Given a Gnat standard library, search the library path to 1120 -- find the library location. 1121 1122 -- Shouldn't we abstract a proc here, we are getting awfully 1123 -- heavily nested ??? 1124 1125 declare 1126 File_Path : String_Access; 1127 1128 Object_Lib_Extension : constant String := 1129 Value (Object_Library_Ext_Ptr); 1130 1131 File_Name : constant String := "lib" & 1132 Next_Line (Nfirst + 2 .. Last) & Object_Lib_Extension; 1133 1134 Run_Path_Opt : constant String := 1135 Value (Run_Path_Option_Ptr); 1136 1137 GCC_Index : Natural; 1138 Run_Path_Opt_Index : Natural := 0; 1139 1140 begin 1141 File_Path := 1142 Locate_Regular_File (File_Name, 1143 String (Libpath.Table (1 .. Libpath.Last))); 1144 1145 if File_Path /= null then 1146 if GNAT_Static then 1147 1148 -- If static gnatlib found, explicitly specify to 1149 -- overcome possible linker default usage of shared 1150 -- version. 1151 1152 Linker_Options.Increment_Last; 1153 1154 Linker_Options.Table (Linker_Options.Last) := 1155 new String'(File_Path.all); 1156 1157 elsif GNAT_Shared then 1158 if Opt.Run_Path_Option then 1159 1160 -- If shared gnatlib desired, add appropriate 1161 -- system specific switch so that it can be 1162 -- located at runtime. 1163 1164 if Run_Path_Opt'Length /= 0 then 1165 1166 -- Output the system specific linker command 1167 -- that allows the image activator to find 1168 -- the shared library at runtime. Also add 1169 -- path to find libgcc_s.so, if relevant. 1170 1171 declare 1172 Path : String (1 .. File_Path'Length + 15); 1173 1174 Path_Last : constant Natural := 1175 File_Path'Length; 1176 1177 begin 1178 Path (1 .. File_Path'Length) := 1179 File_Path.all; 1180 1181 -- To find the location of the shared version 1182 -- of libgcc, we look for "gcc-lib" in the 1183 -- path of the library. However, this 1184 -- subdirectory is no longer present in 1185 -- recent versions of GCC. So, we look for 1186 -- the last subdirectory "lib" in the path. 1187 1188 GCC_Index := 1189 Index (Path (1 .. Path_Last), "gcc-lib"); 1190 1191 if GCC_Index /= 0 then 1192 1193 -- The shared version of libgcc is 1194 -- located in the parent directory. 1195 1196 GCC_Index := GCC_Index - 1; 1197 1198 else 1199 GCC_Index := 1200 Index 1201 (Path (1 .. Path_Last), 1202 "/lib/"); 1203 1204 if GCC_Index = 0 then 1205 GCC_Index := 1206 Index (Path (1 .. Path_Last), 1207 Directory_Separator & "lib" 1208 & Directory_Separator); 1209 end if; 1210 1211 -- If we have found a "lib" subdir in 1212 -- the path to libgnat, the possible 1213 -- shared libgcc of interest by default 1214 -- is in libgcc_subdir at the same 1215 -- level. 1216 1217 if GCC_Index /= 0 then 1218 declare 1219 Subdir : constant String := 1220 Value (Libgcc_Subdir_Ptr); 1221 begin 1222 Path 1223 (GCC_Index + 1 .. 1224 GCC_Index + Subdir'Length) := 1225 Subdir; 1226 GCC_Index := 1227 GCC_Index + Subdir'Length; 1228 end; 1229 end if; 1230 end if; 1231 1232 -- Look for an eventual run_path_option in 1233 -- the linker switches. 1234 1235 if Separate_Run_Path_Options then 1236 Linker_Options.Increment_Last; 1237 Linker_Options.Table 1238 (Linker_Options.Last) := 1239 new String' 1240 (Run_Path_Opt 1241 & File_Path 1242 (1 .. File_Path'Length 1243 - File_Name'Length)); 1244 1245 if GCC_Index /= 0 then 1246 Linker_Options.Increment_Last; 1247 Linker_Options.Table 1248 (Linker_Options.Last) := 1249 new String' 1250 (Run_Path_Opt 1251 & Path (1 .. GCC_Index)); 1252 end if; 1253 1254 else 1255 for J in reverse 1256 1 .. Linker_Options.Last 1257 loop 1258 if Linker_Options.Table (J) /= null 1259 and then 1260 Linker_Options.Table (J)'Length 1261 > Run_Path_Opt'Length 1262 and then 1263 Linker_Options.Table (J) 1264 (1 .. Run_Path_Opt'Length) = 1265 Run_Path_Opt 1266 then 1267 -- We have found an already 1268 -- specified run_path_option: 1269 -- we will add to this 1270 -- switch, because only one 1271 -- run_path_option should be 1272 -- specified. 1273 1274 Run_Path_Opt_Index := J; 1275 exit; 1276 end if; 1277 end loop; 1278 1279 -- If there is no run_path_option, we 1280 -- need to add one. 1281 1282 if Run_Path_Opt_Index = 0 then 1283 Linker_Options.Increment_Last; 1284 end if; 1285 1286 if GCC_Index = 0 then 1287 if Run_Path_Opt_Index = 0 then 1288 Linker_Options.Table 1289 (Linker_Options.Last) := 1290 new String' 1291 (Run_Path_Opt 1292 & File_Path 1293 (1 .. File_Path'Length 1294 - File_Name'Length)); 1295 1296 else 1297 Linker_Options.Table 1298 (Run_Path_Opt_Index) := 1299 new String' 1300 (Linker_Options.Table 1301 (Run_Path_Opt_Index).all 1302 & Path_Separator 1303 & File_Path 1304 (1 .. File_Path'Length 1305 - File_Name'Length)); 1306 end if; 1307 1308 else 1309 if Run_Path_Opt_Index = 0 then 1310 Linker_Options.Table 1311 (Linker_Options.Last) := 1312 new String' 1313 (Run_Path_Opt 1314 & File_Path 1315 (1 .. File_Path'Length 1316 - File_Name'Length) 1317 & Path_Separator 1318 & Path (1 .. GCC_Index)); 1319 1320 else 1321 Linker_Options.Table 1322 (Run_Path_Opt_Index) := 1323 new String' 1324 (Linker_Options.Table 1325 (Run_Path_Opt_Index).all 1326 & Path_Separator 1327 & File_Path 1328 (1 .. File_Path'Length 1329 - File_Name'Length) 1330 & Path_Separator 1331 & Path (1 .. GCC_Index)); 1332 end if; 1333 end if; 1334 end if; 1335 end; 1336 end if; 1337 end if; 1338 1339 -- Then we add the appropriate -l switch 1340 1341 Linker_Options.Increment_Last; 1342 Linker_Options.Table (Linker_Options.Last) := 1343 new String'(Next_Line (Nfirst .. Nlast)); 1344 end if; 1345 1346 else 1347 -- If gnatlib library not found, then add it anyway in 1348 -- case some other mechanism may find it. 1349 1350 Linker_Options.Increment_Last; 1351 Linker_Options.Table (Linker_Options.Last) := 1352 new String'(Next_Line (Nfirst .. Nlast)); 1353 end if; 1354 end; 1355 else 1356 Linker_Options.Increment_Last; 1357 Linker_Options.Table (Linker_Options.Last) := 1358 new String'(Next_Line (Nfirst .. Nlast)); 1359 end if; 1360 end if; 1361 1362 Xlinker_Was_Previous := Next_Line (Nfirst .. Nlast) = "-Xlinker"; 1363 1364 Get_Next_Line; 1365 exit when Next_Line (Nfirst .. Nlast) = End_Info; 1366 1367 Next_Line (Nfirst .. Nlast - 8) := Next_Line (Nfirst + 8 .. Nlast); 1368 Nlast := Nlast - 8; 1369 end loop; 1370 end if; 1371 1372 -- If -shared was specified, invoke gcc with -shared-libgcc 1373 1374 if GNAT_Shared then 1375 Linker_Options.Increment_Last; 1376 Linker_Options.Table (Linker_Options.Last) := Shared_Libgcc; 1377 end if; 1378 1379 Status := fclose (Fd); 1380 end Process_Binder_File; 1381 1382 ----------- 1383 -- Usage -- 1384 ----------- 1385 1386 procedure Usage is 1387 begin 1388 Write_Str ("Usage: "); 1389 Write_Str (Base_Command_Name.all); 1390 Write_Str (" switches mainprog.ali [non-Ada-objects] [linker-options]"); 1391 Write_Eol; 1392 Write_Eol; 1393 Write_Line (" mainprog.ali the ALI file of the main program"); 1394 Write_Eol; 1395 Write_Eol; 1396 Display_Usage_Version_And_Help; 1397 Write_Line (" -f Force object file list to be generated"); 1398 Write_Line (" -g Compile binder source file with debug information"); 1399 Write_Line (" -n Do not compile the binder source file"); 1400 Write_Line (" -P Process files for use by CodePeer"); 1401 Write_Line (" -R Do not use a run_path_option"); 1402 Write_Line (" -v Verbose mode"); 1403 Write_Line (" -v -v Very verbose mode"); 1404 Write_Eol; 1405 Write_Line (" -o nam Use 'nam' as the name of the executable"); 1406 Write_Line (" -b target Compile the binder source to run on target"); 1407 Write_Line (" -Bdir Load compiler executables from dir"); 1408 1409 if Is_Supported (Map_File) then 1410 Write_Line (" -Mmap Create map file map"); 1411 Write_Line (" -M Create map file mainprog.map"); 1412 end if; 1413 1414 Write_Line (" --GCC=comp Use comp as the compiler"); 1415 Write_Line (" --LINK=nam Use 'nam' for the linking rather than 'gcc'"); 1416 Write_Eol; 1417 Write_Line (" [non-Ada-objects] list of non Ada object files"); 1418 Write_Line (" [linker-options] other options for the linker"); 1419 end Usage; 1420 1421 ------------------ 1422 -- Write_Header -- 1423 ------------------ 1424 1425 procedure Write_Header is 1426 begin 1427 if Verbose_Mode then 1428 Write_Eol; 1429 Display_Version ("GNATLINK", "1995"); 1430 end if; 1431 end Write_Header; 1432 1433 ----------------- 1434 -- Write_Usage -- 1435 ----------------- 1436 1437 procedure Write_Usage is 1438 begin 1439 Write_Header; 1440 Usage; 1441 end Write_Usage; 1442 1443-- Start of processing for Gnatlink 1444 1445begin 1446 -- Add the directory where gnatlink is invoked in front of the path, if 1447 -- gnatlink is invoked with directory information. 1448 1449 declare 1450 Command : constant String := Command_Name; 1451 begin 1452 for Index in reverse Command'Range loop 1453 if Command (Index) = Directory_Separator then 1454 declare 1455 Absolute_Dir : constant String := 1456 Normalize_Pathname 1457 (Command (Command'First .. Index)); 1458 1459 PATH : constant String := 1460 Absolute_Dir & 1461 Path_Separator & 1462 Getenv ("PATH").all; 1463 1464 begin 1465 Setenv ("PATH", PATH); 1466 end; 1467 1468 exit; 1469 end if; 1470 end loop; 1471 end; 1472 1473 Base_Command_Name := new String'(Base_Name (Command_Name)); 1474 Process_Args; 1475 1476 if Argument_Count = 0 1477 or else (Verbose_Mode and then Argument_Count = 1) 1478 then 1479 Write_Usage; 1480 Exit_Program (E_Fatal); 1481 end if; 1482 1483 -- Initialize packages to be used 1484 1485 Csets.Initialize; 1486 Snames.Initialize; 1487 1488 -- We always compile with -c 1489 1490 Binder_Options_From_ALI.Increment_Last; 1491 Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := 1492 new String'("-c"); 1493 1494 if Ali_File_Name = null then 1495 Exit_With_Error ("no ali file given for link"); 1496 end if; 1497 1498 if not Is_Regular_File (Ali_File_Name.all) then 1499 Exit_With_Error (Ali_File_Name.all & " not found"); 1500 end if; 1501 1502 -- Read the ALI file of the main subprogram if the binder generated file 1503 -- needs to be compiled and no --GCC= switch has been specified. Fetch the 1504 -- back end switches from this ALI file and use these switches to compile 1505 -- the binder generated file 1506 1507 if Compile_Bind_File and then Standard_Gcc then 1508 Initialize_ALI; 1509 Name_Len := Ali_File_Name'Length; 1510 Name_Buffer (1 .. Name_Len) := Ali_File_Name.all; 1511 1512 declare 1513 use Types; 1514 F : constant File_Name_Type := Name_Find; 1515 T : Text_Buffer_Ptr; 1516 A : ALI_Id; 1517 1518 begin 1519 -- Load the ALI file 1520 1521 T := Read_Library_Info (F, True); 1522 1523 -- Read it. Note that we ignore errors, since we only want very 1524 -- limited information from the ali file, and likely a slightly 1525 -- wrong version will be just fine, though in normal operation 1526 -- we don't expect this to happen. 1527 1528 A := Scan_ALI 1529 (F, 1530 T, 1531 Ignore_ED => False, 1532 Err => False, 1533 Ignore_Errors => True); 1534 1535 if A /= No_ALI_Id then 1536 for 1537 Index in Units.Table (ALIs.Table (A).First_Unit).First_Arg .. 1538 Units.Table (ALIs.Table (A).First_Unit).Last_Arg 1539 loop 1540 -- Do not compile with the front end switches. However, --RTS 1541 -- is to be dealt with specially because it needs to be passed 1542 -- to compile the file generated by the binder. 1543 1544 declare 1545 Arg : String_Ptr renames Args.Table (Index); 1546 begin 1547 if not Is_Front_End_Switch (Arg.all) then 1548 Binder_Options_From_ALI.Increment_Last; 1549 Binder_Options_From_ALI.Table 1550 (Binder_Options_From_ALI.Last) := String_Access (Arg); 1551 1552 -- GNAT doesn't support GCC's multilib mechanism when it 1553 -- is configured with --disable-libada. This means that, 1554 -- when a multilib switch is used to request a particular 1555 -- compilation mode, the corresponding --RTS switch must 1556 -- also be specified. It is convenient to eliminate the 1557 -- redundancy by keying the compilation mode on a single 1558 -- switch, namely --RTS, and have the compiler reinstate 1559 -- the multilib switch (see gcc-interface/lang-specs.h). 1560 -- This switch must be passed to the driver at link time. 1561 1562 if Arg'Length = 5 1563 and then Arg (Arg'First + 1 .. Arg'First + 4) = "mrtp" 1564 then 1565 Linker_Options.Increment_Last; 1566 Linker_Options.Table 1567 (Linker_Options.Last) := String_Access (Arg); 1568 end if; 1569 1570 elsif Arg'Length > 5 1571 and then Arg (Arg'First + 2 .. Arg'First + 5) = "RTS=" 1572 then 1573 Binder_Options_From_ALI.Increment_Last; 1574 Binder_Options_From_ALI.Table 1575 (Binder_Options_From_ALI.Last) := String_Access (Arg); 1576 1577 -- Set the RTS_*_Path_Name variables, so that 1578 -- the correct directories will be set when 1579 -- Osint.Add_Default_Search_Dirs will be called later. 1580 1581 Opt.RTS_Src_Path_Name := 1582 Get_RTS_Search_Dir 1583 (Arg (Arg'First + 6 .. Arg'Last), Include); 1584 1585 Opt.RTS_Lib_Path_Name := 1586 Get_RTS_Search_Dir 1587 (Arg (Arg'First + 6 .. Arg'Last), Objects); 1588 end if; 1589 end; 1590 end loop; 1591 end if; 1592 end; 1593 end if; 1594 1595 -- Get target parameters 1596 1597 Osint.Add_Default_Search_Dirs; 1598 Targparm.Get_Target_Parameters; 1599 1600 -- Compile the bind file with the following switches: 1601 1602 -- -gnatA stops reading gnat.adc, since we don't know what 1603 -- pragmas would work, and we do not need it anyway. 1604 1605 -- -gnatWb allows brackets coding for wide characters 1606 1607 -- -gnatiw allows wide characters in identifiers. This is needed 1608 -- because bindgen uses brackets encoding for all upper 1609 -- half and wide characters in identifier names. 1610 1611 -- In addition, in CodePeer mode compile with -x adascil -gnatcC 1612 1613 Binder_Options_From_ALI.Increment_Last; 1614 Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := 1615 new String'("-gnatA"); 1616 Binder_Options_From_ALI.Increment_Last; 1617 Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := 1618 new String'("-gnatWb"); 1619 Binder_Options_From_ALI.Increment_Last; 1620 Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := 1621 new String'("-gnatiw"); 1622 1623 if Opt.CodePeer_Mode then 1624 Binder_Options_From_ALI.Increment_Last; 1625 Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := 1626 new String'("-x"); 1627 Binder_Options_From_ALI.Increment_Last; 1628 Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := 1629 new String'("adascil"); 1630 Binder_Options_From_ALI.Increment_Last; 1631 Binder_Options_From_ALI.Table (Binder_Options_From_ALI.Last) := 1632 new String'("-gnatcC"); 1633 end if; 1634 1635 -- Locate all the necessary programs and verify required files are present 1636 1637 Gcc_Path := System.OS_Lib.Locate_Exec_On_Path (Gcc.all); 1638 1639 if Gcc_Path = null then 1640 Exit_With_Error ("Couldn't locate " & Gcc.all); 1641 end if; 1642 1643 if Linker_Path = null then 1644 Linker_Path := Gcc_Path; 1645 end if; 1646 1647 Write_Header; 1648 1649 -- If no output name specified, then use the base name of .ali file name 1650 1651 if Output_File_Name = null then 1652 Output_File_Name := 1653 new String'(Base_Name (Ali_File_Name.all) 1654 & Get_Target_Debuggable_Suffix.all); 1655 end if; 1656 1657 Linker_Options.Increment_Last; 1658 Linker_Options.Table (Linker_Options.Last) := new String'("-o"); 1659 1660 Linker_Options.Increment_Last; 1661 Linker_Options.Table (Linker_Options.Last) := 1662 new String'(Output_File_Name.all); 1663 1664 Check_Existing_Executable (Output_File_Name.all); 1665 1666 -- Warn if main program is called "test", as that may be a built-in command 1667 -- on Unix. On non-Unix systems executables have a suffix, so the warning 1668 -- will not appear. However, do not warn in the case of a cross compiler. 1669 1670 -- Assume this is a cross tool if the executable name is not gnatlink. 1671 -- Note that the executable name is also gnatlink on windows, but in that 1672 -- case the output file name will be test.exe rather than test. 1673 1674 if Base_Command_Name.all = "gnatlink" 1675 and then Output_File_Name.all = "test" 1676 then 1677 Error_Msg ("warning: executable name """ & Output_File_Name.all 1678 & """ may conflict with shell command"); 1679 end if; 1680 1681 -- Special warnings for worrisome file names on windows 1682 1683 -- Windows-7 will not allow an executable file whose name contains any 1684 -- of the substrings "install", "setup", or "update" to load without 1685 -- special administration privileges. This rather incredible behavior 1686 -- is Microsoft's idea of a useful security precaution. 1687 1688 Bad_File_Names_On_Windows : declare 1689 FN : String := Output_File_Name.all; 1690 1691 procedure Check_File_Name (S : String); 1692 -- Warn if file name has the substring S 1693 1694 procedure Check_File_Name (S : String) is 1695 begin 1696 for J in 1 .. FN'Length - (S'Length - 1) loop 1697 if FN (J .. J + (S'Length - 1)) = S then 1698 Error_Msg 1699 ("warning: possible problem with executable name """ 1700 & Output_File_Name.all & '"'); 1701 Error_Msg 1702 ("file name contains substring """ & S & '"'); 1703 Error_Msg 1704 ("admin privileges may be required on Windows 7 " 1705 & "to load this file"); 1706 end if; 1707 end loop; 1708 end Check_File_Name; 1709 1710 -- Start of processing for Bad_File_Names_On_Windows 1711 1712 begin 1713 for J in FN'Range loop 1714 FN (J) := Csets.Fold_Lower (FN (J)); 1715 end loop; 1716 1717 -- For now we detect windows by an output executable name ending with 1718 -- the suffix .exe. 1719 1720 if FN'Length > 5 1721 and then FN (FN'Last - 3 .. FN'Last) = ".exe" 1722 then 1723 Check_File_Name ("install"); 1724 Check_File_Name ("setup"); 1725 Check_File_Name ("update"); 1726 end if; 1727 end Bad_File_Names_On_Windows; 1728 1729 -- If -M switch was specified, add the switches to create the map file 1730 1731 if Create_Map_File then 1732 declare 1733 Map_Name : constant String := Base_Name (Ali_File_Name.all) & ".map"; 1734 Switches : String_List_Access; 1735 1736 begin 1737 Convert (Map_File, Map_Name, Switches); 1738 1739 if Switches /= null then 1740 for J in Switches'Range loop 1741 Linker_Options.Increment_Last; 1742 Linker_Options.Table (Linker_Options.Last) := Switches (J); 1743 end loop; 1744 end if; 1745 end; 1746 end if; 1747 1748 -- Perform consistency checks 1749 1750 -- Transform the .ali file name into the binder output file name 1751 1752 Make_Binder_File_Names : declare 1753 Fname : constant String := Base_Name (Ali_File_Name.all); 1754 Fname_Len : Integer := Fname'Length; 1755 1756 function Get_Maximum_File_Name_Length return Integer; 1757 pragma Import (C, Get_Maximum_File_Name_Length, 1758 "__gnat_get_maximum_file_name_length"); 1759 1760 Maximum_File_Name_Length : constant Integer := 1761 Get_Maximum_File_Name_Length; 1762 1763 Bind_File_Prefix : Types.String_Ptr; 1764 -- Contains prefix used for bind files 1765 1766 begin 1767 -- Set prefix 1768 1769 Bind_File_Prefix := new String'("b~"); 1770 1771 -- If the length of the binder file becomes too long due to 1772 -- the addition of the "b?" prefix, then truncate it. 1773 1774 if Maximum_File_Name_Length > 0 then 1775 while Fname_Len > 1776 Maximum_File_Name_Length - Bind_File_Prefix.all'Length 1777 loop 1778 Fname_Len := Fname_Len - 1; 1779 end loop; 1780 end if; 1781 1782 declare 1783 Fnam : constant String := 1784 Bind_File_Prefix.all & 1785 Fname (Fname'First .. Fname'First + Fname_Len - 1); 1786 1787 begin 1788 Binder_Spec_Src_File := new String'(Fnam & ".ads"); 1789 Binder_Body_Src_File := new String'(Fnam & ".adb"); 1790 Binder_Ali_File := new String'(Fnam & ".ali"); 1791 1792 Binder_Obj_File := new String'(Fnam & Get_Target_Object_Suffix.all); 1793 end; 1794 1795 if Fname_Len /= Fname'Length then 1796 Binder_Options.Increment_Last; 1797 Binder_Options.Table (Binder_Options.Last) := new String'("-o"); 1798 Binder_Options.Increment_Last; 1799 Binder_Options.Table (Binder_Options.Last) := Binder_Obj_File; 1800 end if; 1801 end Make_Binder_File_Names; 1802 1803 Process_Binder_File (Binder_Body_Src_File.all & ASCII.NUL); 1804 1805 -- Compile the binder file. This is fast, so we always do it, unless 1806 -- specifically told not to by the -n switch 1807 1808 if Compile_Bind_File then 1809 Bind_Step : declare 1810 Success : Boolean; 1811 1812 Args : Argument_List 1813 (1 .. Binder_Options_From_ALI.Last + Binder_Options.Last + 1); 1814 1815 begin 1816 for J in 1 .. Binder_Options_From_ALI.Last loop 1817 Args (J) := Binder_Options_From_ALI.Table (J); 1818 end loop; 1819 1820 for J in 1 .. Binder_Options.Last loop 1821 Args (Binder_Options_From_ALI.Last + J) := 1822 Binder_Options.Table (J); 1823 end loop; 1824 1825 -- Use the full path of the binder generated source, so that it is 1826 -- guaranteed that the debugger will find this source, even with 1827 -- STABS. 1828 1829 Args (Args'Last) := 1830 new String'(Normalize_Pathname (Binder_Body_Src_File.all)); 1831 1832 if Verbose_Mode then 1833 Write_Str (Base_Name (Gcc_Path.all)); 1834 1835 for J in Args'Range loop 1836 Write_Str (" "); 1837 Write_Str (Args (J).all); 1838 end loop; 1839 1840 Write_Eol; 1841 end if; 1842 1843 System.OS_Lib.Spawn (Gcc_Path.all, Args, Success); 1844 1845 if not Success then 1846 Exit_Program (E_Fatal); 1847 end if; 1848 end Bind_Step; 1849 end if; 1850 1851 -- In CodePeer mode, there's nothing left to do after the binder file has 1852 -- been compiled. 1853 1854 if Opt.CodePeer_Mode then 1855 if Tname_FD /= Invalid_FD then 1856 Delete (Tname); 1857 end if; 1858 1859 return; 1860 end if; 1861 1862 -- Now, actually link the program 1863 1864 Link_Step : declare 1865 Num_Args : Natural := 1866 (Linker_Options.Last - Linker_Options.First + 1) + 1867 (Gcc_Linker_Options.Last - Gcc_Linker_Options.First + 1) + 1868 (Linker_Objects.Last - Linker_Objects.First + 1); 1869 Stack_Op : Boolean := False; 1870 1871 begin 1872 if AAMP_On_Target then 1873 1874 -- Remove extraneous flags not relevant for AAMP 1875 1876 for J in reverse Linker_Options.First .. Linker_Options.Last loop 1877 if Linker_Options.Table (J)'Length = 0 1878 or else Linker_Options.Table (J) (1 .. 3) = "-Wl" 1879 or else Linker_Options.Table (J) (1 .. 3) = "-sh" 1880 or else Linker_Options.Table (J) (1 .. 2) = "-O" 1881 or else Linker_Options.Table (J) (1 .. 2) = "-g" 1882 then 1883 Linker_Options.Table (J .. Linker_Options.Last - 1) := 1884 Linker_Options.Table (J + 1 .. Linker_Options.Last); 1885 Linker_Options.Decrement_Last; 1886 Num_Args := Num_Args - 1; 1887 end if; 1888 end loop; 1889 end if; 1890 1891 -- Remove duplicate stack size setting from the Linker_Options table. 1892 -- The stack setting option "-Xlinker --stack=R,C" can be found 1893 -- in one line when set by a pragma Linker_Options or in two lines 1894 -- ("-Xlinker" then "--stack=R,C") when set on the command line. We 1895 -- also check for the "-Wl,--stack=R" style option. 1896 1897 -- We must remove the second stack setting option instance because 1898 -- the one on the command line will always be the first one. And any 1899 -- subsequent stack setting option will overwrite the previous one. 1900 -- This is done especially for GNAT/NT where we set the stack size 1901 -- for tasking programs by a pragma in the NT specific tasking 1902 -- package System.Task_Primitives.Operations. 1903 1904 -- Note: This is not a FOR loop that runs from Linker_Options.First 1905 -- to Linker_Options.Last, since operations within the loop can 1906 -- modify the length of the table. 1907 1908 Clean_Link_Option_Set : declare 1909 J : Natural; 1910 Shared_Libgcc_Seen : Boolean := False; 1911 1912 begin 1913 J := Linker_Options.First; 1914 while J <= Linker_Options.Last loop 1915 if Linker_Options.Table (J).all = "-Xlinker" 1916 and then J < Linker_Options.Last 1917 and then Linker_Options.Table (J + 1)'Length > 8 1918 and then Linker_Options.Table (J + 1) (1 .. 8) = "--stack=" 1919 then 1920 if Stack_Op then 1921 Linker_Options.Table (J .. Linker_Options.Last - 2) := 1922 Linker_Options.Table (J + 2 .. Linker_Options.Last); 1923 Linker_Options.Decrement_Last; 1924 Linker_Options.Decrement_Last; 1925 Num_Args := Num_Args - 2; 1926 1927 else 1928 Stack_Op := True; 1929 end if; 1930 end if; 1931 1932 -- Remove duplicate -shared-libgcc switch 1933 1934 if Linker_Options.Table (J).all = Shared_Libgcc_String then 1935 if Shared_Libgcc_Seen then 1936 Linker_Options.Table (J .. Linker_Options.Last - 1) := 1937 Linker_Options.Table (J + 1 .. Linker_Options.Last); 1938 Linker_Options.Decrement_Last; 1939 Num_Args := Num_Args - 1; 1940 1941 else 1942 Shared_Libgcc_Seen := True; 1943 end if; 1944 end if; 1945 1946 -- Here we just check for a canonical form that matches the 1947 -- pragma Linker_Options set in the NT runtime. 1948 1949 if (Linker_Options.Table (J)'Length > 17 1950 and then Linker_Options.Table (J) (1 .. 17) = 1951 "-Xlinker --stack=") 1952 or else 1953 (Linker_Options.Table (J)'Length > 12 1954 and then Linker_Options.Table (J) (1 .. 12) = 1955 "-Wl,--stack=") 1956 then 1957 if Stack_Op then 1958 Linker_Options.Table (J .. Linker_Options.Last - 1) := 1959 Linker_Options.Table (J + 1 .. Linker_Options.Last); 1960 Linker_Options.Decrement_Last; 1961 Num_Args := Num_Args - 1; 1962 1963 else 1964 Stack_Op := True; 1965 end if; 1966 end if; 1967 1968 J := J + 1; 1969 end loop; 1970 1971 if Linker_Path = Gcc_Path then 1972 1973 -- For systems where the default is to link statically with 1974 -- libgcc, if gcc is not called with -shared-libgcc, call it 1975 -- with -static-libgcc, as there are some platforms where one 1976 -- of these two switches is compulsory to link. 1977 1978 if Shared_Libgcc_Default = 'T' 1979 and then not Shared_Libgcc_Seen 1980 then 1981 Linker_Options.Increment_Last; 1982 Linker_Options.Table (Linker_Options.Last) := Static_Libgcc; 1983 Num_Args := Num_Args + 1; 1984 end if; 1985 end if; 1986 end Clean_Link_Option_Set; 1987 1988 -- Prepare arguments for call to linker 1989 1990 Call_Linker : declare 1991 Success : Boolean; 1992 Args : Argument_List (1 .. Num_Args + 1); 1993 Index : Integer := Args'First; 1994 1995 begin 1996 Args (Index) := Binder_Obj_File; 1997 1998 -- Add the object files and any -largs libraries 1999 2000 for J in Linker_Objects.First .. Linker_Objects.Last loop 2001 Index := Index + 1; 2002 Args (Index) := Linker_Objects.Table (J); 2003 end loop; 2004 2005 -- Add the linker options from the binder file 2006 2007 for J in Linker_Options.First .. Linker_Options.Last loop 2008 Index := Index + 1; 2009 Args (Index) := Linker_Options.Table (J); 2010 end loop; 2011 2012 -- Finally add the libraries from the --GCC= switch 2013 2014 for J in Gcc_Linker_Options.First .. Gcc_Linker_Options.Last loop 2015 Index := Index + 1; 2016 Args (Index) := Gcc_Linker_Options.Table (J); 2017 end loop; 2018 2019 if Verbose_Mode then 2020 Write_Str (Linker_Path.all); 2021 2022 for J in Args'Range loop 2023 Write_Str (" "); 2024 Write_Str (Args (J).all); 2025 end loop; 2026 2027 Write_Eol; 2028 2029 -- If we are on very verbose mode (-v -v) and a response file 2030 -- is used we display its content. 2031 2032 if Very_Verbose_Mode and then Tname_FD /= Invalid_FD then 2033 Write_Eol; 2034 Write_Str ("Response file (" & 2035 Tname (Tname'First .. Tname'Last - 1) & 2036 ") content : "); 2037 Write_Eol; 2038 2039 for J in 2040 Response_File_Objects.First .. Response_File_Objects.Last 2041 loop 2042 Write_Str (Response_File_Objects.Table (J).all); 2043 Write_Eol; 2044 end loop; 2045 2046 Write_Eol; 2047 end if; 2048 end if; 2049 2050 System.OS_Lib.Spawn (Linker_Path.all, Args, Success); 2051 2052 -- Delete the temporary file used in conjunction with linking if one 2053 -- was created. See Process_Bind_File for details. 2054 2055 if Tname_FD /= Invalid_FD then 2056 Delete (Tname); 2057 end if; 2058 2059 if not Success then 2060 Error_Msg ("error when calling " & Linker_Path.all); 2061 Exit_Program (E_Fatal); 2062 end if; 2063 end Call_Linker; 2064 end Link_Step; 2065 2066 -- Only keep the binder output file and it's associated object 2067 -- file if compiling with the -g option. These files are only 2068 -- useful if debugging. 2069 2070 if not Debug_Flag_Present then 2071 Delete (Binder_Ali_File.all & ASCII.NUL); 2072 Delete (Binder_Spec_Src_File.all & ASCII.NUL); 2073 Delete (Binder_Body_Src_File.all & ASCII.NUL); 2074 Delete (Binder_Obj_File.all & ASCII.NUL); 2075 end if; 2076 2077 Exit_Program (E_Success); 2078 2079exception 2080 when X : others => 2081 Write_Line (Exception_Information (X)); 2082 Exit_With_Error ("INTERNAL ERROR. Please report"); 2083end Gnatlink; 2084