1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- M L I B . P R J -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2001-2003, Ada Core Technologies, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 2, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING. If not, write -- 19-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- 20-- MA 02111-1307, USA. -- 21-- -- 22-- GNAT was originally developed by the GNAT team at New York University. -- 23-- Extensive contributions were provided by Ada Core Technologies Inc. -- 24-- -- 25------------------------------------------------------------------------------ 26 27with ALI; use ALI; 28with Gnatvsn; use Gnatvsn; 29with Hostparm; 30with MLib.Fil; use MLib.Fil; 31with MLib.Tgt; use MLib.Tgt; 32with MLib.Utl; use MLib.Utl; 33with Namet; use Namet; 34with Opt; 35with Osint; use Osint; 36with Output; use Output; 37with Prj.Com; use Prj.Com; 38with Prj.Env; use Prj.Env; 39with Prj.Util; use Prj.Util; 40with Sinput.P; 41with Snames; use Snames; 42with Table; 43with Types; use Types; 44 45with Ada.Characters.Handling; 46 47with GNAT.Directory_Operations; use GNAT.Directory_Operations; 48with GNAT.HTable; 49with GNAT.OS_Lib; use GNAT.OS_Lib; 50with Interfaces.C_Streams; use Interfaces.C_Streams; 51with System; use System; 52with System.Case_Util; use System.Case_Util; 53 54package body MLib.Prj is 55 56 Prj_Add_Obj_Files : Types.Int; 57 pragma Import (C, Prj_Add_Obj_Files, "__gnat_prj_add_obj_files"); 58 Add_Object_Files : constant Boolean := Prj_Add_Obj_Files /= 0; 59 -- Indicates if object files in pragmas Linker_Options (found in the 60 -- binder generated file) should be taken when linking aq stand-alone 61 -- library. 62 -- False for Windows, True for other platforms. 63 64 ALI_Suffix : constant String := ".ali"; 65 B_Start : String := "b~"; 66 67 S_Osinte_Ads : Name_Id := No_Name; 68 -- Name_Id for "s-osinte.ads" 69 70 S_Dec_Ads : Name_Id := No_Name; 71 -- Name_Id for "dec.ads" 72 73 No_Argument_List : aliased String_List := (1 .. 0 => null); 74 No_Argument : constant String_List_Access := No_Argument_List'Access; 75 76 Arguments : String_List_Access := No_Argument; 77 -- Used to accumulate arguments for the invocation of gnatbind and of 78 -- the compiler. Also used to collect the interface ALI when copying 79 -- the ALI files to the library directory. 80 81 Argument_Number : Natural := 0; 82 -- Index of the last argument in Arguments 83 84 Initial_Argument_Max : constant := 10; 85 86 No_Main_String : aliased String := "-n"; 87 No_Main : constant String_Access := No_Main_String'Access; 88 89 Output_Switch_String : aliased String := "-o"; 90 Output_Switch : constant String_Access := Output_Switch_String'Access; 91 92 Compile_Switch_String : aliased String := "-c"; 93 Compile_Switch : constant String_Access := Compile_Switch_String'Access; 94 95 -- List of objects to put inside the library 96 97 Object_Files : Argument_List_Access; 98 99 package Objects is new Table.Table 100 (Table_Name => "Mlib.Prj.Objects", 101 Table_Component_Type => String_Access, 102 Table_Index_Type => Natural, 103 Table_Low_Bound => 1, 104 Table_Initial => 50, 105 Table_Increment => 100); 106 107 package Objects_Htable is new GNAT.HTable.Simple_HTable 108 (Header_Num => Com.Header_Num, 109 Element => Boolean, 110 No_Element => False, 111 Key => Name_Id, 112 Hash => Com.Hash, 113 Equal => "="); 114 115 -- List of non-Ada object files 116 117 Foreign_Objects : Argument_List_Access; 118 119 package Foreigns is new Table.Table 120 (Table_Name => "Mlib.Prj.Foreigns", 121 Table_Component_Type => String_Access, 122 Table_Index_Type => Natural, 123 Table_Low_Bound => 1, 124 Table_Initial => 20, 125 Table_Increment => 100); 126 127 -- List of ALI files 128 129 Ali_Files : Argument_List_Access; 130 131 package ALIs is new Table.Table 132 (Table_Name => "Mlib.Prj.Alis", 133 Table_Component_Type => String_Access, 134 Table_Index_Type => Natural, 135 Table_Low_Bound => 1, 136 Table_Initial => 50, 137 Table_Increment => 100); 138 139 -- List of options set in the command line. 140 141 Options : Argument_List_Access; 142 143 package Opts is new Table.Table 144 (Table_Name => "Mlib.Prj.Opts", 145 Table_Component_Type => String_Access, 146 Table_Index_Type => Natural, 147 Table_Low_Bound => 1, 148 Table_Initial => 5, 149 Table_Increment => 100); 150 151 -- All the ALI file in the library 152 153 package Library_ALIs is new GNAT.HTable.Simple_HTable 154 (Header_Num => Com.Header_Num, 155 Element => Boolean, 156 No_Element => False, 157 Key => Name_Id, 158 Hash => Com.Hash, 159 Equal => "="); 160 161 -- The ALI files in the interface sets 162 163 package Interface_ALIs is new GNAT.HTable.Simple_HTable 164 (Header_Num => Com.Header_Num, 165 Element => Boolean, 166 No_Element => False, 167 Key => Name_Id, 168 Hash => Com.Hash, 169 Equal => "="); 170 171 -- The ALI files that have been processed to check if the corresponding 172 -- library unit is in the interface set. 173 174 package Processed_ALIs is new GNAT.HTable.Simple_HTable 175 (Header_Num => Com.Header_Num, 176 Element => Boolean, 177 No_Element => False, 178 Key => Name_Id, 179 Hash => Com.Hash, 180 Equal => "="); 181 182 -- The projects imported directly or indirectly. 183 184 package Processed_Projects is new GNAT.HTable.Simple_HTable 185 (Header_Num => Com.Header_Num, 186 Element => Boolean, 187 No_Element => False, 188 Key => Name_Id, 189 Hash => Com.Hash, 190 Equal => "="); 191 192 -- The library projects imported directly or indirectly. 193 194 package Library_Projs is new Table.Table ( 195 Table_Component_Type => Project_Id, 196 Table_Index_Type => Integer, 197 Table_Low_Bound => 1, 198 Table_Initial => 10, 199 Table_Increment => 10, 200 Table_Name => "Make.Library_Projs"); 201 202 type Build_Mode_State is (None, Static, Dynamic, Relocatable); 203 204 procedure Add_Argument (S : String); 205 -- Add one argument to the array Arguments. 206 -- If Arguments is full, double its size. 207 208 function ALI_File_Name (Source : String) return String; 209 -- Return the ALI file name corresponding to a source. 210 211 procedure Check (Filename : String); 212 -- Check if filename is a regular file. Fail if it is not. 213 214 procedure Check_Context; 215 -- Check each object files in table Object_Files 216 -- Fail if any of them is not a regular file 217 218 procedure Clean (Directory : Name_Id); 219 -- Attempt to delete all files in Directory, but not subdirectories 220 221 procedure Copy_Interface_Sources 222 (For_Project : Project_Id; 223 Interfaces : Argument_List; 224 To_Dir : Name_Id); 225 -- Copy the interface sources of a SAL to directory To_Dir 226 227 procedure Display (Executable : String); 228 -- Display invocation of gnatbind and of the compiler with the arguments 229 -- in Arguments, except when Quiet_Output is True. 230 231 procedure Process_Binder_File (Name : String); 232 -- For Stand-Alone libraries, get the Linker Options in the binder 233 -- generated file. 234 235 procedure Reset_Tables; 236 -- Make sure that all the above tables are empty 237 -- (Objects, Foreign_Objects, Ali_Files, Options). 238 239 ------------------ 240 -- Add_Argument -- 241 ------------------ 242 243 procedure Add_Argument (S : String) is 244 begin 245 if Argument_Number = Arguments'Last then 246 declare 247 New_Args : constant String_List_Access := 248 new String_List (1 .. 2 * Arguments'Last); 249 250 begin 251 -- Copy the String_Accesses and set them to null in Arguments 252 -- so that they will not be deallocated by the call to 253 -- Free (Arguments). 254 255 New_Args (Arguments'Range) := Arguments.all; 256 Arguments.all := (others => null); 257 Free (Arguments); 258 Arguments := New_Args; 259 end; 260 end if; 261 262 Argument_Number := Argument_Number + 1; 263 Arguments (Argument_Number) := new String'(S); 264 end Add_Argument; 265 266 ------------------- 267 -- ALI_File_Name -- 268 ------------------- 269 270 function ALI_File_Name (Source : String) return String is 271 begin 272 -- If the source name has an extension, then replace it with 273 -- the ALI suffix. 274 275 for Index in reverse Source'First + 1 .. Source'Last loop 276 if Source (Index) = '.' then 277 return Source (Source'First .. Index - 1) & ALI_Suffix; 278 end if; 279 end loop; 280 281 -- If there is no dot, or if it is the first character, just add the 282 -- ALI suffix. 283 284 return Source & ALI_Suffix; 285 end ALI_File_Name; 286 287 ------------------- 288 -- Build_Library -- 289 ------------------- 290 291 procedure Build_Library 292 (For_Project : Project_Id; 293 Gnatbind : String; 294 Gnatbind_Path : String_Access; 295 Gcc : String; 296 Gcc_Path : String_Access; 297 Bind : Boolean := True; 298 Link : Boolean := True) 299 is 300 Warning_For_Library : Boolean := False; 301 -- Set to True for the first warning about a unit missing from the 302 -- interface set. 303 304 Libgnarl_Needed : Boolean := False; 305 -- Set to True if library needs to be linked with libgnarl 306 307 Libdecgnat_Needed : Boolean := False; 308 -- On OpenVMS, set to True if library needs to be linked with libdecgnat 309 310 Data : Project_Data := Projects.Table (For_Project); 311 312 Object_Directory_Path : constant String := 313 Get_Name_String (Data.Object_Directory); 314 315 Standalone : constant Boolean := Data.Standalone_Library; 316 317 Project_Name : constant String := Get_Name_String (Data.Name); 318 319 DLL_Address : constant String_Access := 320 new String'(Default_DLL_Address); 321 322 Current_Dir : constant String := Get_Current_Dir; 323 324 Lib_Filename : String_Access; 325 Lib_Dirpath : String_Access; 326 Lib_Version : String_Access := new String'(""); 327 328 The_Build_Mode : Build_Mode_State := None; 329 330 Success : Boolean := False; 331 332 Library_Options : Variable_Value := Nil_Variable_Value; 333 334 Library_GCC : Variable_Value := Nil_Variable_Value; 335 336 Driver_Name : Name_Id := No_Name; 337 338 In_Main_Object_Directory : Boolean := True; 339 340 Rpath : String_Access := null; 341 -- Allocated only if Path Option is supported 342 343 Rpath_Last : Natural := 0; 344 -- Index of last valid character of Rpath 345 346 Initial_Rpath_Length : constant := 200; 347 -- Initial size of Rpath, when first allocated 348 349 Path_Option : String_Access := Linker_Library_Path_Option; 350 -- If null, Path Option is not supported. 351 -- Not a constant so that it can be deallocated. 352 353 Copy_Dir : Name_Id; 354 -- Directory where to copy ALI files and possibly interface sources 355 356 procedure Add_ALI_For (Source : Name_Id); 357 -- Add the name of the ALI file corresponding to Source to the 358 -- Arguments. 359 360 procedure Add_Rpath (Path : String); 361 -- Add a path name to Rpath 362 363 function Check_Project (P : Project_Id) return Boolean; 364 -- Returns True if P is For_Project or a project extended by For_Project 365 366 procedure Check_Libs (ALI_File : String); 367 -- Set Libgnarl_Needed if the ALI_File indicates that there is a need 368 -- to link with -lgnarl (this is the case when there is a dependency 369 -- on s-osinte.ads). On OpenVMS, set Libdecgnat_Needed if the ALI file 370 -- indicates that there is a need to link with -ldecgnat (this is the 371 -- case when there is a dependency on dec.ads). 372 373 procedure Process (The_ALI : File_Name_Type); 374 -- Check if the closure of a library unit which is or should be in the 375 -- interface set is also in the interface set. Issue a warning for each 376 -- missing library unit. 377 378 procedure Process_Imported_Libraries; 379 -- Add the -L and -l switches for the imported Library Project Files, 380 -- and, if Path Option is supported, the library directory path names 381 -- to Rpath. 382 383 ----------------- 384 -- Add_ALI_For -- 385 ----------------- 386 387 procedure Add_ALI_For (Source : Name_Id) is 388 ALI : constant String := ALI_File_Name (Get_Name_String (Source)); 389 begin 390 Add_Argument (ALI); 391 392 -- Add the ALI file name to the library ALIs 393 394 Name_Len := 0; 395 Add_Str_To_Name_Buffer (S => ALI); 396 Library_ALIs.Set (Name_Find, True); 397 end Add_ALI_For; 398 399 --------------- 400 -- Add_Rpath -- 401 --------------- 402 403 procedure Add_Rpath (Path : String) is 404 405 procedure Double; 406 -- Double Rpath size 407 408 ------------ 409 -- Double -- 410 ------------ 411 412 procedure Double is 413 New_Rpath : constant String_Access := 414 new String (1 .. 2 * Rpath'Length); 415 begin 416 New_Rpath (1 .. Rpath_Last) := Rpath (1 .. Rpath_Last); 417 Free (Rpath); 418 Rpath := New_Rpath; 419 end Double; 420 421 -- Start of processing for Add_Rpath 422 423 begin 424 -- If firt path, allocate initial Rpath 425 426 if Rpath = null then 427 Rpath := new String (1 .. Initial_Rpath_Length); 428 Rpath_Last := 0; 429 430 else 431 -- Otherwise, add a path separator between two path names 432 433 if Rpath_Last = Rpath'Last then 434 Double; 435 end if; 436 437 Rpath_Last := Rpath_Last + 1; 438 Rpath (Rpath_Last) := Path_Separator; 439 end if; 440 441 -- Increase Rpath size until it is large enough 442 443 while Rpath_Last + Path'Length > Rpath'Last loop 444 Double; 445 end loop; 446 447 -- Add the path name 448 449 Rpath (Rpath_Last + 1 .. Rpath_Last + Path'Length) := Path; 450 Rpath_Last := Rpath_Last + Path'Length; 451 end Add_Rpath; 452 453 ------------------- 454 -- Check_Project -- 455 ------------------- 456 457 function Check_Project (P : Project_Id) return Boolean is 458 begin 459 if P = For_Project then 460 return True; 461 462 elsif P /= No_Project then 463 declare 464 Data : Project_Data := Projects.Table (For_Project); 465 466 begin 467 while Data.Extends /= No_Project loop 468 if P = Data.Extends then 469 return True; 470 end if; 471 472 Data := Projects.Table (Data.Extends); 473 end loop; 474 end; 475 end if; 476 477 return False; 478 end Check_Project; 479 480 ---------------- 481 -- Check_Libs -- 482 ---------------- 483 484 procedure Check_Libs (ALI_File : String) is 485 Lib_File : Name_Id; 486 Text : Text_Buffer_Ptr; 487 Id : ALI.ALI_Id; 488 489 pragma Warnings (Off, Id); 490 -- Comment needed ??? 491 492 begin 493 if not Libgnarl_Needed or 494 (Hostparm.OpenVMS and then (not Libdecgnat_Needed)) 495 then 496 -- Scan the ALI file 497 498 Name_Len := ALI_File'Length; 499 Name_Buffer (1 .. Name_Len) := ALI_File; 500 Lib_File := Name_Find; 501 Text := Read_Library_Info (Lib_File, True); 502 503 Id := ALI.Scan_ALI 504 (F => Lib_File, 505 T => Text, 506 Ignore_ED => False, 507 Err => True, 508 Read_Lines => "D"); 509 Free (Text); 510 511 -- Look for s-osinte.ads in the dependencies 512 513 for Index in ALI.ALIs.Table (Id).First_Sdep .. 514 ALI.ALIs.Table (Id).Last_Sdep 515 loop 516 if ALI.Sdep.Table (Index).Sfile = S_Osinte_Ads then 517 Libgnarl_Needed := True; 518 519 elsif Hostparm.OpenVMS and then 520 ALI.Sdep.Table (Index).Sfile = S_Dec_Ads 521 then 522 Libdecgnat_Needed := True; 523 end if; 524 end loop; 525 end if; 526 end Check_Libs; 527 528 ------------- 529 -- Process -- 530 ------------- 531 532 procedure Process (The_ALI : File_Name_Type) is 533 Text : Text_Buffer_Ptr; 534 Idread : ALI_Id; 535 First_Unit : ALI.Unit_Id; 536 Last_Unit : ALI.Unit_Id; 537 Unit_Data : Unit_Record; 538 Afile : File_Name_Type; 539 540 begin 541 -- Nothing to do if the ALI file has already been processed. 542 -- This happens if an interface imports another interface. 543 544 if not Processed_ALIs.Get (The_ALI) then 545 Processed_ALIs.Set (The_ALI, True); 546 Text := Read_Library_Info (The_ALI); 547 548 if Text /= null then 549 Idread := 550 Scan_ALI 551 (F => The_ALI, 552 T => Text, 553 Ignore_ED => False, 554 Err => True); 555 Free (Text); 556 557 if Idread /= No_ALI_Id then 558 First_Unit := ALI.ALIs.Table (Idread).First_Unit; 559 Last_Unit := ALI.ALIs.Table (Idread).Last_Unit; 560 561 -- Process both unit (spec and body) if the body is needed 562 -- by the spec (inline or generic). Otherwise, just process 563 -- the spec. 564 565 if First_Unit /= Last_Unit and then 566 not ALI.Units.Table (Last_Unit).Body_Needed_For_SAL 567 then 568 First_Unit := Last_Unit; 569 end if; 570 571 for Unit in First_Unit .. Last_Unit loop 572 Unit_Data := ALI.Units.Table (Unit); 573 574 -- Check if each withed unit which is in the library is 575 -- also in the interface set, if it has not yet been 576 -- processed. 577 578 for W in Unit_Data.First_With .. Unit_Data.Last_With loop 579 Afile := Withs.Table (W).Afile; 580 581 if Afile /= No_Name and then Library_ALIs.Get (Afile) 582 and then not Processed_ALIs.Get (Afile) 583 then 584 if not Interface_ALIs.Get (Afile) then 585 if not Warning_For_Library then 586 Write_Str ("Warning: In library project """); 587 Get_Name_String (Data.Name); 588 To_Mixed (Name_Buffer (1 .. Name_Len)); 589 Write_Str (Name_Buffer (1 .. Name_Len)); 590 Write_Line (""""); 591 Warning_For_Library := True; 592 end if; 593 594 Write_Str (" Unit """); 595 Get_Name_String (Withs.Table (W).Uname); 596 To_Mixed (Name_Buffer (1 .. Name_Len - 2)); 597 Write_Str (Name_Buffer (1 .. Name_Len - 2)); 598 Write_Line (""" is not in the interface set"); 599 Write_Str (" but it is needed by "); 600 601 case Unit_Data.Utype is 602 when Is_Spec => 603 Write_Str ("the spec of "); 604 605 when Is_Body => 606 Write_Str ("the body of "); 607 608 when others => 609 null; 610 end case; 611 612 Write_Str (""""); 613 Get_Name_String (Unit_Data.Uname); 614 To_Mixed (Name_Buffer (1 .. Name_Len - 2)); 615 Write_Str (Name_Buffer (1 .. Name_Len - 2)); 616 Write_Line (""""); 617 end if; 618 619 -- Now, process this unit 620 621 Process (Afile); 622 end if; 623 end loop; 624 end loop; 625 end if; 626 end if; 627 end if; 628 end Process; 629 630 -------------------------------- 631 -- Process_Imported_Libraries -- 632 -------------------------------- 633 634 procedure Process_Imported_Libraries is 635 Current : Project_Id; 636 637 procedure Process_Project (Project : Project_Id); 638 -- Process Project and its imported projects recursively. 639 -- Add any library projects to table Library_Projs. 640 641 --------------------- 642 -- Process_Project -- 643 --------------------- 644 645 procedure Process_Project (Project : Project_Id) is 646 Data : constant Project_Data := Projects.Table (Project); 647 Imported : Project_List := Data.Imported_Projects; 648 Element : Project_Element; 649 650 begin 651 -- Nothing to do if process has already been processed. 652 653 if not Processed_Projects.Get (Data.Name) then 654 Processed_Projects.Set (Data.Name, True); 655 656 -- If it is a library project, add it to Library_Projs 657 658 if Project /= For_Project and then Data.Library then 659 Library_Projs.Increment_Last; 660 Library_Projs.Table (Library_Projs.Last) := Project; 661 end if; 662 663 -- Call Process_Project recursively for any imported project 664 665 while Imported /= Empty_Project_List loop 666 Element := Project_Lists.Table (Imported); 667 668 if Element.Project /= No_Project then 669 Process_Project (Element.Project); 670 end if; 671 672 Imported := Element.Next; 673 end loop; 674 end if; 675 end Process_Project; 676 677 -- Start of processing for Process_Imported_Libraries 678 679 begin 680 -- Build list of library projects imported directly or indirectly 681 682 Process_Project (For_Project); 683 684 -- If there are more that one library project file, make sure 685 -- that if libA depends on libB, libB is first in order. 686 687 if Library_Projs.Last > 1 then 688 declare 689 Index : Integer := 1; 690 Proj1 : Project_Id; 691 Proj2 : Project_Id; 692 List : Project_List := Empty_Project_List; 693 694 begin 695 Library_Loop : while Index < Library_Projs.Last loop 696 Proj1 := Library_Projs.Table (Index); 697 List := Projects.Table (Proj1).Imported_Projects; 698 699 List_Loop : while List /= Empty_Project_List loop 700 Proj2 := Project_Lists.Table (List).Project; 701 702 for J in Index + 1 .. Library_Projs.Last loop 703 if Proj2 = Library_Projs.Table (J) then 704 Library_Projs.Table (J) := Proj1; 705 Library_Projs.Table (Index) := Proj2; 706 exit List_Loop; 707 end if; 708 end loop; 709 710 List := Project_Lists.Table (List).Next; 711 end loop List_Loop; 712 713 if List = Empty_Project_List then 714 Index := Index + 1; 715 end if; 716 end loop Library_Loop; 717 end; 718 end if; 719 720 -- Now that we have a correct order, add the -L and -l switches and, 721 -- if the Rpath option is supported, add the directory to the Rpath. 722 723 for Index in 1 .. Library_Projs.Last loop 724 Current := Library_Projs.Table (Index); 725 726 Opts.Increment_Last; 727 Opts.Table (Opts.Last) := 728 new String' 729 ("-L" & 730 Get_Name_String 731 (Projects.Table (Current).Library_Dir)); 732 733 if Path_Option /= null then 734 Add_Rpath 735 (Get_Name_String 736 (Projects.Table (Current).Library_Dir)); 737 end if; 738 739 Opts.Increment_Last; 740 Opts.Table (Opts.Last) := 741 new String' 742 ("-l" & 743 Get_Name_String 744 (Projects.Table (Current).Library_Name)); 745 end loop; 746 end Process_Imported_Libraries; 747 748 -- Start of processing for Build_Library 749 750 begin 751 Reset_Tables; 752 753 -- Fail if project is not a library project 754 755 if not Data.Library then 756 Com.Fail ("project """, Project_Name, """ has no library"); 757 end if; 758 759 -- If this is the first time Build_Library is called, get the Name_Id 760 -- of "s-osinte.ads". 761 762 if S_Osinte_Ads = No_Name then 763 Name_Len := 12; 764 Name_Buffer (1 .. Name_Len) := "s-osinte.ads"; 765 S_Osinte_Ads := Name_Find; 766 end if; 767 768 if S_Dec_Ads = No_Name then 769 Name_Len := 7; 770 Name_Buffer (1 .. Name_Len) := "dec.ads"; 771 S_Dec_Ads := Name_Find; 772 end if; 773 774 -- We work in the object directory 775 776 Change_Dir (Object_Directory_Path); 777 778 if Standalone then 779 -- Call gnatbind only if Bind is True 780 781 if Bind then 782 if Gnatbind_Path = null then 783 Com.Fail ("unable to locate ", Gnatbind); 784 end if; 785 786 if Gcc_Path = null then 787 Com.Fail ("unable to locate ", Gcc); 788 end if; 789 790 -- Allocate Arguments, if it is the first time we see a standalone 791 -- library. 792 793 if Arguments = No_Argument then 794 Arguments := new String_List (1 .. Initial_Argument_Max); 795 end if; 796 797 -- Add "-n -o b~<lib>.adb (b$<lib>.adb on VMS) -L<lib>" 798 799 Argument_Number := 2; 800 Arguments (1) := No_Main; 801 Arguments (2) := Output_Switch; 802 803 if Hostparm.OpenVMS then 804 B_Start (B_Start'Last) := '$'; 805 end if; 806 807 Add_Argument 808 (B_Start & Get_Name_String (Data.Library_Name) & ".adb"); 809 Add_Argument ("-L" & Get_Name_String (Data.Library_Name)); 810 811 -- Check if Binder'Default_Switches ("Ada) is defined. If it is, 812 -- add these switches to call gnatbind. 813 814 declare 815 Binder_Package : constant Package_Id := 816 Value_Of 817 (Name => Name_Binder, 818 In_Packages => Data.Decl.Packages); 819 820 begin 821 if Binder_Package /= No_Package then 822 declare 823 Defaults : constant Array_Element_Id := 824 Value_Of 825 (Name => Name_Default_Switches, 826 In_Arrays => 827 Packages.Table 828 (Binder_Package).Decl.Arrays); 829 Switches : Variable_Value := Nil_Variable_Value; 830 831 Switch : String_List_Id := Nil_String; 832 833 begin 834 if Defaults /= No_Array_Element then 835 Switches := 836 Value_Of 837 (Index => Name_Ada, In_Array => Defaults); 838 839 if not Switches.Default then 840 Switch := Switches.Values; 841 842 while Switch /= Nil_String loop 843 Add_Argument 844 (Get_Name_String 845 (String_Elements.Table (Switch).Value)); 846 Switch := String_Elements.Table (Switch).Next; 847 end loop; 848 end if; 849 end if; 850 end; 851 end if; 852 end; 853 854 -- Get all the ALI files of the project file 855 856 declare 857 Unit : Unit_Data; 858 859 begin 860 Library_ALIs.Reset; 861 Interface_ALIs.Reset; 862 Processed_ALIs.Reset; 863 for Source in 1 .. Com.Units.Last loop 864 Unit := Com.Units.Table (Source); 865 866 if Unit.File_Names (Body_Part).Name /= No_Name 867 and then Unit.File_Names (Body_Part).Path /= Slash 868 then 869 if 870 Check_Project (Unit.File_Names (Body_Part).Project) 871 then 872 if Unit.File_Names (Specification).Name = No_Name then 873 declare 874 Src_Ind : Source_File_Index; 875 876 begin 877 Src_Ind := Sinput.P.Load_Project_File 878 (Get_Name_String 879 (Unit.File_Names 880 (Body_Part).Path)); 881 882 -- Add the ALI file only if it is not a subunit 883 884 if 885 not Sinput.P.Source_File_Is_Subunit (Src_Ind) 886 then 887 Add_ALI_For 888 (Unit.File_Names (Body_Part).Name); 889 end if; 890 end; 891 892 else 893 Add_ALI_For (Unit.File_Names (Body_Part).Name); 894 end if; 895 end if; 896 897 elsif Unit.File_Names (Specification).Name /= No_Name 898 and then Unit.File_Names (Specification).Path /= Slash 899 and then Check_Project 900 (Unit.File_Names (Specification).Project) 901 then 902 Add_ALI_For (Unit.File_Names (Specification).Name); 903 end if; 904 end loop; 905 end; 906 907 -- Set the paths 908 909 Set_Ada_Paths 910 (Project => For_Project, Including_Libraries => True); 911 912 -- Display the gnatbind command, if not in quiet output 913 914 Display (Gnatbind); 915 916 -- Invoke gnatbind 917 918 GNAT.OS_Lib.Spawn 919 (Gnatbind_Path.all, Arguments (1 .. Argument_Number), Success); 920 921 if not Success then 922 Com.Fail ("could not bind standalone library ", 923 Get_Name_String (Data.Library_Name)); 924 end if; 925 926 end if; 927 928 -- Compile the binder generated file only if Link is true 929 930 if Link then 931 -- Set the paths 932 933 Set_Ada_Paths 934 (Project => For_Project, Including_Libraries => True); 935 936 -- Invoke <gcc> -c b$$<lib>.adb 937 938 -- Allocate Arguments, if it is the first time we see a standalone 939 -- library. 940 941 if Arguments = No_Argument then 942 Arguments := new String_List (1 .. Initial_Argument_Max); 943 end if; 944 945 Argument_Number := 1; 946 Arguments (1) := Compile_Switch; 947 948 if Hostparm.OpenVMS then 949 B_Start (B_Start'Last) := '$'; 950 end if; 951 952 Add_Argument 953 (B_Start & Get_Name_String (Data.Library_Name) & ".adb"); 954 955 -- If necessary, add the PIC option 956 957 if PIC_Option /= "" then 958 Add_Argument (PIC_Option); 959 end if; 960 961 Display (Gcc); 962 GNAT.OS_Lib.Spawn 963 (Gcc_Path.all, Arguments (1 .. Argument_Number), Success); 964 965 if not Success then 966 Com.Fail 967 ("could not compile binder generated file for library ", 968 Get_Name_String (Data.Library_Name)); 969 end if; 970 971 -- Process binder generated file for pragmas Linker_Options 972 973 Process_Binder_File (Arguments (2).all & ASCII.NUL); 974 end if; 975 end if; 976 977 -- Build the library only if Link is True 978 979 if Link then 980 -- If attribute Library_GCC was specified, get the driver name 981 982 Library_GCC := Value_Of (Name_Library_GCC, Data.Decl.Attributes); 983 984 if not Library_GCC.Default then 985 Driver_Name := Library_GCC.Value; 986 end if; 987 988 -- If attribute Library_Options was specified, add these additional 989 -- options. 990 991 Library_Options := 992 Value_Of (Name_Library_Options, Data.Decl.Attributes); 993 994 if not Library_Options.Default then 995 declare 996 Current : String_List_Id := Library_Options.Values; 997 Element : String_Element; 998 999 begin 1000 while Current /= Nil_String loop 1001 Element := String_Elements.Table (Current); 1002 Get_Name_String (Element.Value); 1003 1004 if Name_Len /= 0 then 1005 Opts.Increment_Last; 1006 Opts.Table (Opts.Last) := 1007 new String'(Name_Buffer (1 .. Name_Len)); 1008 end if; 1009 1010 Current := Element.Next; 1011 end loop; 1012 end; 1013 end if; 1014 1015 Lib_Dirpath := new String'(Get_Name_String (Data.Library_Dir)); 1016 Lib_Filename := new String'(Get_Name_String (Data.Library_Name)); 1017 1018 case Data.Library_Kind is 1019 when Static => 1020 The_Build_Mode := Static; 1021 1022 when Dynamic => 1023 The_Build_Mode := Dynamic; 1024 1025 when Relocatable => 1026 The_Build_Mode := Relocatable; 1027 1028 if PIC_Option /= "" then 1029 Opts.Increment_Last; 1030 Opts.Table (Opts.Last) := new String'(PIC_Option); 1031 end if; 1032 end case; 1033 1034 -- Get the library version, if any 1035 1036 if Data.Lib_Internal_Name /= No_Name then 1037 Lib_Version := 1038 new String'(Get_Name_String (Data.Lib_Internal_Name)); 1039 end if; 1040 1041 -- Add the objects found in the object directory and the object 1042 -- directories of the extended files, if any, except for generated 1043 -- object files (b~.. or B$..) from extended projects. 1044 -- When there are one or more extended files, only add an object file 1045 -- if no object file with the same name have already been added. 1046 1047 In_Main_Object_Directory := True; 1048 1049 loop 1050 declare 1051 Object_Dir_Path : constant String := 1052 Get_Name_String (Data.Object_Directory); 1053 Object_Dir : Dir_Type; 1054 Filename : String (1 .. 255); 1055 Last : Natural; 1056 Id : Name_Id; 1057 1058 begin 1059 Open (Dir => Object_Dir, Dir_Name => Object_Dir_Path); 1060 1061 -- For all entries in the object directory 1062 1063 loop 1064 Read (Object_Dir, Filename, Last); 1065 1066 exit when Last = 0; 1067 1068 -- Check if it is an object file 1069 1070 if Is_Obj (Filename (1 .. Last)) then 1071 declare 1072 Object_Path : String := 1073 Normalize_Pathname 1074 (Object_Dir_Path & Directory_Separator & 1075 Filename (1 .. Last)); 1076 1077 begin 1078 Canonical_Case_File_Name (Object_Path); 1079 Canonical_Case_File_Name (Filename (1 .. Last)); 1080 1081 -- If in the object directory of an extended project, 1082 -- do not consider generated object files. 1083 1084 if In_Main_Object_Directory or else 1085 Last < 5 or else 1086 Filename (1 .. B_Start'Length) /= B_Start 1087 then 1088 Name_Len := Last; 1089 Name_Buffer (1 .. Name_Len) := Filename (1 .. Last); 1090 Id := Name_Find; 1091 1092 if not Objects_Htable.Get (Id) then 1093 1094 -- Record this object file 1095 1096 Objects_Htable.Set (Id, True); 1097 Objects.Increment_Last; 1098 Objects.Table (Objects.Last) := 1099 new String'(Object_Path); 1100 1101 declare 1102 ALI_File : constant String := 1103 Ext_To (Object_Path, "ali"); 1104 1105 begin 1106 if Is_Regular_File (ALI_File) then 1107 1108 -- Record the ALI file 1109 1110 ALIs.Increment_Last; 1111 ALIs.Table (ALIs.Last) := 1112 new String'(ALI_File); 1113 1114 -- Find out if for this ALI file, 1115 -- libgnarl or libdecgnat (on OpenVMS) 1116 -- is necessary. 1117 1118 Check_Libs (ALI_File); 1119 1120 else 1121 -- The object file is a foreign object 1122 -- file. 1123 1124 Foreigns.Increment_Last; 1125 Foreigns.Table (Foreigns.Last) := 1126 new String'(Object_Path); 1127 end if; 1128 end; 1129 end if; 1130 end if; 1131 end; 1132 end if; 1133 end loop; 1134 1135 Close (Dir => Object_Dir); 1136 1137 exception 1138 when Directory_Error => 1139 Com.Fail ("cannot find object directory """, 1140 Get_Name_String (Data.Object_Directory), 1141 """"); 1142 end; 1143 1144 exit when Data.Extends = No_Project; 1145 1146 In_Main_Object_Directory := False; 1147 Data := Projects.Table (Data.Extends); 1148 end loop; 1149 1150 -- Add the -L and -l switches for the imported Library Project Files, 1151 -- and, if Path Option is supported, the library directory path names 1152 -- to Rpath. 1153 1154 Process_Imported_Libraries; 1155 1156 -- Link with libgnat and possibly libgnarl 1157 1158 Opts.Increment_Last; 1159 Opts.Table (Opts.Last) := new String'("-L" & Lib_Directory); 1160 1161 -- If Path Option is supported, add libgnat directory path name to 1162 -- Rpath. 1163 1164 if Path_Option /= null then 1165 Add_Rpath (Lib_Directory); 1166 end if; 1167 1168 if Libgnarl_Needed then 1169 Opts.Increment_Last; 1170 1171 if The_Build_Mode = Static then 1172 Opts.Table (Opts.Last) := new String'("-lgnarl"); 1173 else 1174 Opts.Table (Opts.Last) := new String'(Shared_Lib ("gnarl")); 1175 end if; 1176 end if; 1177 1178 if Libdecgnat_Needed then 1179 Opts.Increment_Last; 1180 Opts.Table (Opts.Last) := 1181 new String'("-L" & Lib_Directory & "/../declib"); 1182 Opts.Increment_Last; 1183 Opts.Table (Opts.Last) := new String'("-ldecgnat"); 1184 end if; 1185 1186 Opts.Increment_Last; 1187 1188 if The_Build_Mode = Static then 1189 Opts.Table (Opts.Last) := new String'("-lgnat"); 1190 else 1191 Opts.Table (Opts.Last) := new String'(Shared_Lib ("gnat")); 1192 end if; 1193 1194 -- If Path Option is supported, add the necessary switch with the 1195 -- content of Rpath. As Rpath contains at least libgnat directory 1196 -- path name, it is guaranteed that it is not null. 1197 1198 if Path_Option /= null then 1199 Opts.Increment_Last; 1200 Opts.Table (Opts.Last) := 1201 new String'(Path_Option.all & Rpath (1 .. Rpath_Last)); 1202 Free (Path_Option); 1203 Free (Rpath); 1204 end if; 1205 1206 Object_Files := 1207 new Argument_List' 1208 (Argument_List (Objects.Table (1 .. Objects.Last))); 1209 1210 Foreign_Objects := 1211 new Argument_List'(Argument_List 1212 (Foreigns.Table (1 .. Foreigns.Last))); 1213 1214 Ali_Files := 1215 new Argument_List'(Argument_List (ALIs.Table (1 .. ALIs.Last))); 1216 1217 Options := 1218 new Argument_List'(Argument_List (Opts.Table (1 .. Opts.Last))); 1219 1220 -- We fail if there are no object to put in the library 1221 -- (Ada or foreign objects). 1222 1223 if Object_Files'Length = 0 then 1224 Com.Fail ("no object files for library """ & 1225 Lib_Filename.all & '"'); 1226 1227 end if; 1228 1229 if not Opt.Quiet_Output then 1230 Write_Eol; 1231 Write_Str ("building "); 1232 Write_Str (Ada.Characters.Handling.To_Lower 1233 (Build_Mode_State'Image (The_Build_Mode))); 1234 Write_Str (" library for project "); 1235 Write_Line (Project_Name); 1236 1237 Write_Eol; 1238 1239 Write_Line ("object files:"); 1240 1241 for Index in Object_Files'Range loop 1242 Write_Str (" "); 1243 Write_Line (Object_Files (Index).all); 1244 end loop; 1245 1246 Write_Eol; 1247 1248 if Ali_Files'Length = 0 then 1249 Write_Line ("NO ALI files"); 1250 1251 else 1252 Write_Line ("ALI files:"); 1253 1254 for Index in Ali_Files'Range loop 1255 Write_Str (" "); 1256 Write_Line (Ali_Files (Index).all); 1257 end loop; 1258 end if; 1259 1260 Write_Eol; 1261 end if; 1262 1263 -- We check that all object files are regular files 1264 1265 Check_Context; 1266 1267 -- Delete the existing library file, if it exists. 1268 -- Fail if the library file is not writable, or if it is not possible 1269 -- to delete the file. 1270 1271 declare 1272 DLL_Name : aliased String := 1273 Lib_Dirpath.all & "/lib" & 1274 Lib_Filename.all & "." & DLL_Ext; 1275 1276 Archive_Name : aliased String := 1277 Lib_Dirpath.all & "/lib" & 1278 Lib_Filename.all & "." & Archive_Ext; 1279 1280 type Str_Ptr is access all String; 1281 -- This type is necessary to meet the accessibility rules of Ada. 1282 -- It is not possible to use String_Access here. 1283 1284 Full_Lib_Name : Str_Ptr; 1285 -- Designates the full library path name. Either DLL_Name or 1286 -- Archive_Name, depending on the library kind. 1287 1288 Success : Boolean := False; 1289 -- Used to call Delete_File 1290 1291 begin 1292 if The_Build_Mode = Static then 1293 Full_Lib_Name := Archive_Name'Access; 1294 else 1295 Full_Lib_Name := DLL_Name'Access; 1296 end if; 1297 1298 if Is_Regular_File (Full_Lib_Name.all) then 1299 if Is_Writable_File (Full_Lib_Name.all) then 1300 Delete_File (Full_Lib_Name.all, Success); 1301 end if; 1302 1303 if Is_Regular_File (Full_Lib_Name.all) then 1304 Com.Fail ("could not delete """ & Full_Lib_Name.all & """"); 1305 end if; 1306 end if; 1307 end; 1308 1309 Argument_Number := 0; 1310 1311 -- If we have a standalone library, gather all the interface ALI. 1312 -- They are passed to Build_Dynamic_Library, where they are used by 1313 -- some platforms (VMS, for example) to decide what symbols should be 1314 -- exported. They are also flagged as Interface when we copy them to 1315 -- the library directory (by Copy_ALI_Files, below). 1316 1317 if Standalone then 1318 Data := Projects.Table (For_Project); 1319 1320 declare 1321 Interface : String_List_Id := Data.Lib_Interface_ALIs; 1322 ALI : File_Name_Type; 1323 1324 begin 1325 while Interface /= Nil_String loop 1326 ALI := String_Elements.Table (Interface).Value; 1327 Interface_ALIs.Set (ALI, True); 1328 Get_Name_String (String_Elements.Table (Interface).Value); 1329 Add_Argument (Name_Buffer (1 .. Name_Len)); 1330 Interface := String_Elements.Table (Interface).Next; 1331 end loop; 1332 1333 Interface := Data.Lib_Interface_ALIs; 1334 1335 if not Opt.Quiet_Output then 1336 1337 -- Check that the interface set is complete: any unit in the 1338 -- library that is needed by an interface should also be an 1339 -- interface. If it is not the case, output a warning. 1340 1341 while Interface /= Nil_String loop 1342 ALI := String_Elements.Table (Interface).Value; 1343 Process (ALI); 1344 Interface := String_Elements.Table (Interface).Next; 1345 end loop; 1346 end if; 1347 end; 1348 end if; 1349 1350 -- Clean the library directory, if it is also the directory where 1351 -- the ALI files are copied, either because there is no interface 1352 -- copy directory or because the interface copy directory is the 1353 -- same as the library directory. 1354 1355 Copy_Dir := Projects.Table (For_Project).Library_Dir; 1356 Clean (Copy_Dir); 1357 1358 -- Call the procedure to build the library, depending on the build 1359 -- mode. 1360 1361 case The_Build_Mode is 1362 when Dynamic | Relocatable => 1363 Build_Dynamic_Library 1364 (Ofiles => Object_Files.all, 1365 Foreign => Foreign_Objects.all, 1366 Afiles => Ali_Files.all, 1367 Options => Options.all, 1368 Interfaces => Arguments (1 .. Argument_Number), 1369 Lib_Filename => Lib_Filename.all, 1370 Lib_Dir => Lib_Dirpath.all, 1371 Symbol_Data => Data.Symbol_Data, 1372 Driver_Name => Driver_Name, 1373 Lib_Address => DLL_Address.all, 1374 Lib_Version => Lib_Version.all, 1375 Relocatable => The_Build_Mode = Relocatable, 1376 Auto_Init => Data.Lib_Auto_Init); 1377 1378 when Static => 1379 MLib.Build_Library 1380 (Object_Files.all, 1381 Ali_Files.all, 1382 Lib_Filename.all, 1383 Lib_Dirpath.all); 1384 1385 when None => 1386 null; 1387 end case; 1388 1389 -- We need to copy the ALI files from the object directory 1390 -- to the library directory, so that the linker find them there, 1391 -- and does not need to look in the object directory where it would 1392 -- also find the object files; and we don't want that: we want the 1393 -- linker to use the library. 1394 1395 -- Copy the ALI files and make the copies read-only. For interfaces, 1396 -- mark the copies as interfaces. 1397 1398 Copy_ALI_Files 1399 (Files => Ali_Files.all, 1400 To => Copy_Dir, 1401 Interfaces => Arguments (1 .. Argument_Number)); 1402 1403 -- Copy interface sources if Library_Src_Dir specified 1404 1405 if Standalone 1406 and then Projects.Table (For_Project).Library_Src_Dir /= No_Name 1407 then 1408 -- Clean the interface copy directory, if it is not also the 1409 -- library directory. If it is also the library directory, it has 1410 -- already been cleaned before the generation of the library. 1411 1412 if Projects.Table (For_Project).Library_Src_Dir /= Copy_Dir then 1413 Copy_Dir := Projects.Table (For_Project).Library_Src_Dir; 1414 Clean (Copy_Dir); 1415 end if; 1416 1417 Copy_Interface_Sources 1418 (For_Project => For_Project, 1419 Interfaces => Arguments (1 .. Argument_Number), 1420 To_Dir => Copy_Dir); 1421 end if; 1422 end if; 1423 1424 -- Reset the current working directory to its previous value 1425 1426 Change_Dir (Current_Dir); 1427 end Build_Library; 1428 1429 ----------- 1430 -- Check -- 1431 ----------- 1432 1433 procedure Check (Filename : String) is 1434 begin 1435 if not Is_Regular_File (Filename) then 1436 Com.Fail (Filename, " not found."); 1437 end if; 1438 end Check; 1439 1440 ------------------- 1441 -- Check_Context -- 1442 ------------------- 1443 1444 procedure Check_Context is 1445 begin 1446 -- check that each object file exists 1447 1448 for F in Object_Files'Range loop 1449 Check (Object_Files (F).all); 1450 end loop; 1451 end Check_Context; 1452 1453 ------------------- 1454 -- Check_Library -- 1455 ------------------- 1456 1457 procedure Check_Library (For_Project : Project_Id) is 1458 Data : constant Project_Data := Projects.Table (For_Project); 1459 1460 begin 1461 if Data.Library and not Data.Flag1 then 1462 declare 1463 Current : constant Dir_Name_Str := Get_Current_Dir; 1464 Lib_Name : constant Name_Id := Library_File_Name_For (For_Project); 1465 Lib_TS : Time_Stamp_Type; 1466 Obj_TS : Time_Stamp_Type; 1467 1468 Object_Dir : Dir_Type; 1469 1470 begin 1471 if Hostparm.OpenVMS then 1472 B_Start (B_Start'Last) := '$'; 1473 end if; 1474 1475 Change_Dir (Get_Name_String (Data.Library_Dir)); 1476 1477 Lib_TS := File_Stamp (Lib_Name); 1478 1479 -- If the library file does not exist, then the time stamp will 1480 -- be Empty_Time_Stamp, earlier than any other time stamp. 1481 1482 Change_Dir (Get_Name_String (Data.Object_Directory)); 1483 Open (Dir => Object_Dir, Dir_Name => "."); 1484 1485 -- For all entries in the object directory 1486 1487 loop 1488 Read (Object_Dir, Name_Buffer, Name_Len); 1489 exit when Name_Len = 0; 1490 1491 -- Check if it is an object file, but ignore any binder 1492 -- generated file. 1493 1494 if Is_Obj (Name_Buffer (1 .. Name_Len)) 1495 and then Name_Buffer (1 .. B_Start'Length) /= B_Start 1496 then 1497 1498 -- Get the object file time stamp 1499 1500 Obj_TS := File_Stamp (Name_Find); 1501 1502 -- If library file time stamp is earlier, set Flag1 and 1503 -- return. String comparaison is used, otherwise time stamps 1504 -- may be too close and the comparaison would return True, 1505 -- which would trigger an unnecessary rebuild of the 1506 -- library. 1507 1508 if String (Lib_TS) < String (Obj_TS) then 1509 1510 -- Library must be rebuilt 1511 1512 Projects.Table (For_Project).Flag1 := True; 1513 exit; 1514 end if; 1515 end if; 1516 end loop; 1517 1518 Change_Dir (Current); 1519 end; 1520 end if; 1521 end Check_Library; 1522 1523 ----------- 1524 -- Clean -- 1525 ----------- 1526 1527 procedure Clean (Directory : Name_Id) is 1528 Current : constant Dir_Name_Str := Get_Current_Dir; 1529 1530 Dir : Dir_Type; 1531 1532 Name : String (1 .. 200); 1533 Last : Natural; 1534 1535 Disregard : Boolean; 1536 1537 procedure Set_Writable (Name : System.Address); 1538 pragma Import (C, Set_Writable, "__gnat_set_writable"); 1539 1540 begin 1541 Get_Name_String (Directory); 1542 1543 -- Change the working directory to the directory to clean 1544 1545 begin 1546 Change_Dir (Name_Buffer (1 .. Name_Len)); 1547 1548 exception 1549 when others => 1550 Com.Fail 1551 ("unable to access directory """, 1552 Name_Buffer (1 .. Name_Len), 1553 """"); 1554 end; 1555 1556 Open (Dir, "."); 1557 1558 -- For each regular file in the directory, make it writable and 1559 -- delete the file. 1560 1561 loop 1562 Read (Dir, Name, Last); 1563 exit when Last = 0; 1564 1565 if Is_Regular_File (Name (1 .. Last)) then 1566 Name (Last + 1) := ASCII.NUL; 1567 Set_Writable (Name (1)'Address); 1568 Delete_File (Name (1 .. Last), Disregard); 1569 end if; 1570 end loop; 1571 1572 Close (Dir); 1573 1574 -- Restore the initial working directory 1575 1576 Change_Dir (Current); 1577 end Clean; 1578 1579 ---------------------------- 1580 -- Copy_Interface_Sources -- 1581 ---------------------------- 1582 1583 procedure Copy_Interface_Sources 1584 (For_Project : Project_Id; 1585 Interfaces : Argument_List; 1586 To_Dir : Name_Id) 1587 is 1588 Current : constant Dir_Name_Str := Get_Current_Dir; 1589 Target : constant Dir_Name_Str := Get_Name_String (To_Dir); 1590 1591 Text : Text_Buffer_Ptr; 1592 The_ALI : ALI.ALI_Id; 1593 Lib_File : Name_Id; 1594 1595 First_Unit : ALI.Unit_Id; 1596 Second_Unit : ALI.Unit_Id; 1597 1598 Data : Unit_Data; 1599 1600 Copy_Subunits : Boolean := False; 1601 1602 procedure Copy (File_Name : Name_Id); 1603 -- Copy one source of the project to the target directory 1604 1605 ---------- 1606 -- Copy -- 1607 ---------- 1608 1609 procedure Copy (File_Name : Name_Id) is 1610 Success : Boolean := False; 1611 1612 begin 1613 Unit_Loop : 1614 for Index in 1 .. Com.Units.Last loop 1615 Data := Com.Units.Table (Index); 1616 1617 for J in Data.File_Names'Range loop 1618 if Data.File_Names (J).Project = For_Project 1619 and then Data.File_Names (J).Name = File_Name 1620 then 1621 Copy_File 1622 (Get_Name_String (Data.File_Names (J).Path), 1623 Target, 1624 Success, 1625 Mode => Overwrite, 1626 Preserve => Preserve); 1627 exit Unit_Loop; 1628 end if; 1629 end loop; 1630 end loop Unit_Loop; 1631 end Copy; 1632 1633 use ALI; 1634 1635 -- Start of processing for Copy_Interface_Sources 1636 1637 begin 1638 -- Change the working directory to the object directory 1639 1640 Change_Dir 1641 (Get_Name_String (Projects.Table (For_Project).Object_Directory)); 1642 1643 for Index in Interfaces'Range loop 1644 1645 -- First, load the ALI file 1646 1647 Name_Len := 0; 1648 Add_Str_To_Name_Buffer (Interfaces (Index).all); 1649 Lib_File := Name_Find; 1650 Text := Read_Library_Info (Lib_File); 1651 The_ALI := Scan_ALI (Lib_File, Text, Ignore_ED => False, Err => True); 1652 Free (Text); 1653 1654 Second_Unit := No_Unit_Id; 1655 First_Unit := ALI.ALIs.Table (The_ALI).First_Unit; 1656 Copy_Subunits := True; 1657 1658 -- If there is both a spec and a body, check if they are both needed 1659 1660 if ALI.Units.Table (First_Unit).Utype = Is_Body then 1661 Second_Unit := ALI.ALIs.Table (The_ALI).Last_Unit; 1662 1663 -- If the body is not needed, then reset First_Unit 1664 1665 if not ALI.Units.Table (Second_Unit).Body_Needed_For_SAL then 1666 First_Unit := No_Unit_Id; 1667 Copy_Subunits := False; 1668 end if; 1669 1670 elsif ALI.Units.Table (First_Unit).Utype = Is_Spec_Only then 1671 Copy_Subunits := False; 1672 end if; 1673 1674 -- Copy the file(s) that need to be copied 1675 1676 if First_Unit /= No_Unit_Id then 1677 Copy (File_Name => ALI.Units.Table (First_Unit).Sfile); 1678 end if; 1679 1680 if Second_Unit /= No_Unit_Id then 1681 Copy (File_Name => ALI.Units.Table (Second_Unit).Sfile); 1682 end if; 1683 1684 -- Copy all the separates, if any 1685 1686 if Copy_Subunits then 1687 for Dep in ALI.ALIs.Table (The_ALI).First_Sdep .. 1688 ALI.ALIs.Table (The_ALI).Last_Sdep 1689 loop 1690 if Sdep.Table (Dep).Subunit_Name /= No_Name then 1691 Copy (File_Name => Sdep.Table (Dep).Sfile); 1692 end if; 1693 end loop; 1694 end if; 1695 end loop; 1696 1697 -- Restore the initial working directory 1698 1699 Change_Dir (Current); 1700 end Copy_Interface_Sources; 1701 1702 ------------- 1703 -- Display -- 1704 ------------- 1705 1706 procedure Display (Executable : String) is 1707 begin 1708 if not Opt.Quiet_Output then 1709 Write_Str (Executable); 1710 1711 for Index in 1 .. Argument_Number loop 1712 Write_Char (' '); 1713 Write_Str (Arguments (Index).all); 1714 end loop; 1715 1716 Write_Eol; 1717 end if; 1718 end Display; 1719 1720 ------------------------- 1721 -- Process_Binder_File -- 1722 ------------------------- 1723 1724 procedure Process_Binder_File (Name : String) is 1725 Fd : FILEs; 1726 -- Binder file's descriptor 1727 1728 Read_Mode : constant String := "r" & ASCII.Nul; 1729 -- For fopen 1730 1731 Status : Interfaces.C_Streams.int; 1732 pragma Unreferenced (Status); 1733 -- For fclose 1734 1735 Begin_Info : constant String := "-- BEGIN Object file/option list"; 1736 End_Info : constant String := "-- END Object file/option list "; 1737 1738 Next_Line : String (1 .. 1000); 1739 -- Current line value 1740 -- Where does this odd constant 1000 come from, looks suspicious ??? 1741 1742 Nlast : Integer; 1743 -- End of line slice (the slice does not contain the line terminator) 1744 1745 procedure Get_Next_Line; 1746 -- Read the next line from the binder file without the line terminator 1747 1748 ------------------- 1749 -- Get_Next_Line -- 1750 ------------------- 1751 1752 procedure Get_Next_Line is 1753 Fchars : chars; 1754 1755 begin 1756 Fchars := fgets (Next_Line'Address, Next_Line'Length, Fd); 1757 1758 if Fchars = System.Null_Address then 1759 Fail ("Error reading binder output"); 1760 end if; 1761 1762 Nlast := 1; 1763 while Nlast <= Next_Line'Last 1764 and then Next_Line (Nlast) /= ASCII.LF 1765 and then Next_Line (Nlast) /= ASCII.CR 1766 loop 1767 Nlast := Nlast + 1; 1768 end loop; 1769 1770 Nlast := Nlast - 1; 1771 end Get_Next_Line; 1772 1773 -- Start of processing for Process_Binder_File 1774 1775 begin 1776 Fd := fopen (Name'Address, Read_Mode'Address); 1777 1778 if Fd = NULL_Stream then 1779 Fail ("Failed to open binder output"); 1780 end if; 1781 1782 -- Skip up to the Begin Info line 1783 1784 loop 1785 Get_Next_Line; 1786 exit when Next_Line (1 .. Nlast) = Begin_Info; 1787 end loop; 1788 1789 -- Find the first switch 1790 1791 loop 1792 Get_Next_Line; 1793 1794 exit when Next_Line (1 .. Nlast) = End_Info; 1795 1796 -- As the binder generated file is in Ada, remove the first eight 1797 -- characters " -- ". 1798 1799 Next_Line (1 .. Nlast - 8) := Next_Line (9 .. Nlast); 1800 Nlast := Nlast - 8; 1801 1802 -- Stop when the first switch is found 1803 1804 exit when Next_Line (1) = '-'; 1805 end loop; 1806 1807 if Next_Line (1 .. Nlast) /= End_Info then 1808 loop 1809 -- Ignore -static and -shared, since -shared will be used 1810 -- in any case. 1811 1812 -- Ignore -lgnat, -lgnarl and -ldecgnat as they will be added 1813 -- later, because they are also needed for non Stand-Alone shared 1814 -- libraries. 1815 1816 -- Also ignore the shared libraries which are : 1817 1818 -- UNIX / Windows VMS 1819 -- -lgnat-<version> -lgnat_<version> (7 + version'length chars) 1820 -- -lgnarl-<version> -lgnarl_<version> (8 + version'length chars) 1821 1822 if Next_Line (1 .. Nlast) /= "-static" and then 1823 Next_Line (1 .. Nlast) /= "-shared" and then 1824 Next_Line (1 .. Nlast) /= "-ldecgnat" and then 1825 Next_Line (1 .. Nlast) /= "-lgnarl" and then 1826 Next_Line (1 .. Nlast) /= "-lgnat" and then 1827 Next_Line 1828 (1 .. Natural'Min (Nlast, 8 + Library_Version'Length)) /= 1829 Shared_Lib ("gnarl") and then 1830 Next_Line 1831 (1 .. Natural'Min (Nlast, 7 + Library_Version'Length)) /= 1832 Shared_Lib ("gnat") 1833 then 1834 if Next_Line (1) /= '-' then 1835 1836 -- This is not an option, should we add it? 1837 1838 if Add_Object_Files then 1839 Opts.Increment_Last; 1840 Opts.Table (Opts.Last) := 1841 new String'(Next_Line (1 .. Nlast)); 1842 end if; 1843 1844 else 1845 -- Add all other options 1846 1847 Opts.Increment_Last; 1848 Opts.Table (Opts.Last) := 1849 new String'(Next_Line (1 .. Nlast)); 1850 end if; 1851 end if; 1852 1853 -- Next option, if any 1854 1855 Get_Next_Line; 1856 exit when Next_Line (1 .. Nlast) = End_Info; 1857 1858 -- Remove first eight characters " -- " 1859 1860 Next_Line (1 .. Nlast - 8) := Next_Line (9 .. Nlast); 1861 Nlast := Nlast - 8; 1862 end loop; 1863 end if; 1864 1865 Status := fclose (Fd); 1866 -- Is it really right to ignore any close error ??? 1867 end Process_Binder_File; 1868 1869 ------------------ 1870 -- Reset_Tables -- 1871 ------------------ 1872 1873 procedure Reset_Tables is 1874 begin 1875 Objects.Init; 1876 Objects_Htable.Reset; 1877 Foreigns.Init; 1878 ALIs.Init; 1879 Opts.Init; 1880 Processed_Projects.Reset; 1881 Library_Projs.Init; 1882 end Reset_Tables; 1883 1884end MLib.Prj; 1885