1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- M L I B . U T L -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2002-2013, AdaCore -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with MLib.Fil; use MLib.Fil; 27with MLib.Tgt; use MLib.Tgt; 28with Opt; 29with Osint; 30with Output; use Output; 31 32with Interfaces.C.Strings; use Interfaces.C.Strings; 33 34package body MLib.Utl is 35 36 Adalib_Path : String_Access := null; 37 -- Path of the GNAT adalib directory, specified in procedure 38 -- Specify_Adalib_Dir. Used in function Lib_Directory. 39 40 Gcc_Name : String_Access; 41 -- Default value of the "gcc" executable used in procedure Gcc 42 43 Gcc_Exec : String_Access; 44 -- The full path name of the "gcc" executable 45 46 Ar_Name : String_Access; 47 -- The name of the archive builder for the platform, set when procedure Ar 48 -- is called for the first time. 49 50 Ar_Exec : String_Access; 51 -- The full path name of the archive builder 52 53 Ar_Options : String_List_Access; 54 -- The minimum options used when invoking the archive builder 55 56 Ar_Append_Options : String_List_Access; 57 -- The options to be used when invoking the archive builder to add chunks 58 -- of object files, when building the archive in chunks. 59 60 Opt_Length : Natural := 0; 61 -- The max number of options for the Archive_Builder 62 63 Initial_Size : Natural := 0; 64 -- The minimum number of bytes for the invocation of the Archive Builder 65 -- (without name of the archive or object files). 66 67 Ranlib_Name : String_Access; 68 -- The name of the archive indexer for the platform, if there is one 69 70 Ranlib_Exec : String_Access := null; 71 -- The full path name of the archive indexer 72 73 Ranlib_Options : String_List_Access := null; 74 -- The options to be used when invoking the archive indexer, if any 75 76 -------- 77 -- Ar -- 78 -------- 79 80 procedure Ar (Output_File : String; Objects : Argument_List) is 81 Full_Output_File : constant String := 82 Ext_To (Output_File, Archive_Ext); 83 84 Arguments : Argument_List_Access; 85 Last_Arg : Natural := 0; 86 Success : Boolean; 87 Line_Length : Natural := 0; 88 89 Maximum_Size : Integer; 90 pragma Import (C, Maximum_Size, "__gnat_link_max"); 91 -- Maximum number of bytes to put in an invocation of the 92 -- Archive_Builder. 93 94 Size : Integer; 95 -- The number of bytes for the invocation of the archive builder 96 97 Current_Object : Natural; 98 99 procedure Display; 100 -- Display an invocation of the Archive Builder 101 102 ------------- 103 -- Display -- 104 ------------- 105 106 procedure Display is 107 begin 108 if not Opt.Quiet_Output then 109 Write_Str (Ar_Name.all); 110 Line_Length := Ar_Name'Length; 111 112 for J in 1 .. Last_Arg loop 113 114 -- Make sure the Output buffer does not overflow 115 116 if Line_Length + 1 + Arguments (J)'Length > Buffer_Max then 117 Write_Eol; 118 Line_Length := 0; 119 end if; 120 121 Write_Char (' '); 122 123 -- Only output the first object files when not in verbose mode 124 125 if (not Opt.Verbose_Mode) and then J = Opt_Length + 3 then 126 Write_Str ("..."); 127 exit; 128 end if; 129 130 Write_Str (Arguments (J).all); 131 Line_Length := Line_Length + 1 + Arguments (J)'Length; 132 end loop; 133 134 Write_Eol; 135 end if; 136 137 end Display; 138 139 begin 140 if Ar_Exec = null then 141 Ar_Name := Osint.Program_Name (Archive_Builder, "gnatmake"); 142 Ar_Exec := Locate_Exec_On_Path (Ar_Name.all); 143 144 if Ar_Exec = null then 145 Free (Ar_Name); 146 Ar_Name := new String'(Archive_Builder); 147 Ar_Exec := Locate_Exec_On_Path (Ar_Name.all); 148 end if; 149 150 if Ar_Exec = null then 151 Fail (Ar_Name.all & " not found in path"); 152 153 elsif Opt.Verbose_Mode then 154 Write_Str ("found "); 155 Write_Line (Ar_Exec.all); 156 end if; 157 158 Ar_Options := Archive_Builder_Options; 159 160 Initial_Size := 0; 161 for J in Ar_Options'Range loop 162 Initial_Size := Initial_Size + Ar_Options (J)'Length + 1; 163 end loop; 164 165 Ar_Append_Options := Archive_Builder_Append_Options; 166 167 Opt_Length := Ar_Options'Length; 168 169 if Ar_Append_Options /= null then 170 Opt_Length := Natural'Max (Ar_Append_Options'Length, Opt_Length); 171 172 Size := 0; 173 for J in Ar_Append_Options'Range loop 174 Size := Size + Ar_Append_Options (J)'Length + 1; 175 end loop; 176 177 Initial_Size := Integer'Max (Initial_Size, Size); 178 end if; 179 180 -- ranlib 181 182 Ranlib_Name := Osint.Program_Name (Archive_Indexer, "gnatmake"); 183 184 if Ranlib_Name'Length > 0 then 185 Ranlib_Exec := Locate_Exec_On_Path (Ranlib_Name.all); 186 187 if Ranlib_Exec = null then 188 Free (Ranlib_Name); 189 Ranlib_Name := new String'(Archive_Indexer); 190 Ranlib_Exec := Locate_Exec_On_Path (Ranlib_Name.all); 191 end if; 192 193 if Ranlib_Exec /= null and then Opt.Verbose_Mode then 194 Write_Str ("found "); 195 Write_Line (Ranlib_Exec.all); 196 end if; 197 end if; 198 199 Ranlib_Options := Archive_Indexer_Options; 200 end if; 201 202 Arguments := 203 new String_List (1 .. 1 + Opt_Length + Objects'Length); 204 Arguments (1 .. Ar_Options'Length) := Ar_Options.all; -- "ar cr ..." 205 Arguments (Ar_Options'Length + 1) := new String'(Full_Output_File); 206 207 Delete_File (Full_Output_File); 208 209 Size := Initial_Size + Full_Output_File'Length + 1; 210 211 -- Check the full size of a call of the archive builder with all the 212 -- object files. 213 214 for J in Objects'Range loop 215 Size := Size + Objects (J)'Length + 1; 216 end loop; 217 218 -- If the size is not too large or if it is not possible to build the 219 -- archive in chunks, build the archive in a single invocation. 220 221 if Size <= Maximum_Size or else Ar_Append_Options = null then 222 Last_Arg := Ar_Options'Length + 1 + Objects'Length; 223 Arguments (Ar_Options'Length + 2 .. Last_Arg) := Objects; 224 225 Display; 226 227 Spawn (Ar_Exec.all, Arguments (1 .. Last_Arg), Success); 228 229 else 230 -- Build the archive in several invocation, making sure to not 231 -- go over the maximum size for each invocation. 232 233 Last_Arg := Ar_Options'Length + 1; 234 Current_Object := Objects'First; 235 Size := Initial_Size + Full_Output_File'Length + 1; 236 237 -- First invocation 238 239 while Current_Object <= Objects'Last loop 240 Size := Size + Objects (Current_Object)'Length + 1; 241 exit when Size > Maximum_Size; 242 Last_Arg := Last_Arg + 1; 243 Arguments (Last_Arg) := Objects (Current_Object); 244 Current_Object := Current_Object + 1; 245 end loop; 246 247 Display; 248 249 Spawn (Ar_Exec.all, Arguments (1 .. Last_Arg), Success); 250 251 Arguments (1 .. Ar_Append_Options'Length) := Ar_Append_Options.all; 252 Arguments 253 (Ar_Append_Options'Length + 1) := new String'(Full_Output_File); 254 255 -- Appending invocation(s) 256 257 Big_Loop : while Success and then Current_Object <= Objects'Last loop 258 Last_Arg := Ar_Append_Options'Length + 1; 259 Size := Initial_Size + Full_Output_File'Length + 1; 260 261 Inner_Loop : while Current_Object <= Objects'Last loop 262 Size := Size + Objects (Current_Object)'Length + 1; 263 exit Inner_Loop when Size > Maximum_Size; 264 Last_Arg := Last_Arg + 1; 265 Arguments (Last_Arg) := Objects (Current_Object); 266 Current_Object := Current_Object + 1; 267 end loop Inner_Loop; 268 269 Display; 270 271 Spawn (Ar_Exec.all, Arguments (1 .. Last_Arg), Success); 272 end loop Big_Loop; 273 end if; 274 275 if not Success then 276 Fail (Ar_Name.all & " execution error."); 277 end if; 278 279 -- If we have found ranlib, run it over the library 280 281 if Ranlib_Exec /= null then 282 if not Opt.Quiet_Output then 283 Write_Str (Ranlib_Name.all); 284 Write_Char (' '); 285 Write_Line (Arguments (Ar_Options'Length + 1).all); 286 end if; 287 288 Spawn 289 (Ranlib_Exec.all, 290 Ranlib_Options.all & (Arguments (Ar_Options'Length + 1)), 291 Success); 292 293 if not Success then 294 Fail (Ranlib_Name.all & " execution error."); 295 end if; 296 end if; 297 end Ar; 298 299 ----------------- 300 -- Delete_File -- 301 ----------------- 302 303 procedure Delete_File (Filename : String) is 304 File : constant String := Filename & ASCII.NUL; 305 Success : Boolean; 306 307 begin 308 Delete_File (File'Address, Success); 309 310 if Opt.Verbose_Mode then 311 if Success then 312 Write_Str ("deleted "); 313 314 else 315 Write_Str ("could not delete "); 316 end if; 317 318 Write_Line (Filename); 319 end if; 320 end Delete_File; 321 322 --------- 323 -- Gcc -- 324 --------- 325 326 procedure Gcc 327 (Output_File : String; 328 Objects : Argument_List; 329 Options : Argument_List; 330 Options_2 : Argument_List; 331 Driver_Name : Name_Id := No_Name) 332 is 333 Link_Bytes : Integer := 0; 334 -- Projected number of bytes for the linker command line 335 336 Link_Max : Integer; 337 pragma Import (C, Link_Max, "__gnat_link_max"); 338 -- Maximum number of bytes on the command line supported by the OS 339 -- linker. Passed this limit the response file mechanism must be used 340 -- if supported. 341 342 Object_List_File_Supported : Boolean; 343 for Object_List_File_Supported'Size use Character'Size; 344 pragma Import 345 (C, Object_List_File_Supported, "__gnat_objlist_file_supported"); 346 -- Predicate indicating whether the linker has an option whereby the 347 -- names of object files can be passed to the linker in a file. 348 349 Object_File_Option_Ptr : Interfaces.C.Strings.chars_ptr; 350 pragma Import (C, Object_File_Option_Ptr, "__gnat_object_file_option"); 351 -- Pointer to a string representing the linker option which specifies 352 -- the response file. 353 354 Object_File_Option : constant String := Value (Object_File_Option_Ptr); 355 -- The linker option which specifies the response file as a string 356 357 Using_GNU_response_file : constant Boolean := 358 Object_File_Option'Length > 0 359 and then 360 Object_File_Option 361 (Object_File_Option'Last) = '@'; 362 -- Whether a GNU response file is used 363 364 Tname : String_Access; 365 Tname_FD : File_Descriptor := Invalid_FD; 366 -- Temporary file used by linker to pass list of object files on 367 -- certain systems with limitations on size of arguments. 368 369 Closing_Status : Boolean; 370 -- For call to Close 371 372 Arguments : 373 Argument_List 374 (1 .. 7 + Objects'Length + Options'Length + Options_2'Length); 375 376 A : Natural := 0; 377 Success : Boolean; 378 379 Out_Opt : constant String_Access := new String'("-o"); 380 Out_V : constant String_Access := new String'(Output_File); 381 Lib_Dir : constant String_Access := new String'("-L" & Lib_Directory); 382 Lib_Opt : constant String_Access := new String'(Dynamic_Option); 383 384 Driver : String_Access; 385 386 type Object_Position is (First, Second, Last); 387 388 Position : Object_Position; 389 390 procedure Write_RF (S : String); 391 -- Write a string to the response file and check if it was successful. 392 -- Fail the program if it was not successful (disk full). 393 394 -------------- 395 -- Write_RF -- 396 -------------- 397 398 procedure Write_RF (S : String) is 399 Success : Boolean := True; 400 Back_Slash : constant Character := '\'; 401 402 begin 403 -- If a GNU response file is used, space and backslash need to be 404 -- escaped because they are interpreted as a string separator and 405 -- an escape character respectively by the underlying mechanism. 406 -- On the other hand, quote and double-quote are not escaped since 407 -- they are interpreted as string delimiters on both sides. 408 409 if Using_GNU_response_file then 410 for J in S'Range loop 411 if S (J) = ' ' or else S (J) = '\' then 412 if Write (Tname_FD, Back_Slash'Address, 1) /= 1 then 413 Success := False; 414 end if; 415 end if; 416 417 if Write (Tname_FD, S (J)'Address, 1) /= 1 then 418 Success := False; 419 end if; 420 end loop; 421 422 else 423 if Write (Tname_FD, S'Address, S'Length) /= S'Length then 424 Success := False; 425 end if; 426 end if; 427 428 if Write (Tname_FD, ASCII.LF'Address, 1) /= 1 then 429 Success := False; 430 end if; 431 432 if not Success then 433 Fail ("cannot generate response file to link library: disk full"); 434 end if; 435 end Write_RF; 436 437 -- Start of processing for Gcc 438 439 begin 440 if Driver_Name = No_Name then 441 if Gcc_Exec = null then 442 if Gcc_Name = null then 443 Gcc_Name := Osint.Program_Name ("gcc", "gnatmake"); 444 end if; 445 446 Gcc_Exec := Locate_Exec_On_Path (Gcc_Name.all); 447 448 if Gcc_Exec = null then 449 Fail (Gcc_Name.all & " not found in path"); 450 end if; 451 end if; 452 453 Driver := Gcc_Exec; 454 455 else 456 Driver := Locate_Exec_On_Path (Get_Name_String (Driver_Name)); 457 458 if Driver = null then 459 Fail (Get_Name_String (Driver_Name) & " not found in path"); 460 end if; 461 end if; 462 463 Link_Bytes := 0; 464 465 if Lib_Opt'Length /= 0 then 466 A := A + 1; 467 Arguments (A) := Lib_Opt; 468 Link_Bytes := Link_Bytes + Lib_Opt'Length + 1; 469 end if; 470 471 A := A + 1; 472 Arguments (A) := Out_Opt; 473 Link_Bytes := Link_Bytes + Out_Opt'Length + 1; 474 475 A := A + 1; 476 Arguments (A) := Out_V; 477 Link_Bytes := Link_Bytes + Out_V'Length + 1; 478 479 A := A + 1; 480 Arguments (A) := Lib_Dir; 481 Link_Bytes := Link_Bytes + Lib_Dir'Length + 1; 482 483 A := A + Options'Length; 484 Arguments (A - Options'Length + 1 .. A) := Options; 485 486 for J in Options'Range loop 487 Link_Bytes := Link_Bytes + Options (J)'Length + 1; 488 end loop; 489 490 if not Opt.Quiet_Output then 491 if Opt.Verbose_Mode then 492 Write_Str (Driver.all); 493 494 elsif Driver_Name /= No_Name then 495 Write_Str (Get_Name_String (Driver_Name)); 496 497 else 498 Write_Str (Gcc_Name.all); 499 end if; 500 501 for J in 1 .. A loop 502 if Opt.Verbose_Mode or else J < 4 then 503 Write_Char (' '); 504 Write_Str (Arguments (J).all); 505 506 else 507 Write_Str (" ..."); 508 exit; 509 end if; 510 end loop; 511 512 -- Do not display all the object files if not in verbose mode, only 513 -- the first one. 514 515 Position := First; 516 for J in Objects'Range loop 517 if Opt.Verbose_Mode or else Position = First then 518 Write_Char (' '); 519 Write_Str (Objects (J).all); 520 Position := Second; 521 522 elsif Position = Second then 523 Write_Str (" ..."); 524 Position := Last; 525 exit; 526 end if; 527 end loop; 528 529 for J in Options_2'Range loop 530 if not Opt.Verbose_Mode then 531 if Position = Second then 532 Write_Str (" ..."); 533 end if; 534 535 exit; 536 end if; 537 538 Write_Char (' '); 539 Write_Str (Options_2 (J).all); 540 end loop; 541 542 Write_Eol; 543 end if; 544 545 for J in Objects'Range loop 546 Link_Bytes := Link_Bytes + Objects (J)'Length + 1; 547 end loop; 548 549 for J in Options_2'Range loop 550 Link_Bytes := Link_Bytes + Options_2 (J)'Length + 1; 551 end loop; 552 553 if Object_List_File_Supported and then Link_Bytes > Link_Max then 554 555 -- Create a temporary file containing the object files, one object 556 -- file per line for maximal compatibility with linkers supporting 557 -- this option. 558 559 Create_Temp_File (Tname_FD, Tname); 560 561 for J in Objects'Range loop 562 Write_RF (Objects (J).all); 563 end loop; 564 565 Close (Tname_FD, Closing_Status); 566 567 if not Closing_Status then 568 Fail ("cannot generate response file to link library: disk full"); 569 end if; 570 571 A := A + 1; 572 Arguments (A) := new String'(Object_File_Option & Tname.all); 573 574 else 575 A := A + Objects'Length; 576 Arguments (A - Objects'Length + 1 .. A) := Objects; 577 end if; 578 579 A := A + Options_2'Length; 580 Arguments (A - Options_2'Length + 1 .. A) := Options_2; 581 582 Spawn (Driver.all, Arguments (1 .. A), Success); 583 584 if Success then 585 -- Delete the temporary file used in conjunction with linking 586 -- if one was created. 587 588 if Tname_FD /= Invalid_FD then 589 Delete_File (Tname.all); 590 end if; 591 592 else 593 if Driver_Name = No_Name then 594 Fail (Gcc_Name.all & " execution error"); 595 else 596 Fail (Get_Name_String (Driver_Name) & " execution error"); 597 end if; 598 end if; 599 end Gcc; 600 601 ------------------- 602 -- Lib_Directory -- 603 ------------------- 604 605 function Lib_Directory return String is 606 Libgnat : constant String := Tgt.Libgnat; 607 608 begin 609 -- If procedure Specify_Adalib_Dir has been called, used the specified 610 -- value. 611 612 if Adalib_Path /= null then 613 return Adalib_Path.all; 614 end if; 615 616 Name_Len := Libgnat'Length; 617 Name_Buffer (1 .. Name_Len) := Libgnat; 618 Get_Name_String (Osint.Find_File (Name_Enter, Osint.Library)); 619 620 -- Remove libgnat.a 621 622 return Name_Buffer (1 .. Name_Len - Libgnat'Length); 623 end Lib_Directory; 624 625 ------------------------ 626 -- Specify_Adalib_Dir -- 627 ------------------------ 628 629 procedure Specify_Adalib_Dir (Path : String) is 630 begin 631 if Path'Length = 0 then 632 Adalib_Path := null; 633 else 634 Adalib_Path := new String'(Path); 635 end if; 636 end Specify_Adalib_Dir; 637 638end MLib.Utl; 639