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-2014, 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 286 for J in Ranlib_Options'Range loop 287 Write_Str (Ranlib_Options (J).all); 288 Write_Char (' '); 289 end loop; 290 291 Write_Line (Arguments (Ar_Options'Length + 1).all); 292 end if; 293 294 Spawn 295 (Ranlib_Exec.all, 296 Ranlib_Options.all & (Arguments (Ar_Options'Length + 1)), 297 Success); 298 299 if not Success then 300 Fail (Ranlib_Name.all & " execution error."); 301 end if; 302 end if; 303 end Ar; 304 305 ----------------- 306 -- Delete_File -- 307 ----------------- 308 309 procedure Delete_File (Filename : String) is 310 File : constant String := Filename & ASCII.NUL; 311 Success : Boolean; 312 313 begin 314 Delete_File (File'Address, Success); 315 316 if Opt.Verbose_Mode then 317 if Success then 318 Write_Str ("deleted "); 319 320 else 321 Write_Str ("could not delete "); 322 end if; 323 324 Write_Line (Filename); 325 end if; 326 end Delete_File; 327 328 --------- 329 -- Gcc -- 330 --------- 331 332 procedure Gcc 333 (Output_File : String; 334 Objects : Argument_List; 335 Options : Argument_List; 336 Options_2 : Argument_List; 337 Driver_Name : Name_Id := No_Name) 338 is 339 Link_Bytes : Integer := 0; 340 -- Projected number of bytes for the linker command line 341 342 Link_Max : Integer; 343 pragma Import (C, Link_Max, "__gnat_link_max"); 344 -- Maximum number of bytes on the command line supported by the OS 345 -- linker. Passed this limit the response file mechanism must be used 346 -- if supported. 347 348 Object_List_File_Supported : Boolean; 349 for Object_List_File_Supported'Size use Character'Size; 350 pragma Import 351 (C, Object_List_File_Supported, "__gnat_objlist_file_supported"); 352 -- Predicate indicating whether the linker has an option whereby the 353 -- names of object files can be passed to the linker in a file. 354 355 Object_File_Option_Ptr : Interfaces.C.Strings.chars_ptr; 356 pragma Import (C, Object_File_Option_Ptr, "__gnat_object_file_option"); 357 -- Pointer to a string representing the linker option which specifies 358 -- the response file. 359 360 Object_File_Option : constant String := Value (Object_File_Option_Ptr); 361 -- The linker option which specifies the response file as a string 362 363 Using_GNU_response_file : constant Boolean := 364 Object_File_Option'Length > 0 365 and then 366 Object_File_Option 367 (Object_File_Option'Last) = '@'; 368 -- Whether a GNU response file is used 369 370 Tname : String_Access; 371 Tname_FD : File_Descriptor := Invalid_FD; 372 -- Temporary file used by linker to pass list of object files on 373 -- certain systems with limitations on size of arguments. 374 375 Closing_Status : Boolean; 376 -- For call to Close 377 378 Arguments : 379 Argument_List 380 (1 .. 7 + Objects'Length + Options'Length + Options_2'Length); 381 382 A : Natural := 0; 383 Success : Boolean; 384 385 Out_Opt : constant String_Access := new String'("-o"); 386 Out_V : constant String_Access := new String'(Output_File); 387 Lib_Dir : constant String_Access := new String'("-L" & Lib_Directory); 388 Lib_Opt : constant String_Access := new String'(Dynamic_Option); 389 390 Driver : String_Access; 391 392 type Object_Position is (First, Second, Last); 393 394 Position : Object_Position; 395 396 procedure Write_RF (S : String); 397 -- Write a string to the response file and check if it was successful. 398 -- Fail the program if it was not successful (disk full). 399 400 -------------- 401 -- Write_RF -- 402 -------------- 403 404 procedure Write_RF (S : String) is 405 Success : Boolean := True; 406 Back_Slash : constant Character := '\'; 407 408 begin 409 -- If a GNU response file is used, space and backslash need to be 410 -- escaped because they are interpreted as a string separator and 411 -- an escape character respectively by the underlying mechanism. 412 -- On the other hand, quote and double-quote are not escaped since 413 -- they are interpreted as string delimiters on both sides. 414 415 if Using_GNU_response_file then 416 for J in S'Range loop 417 if S (J) = ' ' or else S (J) = '\' then 418 if Write (Tname_FD, Back_Slash'Address, 1) /= 1 then 419 Success := False; 420 end if; 421 end if; 422 423 if Write (Tname_FD, S (J)'Address, 1) /= 1 then 424 Success := False; 425 end if; 426 end loop; 427 428 else 429 if Write (Tname_FD, S'Address, S'Length) /= S'Length then 430 Success := False; 431 end if; 432 end if; 433 434 if Write (Tname_FD, ASCII.LF'Address, 1) /= 1 then 435 Success := False; 436 end if; 437 438 if not Success then 439 Fail ("cannot generate response file to link library: disk full"); 440 end if; 441 end Write_RF; 442 443 -- Start of processing for Gcc 444 445 begin 446 if Driver_Name = No_Name then 447 if Gcc_Exec = null then 448 if Gcc_Name = null then 449 Gcc_Name := Osint.Program_Name ("gcc", "gnatmake"); 450 end if; 451 452 Gcc_Exec := Locate_Exec_On_Path (Gcc_Name.all); 453 454 if Gcc_Exec = null then 455 Fail (Gcc_Name.all & " not found in path"); 456 end if; 457 end if; 458 459 Driver := Gcc_Exec; 460 461 else 462 Driver := Locate_Exec_On_Path (Get_Name_String (Driver_Name)); 463 464 if Driver = null then 465 Fail (Get_Name_String (Driver_Name) & " not found in path"); 466 end if; 467 end if; 468 469 Link_Bytes := 0; 470 471 if Lib_Opt'Length /= 0 then 472 A := A + 1; 473 Arguments (A) := Lib_Opt; 474 Link_Bytes := Link_Bytes + Lib_Opt'Length + 1; 475 end if; 476 477 A := A + 1; 478 Arguments (A) := Out_Opt; 479 Link_Bytes := Link_Bytes + Out_Opt'Length + 1; 480 481 A := A + 1; 482 Arguments (A) := Out_V; 483 Link_Bytes := Link_Bytes + Out_V'Length + 1; 484 485 A := A + 1; 486 Arguments (A) := Lib_Dir; 487 Link_Bytes := Link_Bytes + Lib_Dir'Length + 1; 488 489 A := A + Options'Length; 490 Arguments (A - Options'Length + 1 .. A) := Options; 491 492 for J in Options'Range loop 493 Link_Bytes := Link_Bytes + Options (J)'Length + 1; 494 end loop; 495 496 if not Opt.Quiet_Output then 497 if Opt.Verbose_Mode then 498 Write_Str (Driver.all); 499 500 elsif Driver_Name /= No_Name then 501 Write_Str (Get_Name_String (Driver_Name)); 502 503 else 504 Write_Str (Gcc_Name.all); 505 end if; 506 507 for J in 1 .. A loop 508 if Opt.Verbose_Mode or else J < 4 then 509 Write_Char (' '); 510 Write_Str (Arguments (J).all); 511 512 else 513 Write_Str (" ..."); 514 exit; 515 end if; 516 end loop; 517 518 -- Do not display all the object files if not in verbose mode, only 519 -- the first one. 520 521 Position := First; 522 for J in Objects'Range loop 523 if Opt.Verbose_Mode or else Position = First then 524 Write_Char (' '); 525 Write_Str (Objects (J).all); 526 Position := Second; 527 528 elsif Position = Second then 529 Write_Str (" ..."); 530 Position := Last; 531 exit; 532 end if; 533 end loop; 534 535 for J in Options_2'Range loop 536 if not Opt.Verbose_Mode then 537 if Position = Second then 538 Write_Str (" ..."); 539 end if; 540 541 exit; 542 end if; 543 544 Write_Char (' '); 545 Write_Str (Options_2 (J).all); 546 end loop; 547 548 Write_Eol; 549 end if; 550 551 for J in Objects'Range loop 552 Link_Bytes := Link_Bytes + Objects (J)'Length + 1; 553 end loop; 554 555 for J in Options_2'Range loop 556 Link_Bytes := Link_Bytes + Options_2 (J)'Length + 1; 557 end loop; 558 559 if Object_List_File_Supported and then Link_Bytes > Link_Max then 560 561 -- Create a temporary file containing the object files, one object 562 -- file per line for maximal compatibility with linkers supporting 563 -- this option. 564 565 Create_Temp_File (Tname_FD, Tname); 566 567 for J in Objects'Range loop 568 Write_RF (Objects (J).all); 569 end loop; 570 571 Close (Tname_FD, Closing_Status); 572 573 if not Closing_Status then 574 Fail ("cannot generate response file to link library: disk full"); 575 end if; 576 577 A := A + 1; 578 Arguments (A) := new String'(Object_File_Option & Tname.all); 579 580 else 581 A := A + Objects'Length; 582 Arguments (A - Objects'Length + 1 .. A) := Objects; 583 end if; 584 585 A := A + Options_2'Length; 586 Arguments (A - Options_2'Length + 1 .. A) := Options_2; 587 588 Spawn (Driver.all, Arguments (1 .. A), Success); 589 590 if Success then 591 -- Delete the temporary file used in conjunction with linking 592 -- if one was created. 593 594 if Tname_FD /= Invalid_FD then 595 Delete_File (Tname.all); 596 end if; 597 598 else 599 if Driver_Name = No_Name then 600 Fail (Gcc_Name.all & " execution error"); 601 else 602 Fail (Get_Name_String (Driver_Name) & " execution error"); 603 end if; 604 end if; 605 end Gcc; 606 607 ------------------- 608 -- Lib_Directory -- 609 ------------------- 610 611 function Lib_Directory return String is 612 Libgnat : constant String := Tgt.Libgnat; 613 614 begin 615 -- If procedure Specify_Adalib_Dir has been called, used the specified 616 -- value. 617 618 if Adalib_Path /= null then 619 return Adalib_Path.all; 620 end if; 621 622 Name_Len := Libgnat'Length; 623 Name_Buffer (1 .. Name_Len) := Libgnat; 624 Get_Name_String (Osint.Find_File (Name_Enter, Osint.Library)); 625 626 -- Remove libgnat.a 627 628 return Name_Buffer (1 .. Name_Len - Libgnat'Length); 629 end Lib_Directory; 630 631 ------------------------ 632 -- Specify_Adalib_Dir -- 633 ------------------------ 634 635 procedure Specify_Adalib_Dir (Path : String) is 636 begin 637 if Path'Length = 0 then 638 Adalib_Path := null; 639 else 640 Adalib_Path := new String'(Path); 641 end if; 642 end Specify_Adalib_Dir; 643 644end MLib.Utl; 645