1------------------------------------------------------------------------------ 2-- -- 3-- GPR TECHNOLOGY -- 4-- -- 5-- Copyright (C) 2007-2016, AdaCore -- 6-- -- 7-- This is free software; you can redistribute it and/or modify it under -- 8-- terms of the GNU General Public License as published by the Free Soft- -- 9-- ware Foundation; either version 3, or (at your option) any later ver- -- 10-- sion. This software is distributed in the hope that it will be useful, -- 11-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- 12-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public -- 13-- License for more details. You should have received a copy of the GNU -- 14-- General Public License distributed with GNAT; see file COPYING. If not, -- 15-- see <http://www.gnu.org/licenses/>. -- 16-- -- 17------------------------------------------------------------------------------ 18 19with Ada.Containers.Indefinite_Ordered_Sets; 20with Ada.Calendar.Time_Zones; use Ada.Calendar; use Ada.Calendar.Time_Zones; 21with Ada.Command_Line; use Ada.Command_Line; 22with Ada.Directories; use Ada.Directories; 23with Ada.Environment_Variables; use Ada.Environment_Variables; 24with Ada.Streams.Stream_IO; use Ada.Streams; 25with Ada.Strings.Fixed; use Ada.Strings.Fixed; 26with Ada.Strings.Unbounded; 27with Ada.Text_IO; use Ada.Text_IO; 28 29with GNAT.Calendar.Time_IO; use GNAT.Calendar.Time_IO; 30with GNAT.Case_Util; use GNAT.Case_Util; 31with GNAT.Directory_Operations; use GNAT.Directory_Operations; 32with GNAT.Dynamic_HTables; use GNAT.Dynamic_HTables; 33with GNAT.Sockets; 34with GNAT.Table; 35with GNAT.Regpat; use GNAT.Regpat; 36 37with Interfaces.C.Strings; 38with System; 39 40with Gpr_Build_Util; use Gpr_Build_Util; 41with GprConfig.Sdefault; 42with GPR_Version; use GPR_Version; 43with GPR.ALI; use GPR.ALI; 44with GPR.Com; 45with GPR.Debug; 46with GPR.Opt; use GPR.Opt; 47with GPR.Osint; use GPR.Osint; 48with GPR.Conf; 49with GPR.Env; 50with GPR.Err; 51with GPR.Names; use GPR.Names; 52with GPR.Scans; 53with GPR.Sinput; 54with GPR.Tempdir; 55with GPR.Util; use GPR.Util; 56 57package body Gpr_Util is 58 59 use GPR.Stamps; 60 61 Libgcc_Subdir_Ptr : Interfaces.C.Strings.chars_ptr; 62 pragma Import (C, Libgcc_Subdir_Ptr, "__gnat_default_libgcc_subdir"); 63 -- Pointer to string indicating the installation subdirectory where a 64 -- default shared libgcc might be found. 65 66 GNU_Header : aliased constant String := "INPUT ("; 67 GNU_Opening : aliased constant String := """"; 68 GNU_Closing : aliased constant String := '"' & ASCII.LF; 69 GNU_Footer : aliased constant String := ')' & ASCII.LF; 70 71 package Project_Name_Boolean_Htable is new Simple_HTable 72 (Header_Num => Header_Num, 73 Element => Boolean, 74 No_Element => False, 75 Key => Name_Id, 76 Hash => Hash, 77 Equal => "="); 78 79 Project_Failure : Project_Name_Boolean_Htable.Instance := 80 Project_Name_Boolean_Htable.Nil; 81 -- Record a boolean for project having failed to compile cleanly 82 83 ------------------------------- 84 -- Binder_Exchange_File_Name -- 85 ------------------------------- 86 87 function Binder_Exchange_File_Name 88 (Main_Base_Name : File_Name_Type; Prefix : Name_Id) return String_Access 89 is 90 File_Name : constant String := Get_Name_String (Main_Base_Name); 91 begin 92 Get_Name_String (Prefix); 93 Add_Str_To_Name_Buffer (File_Name); 94 Add_Str_To_Name_Buffer (Binder_Exchange_Suffix); 95 return new String'(Name_Buffer (1 .. Name_Len)); 96 end Binder_Exchange_File_Name; 97 98 ----------------------- 99 -- Compute_Slave_Env -- 100 ----------------------- 101 102 function Compute_Slave_Env 103 (Project : Project_Tree_Ref; Auto : Boolean) return String 104 is 105 User : String_Access := Getenv ("USER"); 106 User_Name : String_Access := Getenv ("USERNAME"); 107 Default : constant String := 108 (if User = null 109 then (if User_Name = null 110 then "unknown" else User_Name.all) 111 else User.all) 112 & '@' & GNAT.Sockets.Host_Name; 113 114 package S_Set is new Containers.Indefinite_Ordered_Sets (String); 115 116 Set : S_Set.Set; 117 Ctx : Context; 118 119 begin 120 Free (User); 121 Free (User_Name); 122 123 if Auto then 124 -- In this mode the slave environment is computed based on 125 -- the project variable value and the command line arguments. 126 127 -- First adds all command line arguments 128 129 for K in 1 .. Argument_Count loop 130 -- Skip arguments that are not changing the actual compilation and 131 -- this will ensure that the same environment will be created for 132 -- gprclean. 133 134 if Argument (K) not in "-p" | "-d" | "-c" | "-q" 135 and then 136 (Argument (K)'Length < 2 137 or else Argument (K) (1 .. 2) /= "-j") 138 then 139 Set.Insert (Argument (K)); 140 end if; 141 end loop; 142 143 -- Then all the global variables for the project tree 144 145 for K in 146 1 .. Variable_Element_Table.Last (Project.Shared.Variable_Elements) 147 loop 148 declare 149 V : constant Variable := 150 Project.Shared.Variable_Elements.Table (K); 151 begin 152 if V.Value.Kind = Single then 153 Set.Include 154 (Get_Name_String (V.Name) 155 & "=" & Get_Name_String (V.Value.Value)); 156 end if; 157 end; 158 end loop; 159 160 -- Compute the MD5 sum of the sorted elements in the set 161 162 for S of Set loop 163 Update (Ctx, S); 164 end loop; 165 166 return Default & "-" & Digest (Ctx); 167 168 else 169 -- Otherwise use the default <user_name> & '@' & <host_name> 170 return Default; 171 end if; 172 end Compute_Slave_Env; 173 174 ------------------------------ 175 -- Check_Version_And_Help_G -- 176 ------------------------------ 177 178 -- Common switches for GNU tools 179 180 Version_Switch : constant String := "--version"; 181 Help_Switch : constant String := "--help"; 182 183 procedure Check_Version_And_Help_G 184 (Tool_Name : String; 185 Initial_Year : String; 186 Version_String : String) 187 is 188 Version_Switch_Present : Boolean := False; 189 Help_Switch_Present : Boolean := False; 190 Next_Arg : Natural; 191 192 begin 193 -- First check for --version or --help 194 195 Next_Arg := 1; 196 while Next_Arg <= Argument_Count loop 197 declare 198 Next_Argv : constant String := Argument (Next_Arg); 199 begin 200 if Next_Argv = Version_Switch then 201 Version_Switch_Present := True; 202 203 elsif Next_Argv = Help_Switch then 204 Help_Switch_Present := True; 205 end if; 206 207 Next_Arg := Next_Arg + 1; 208 end; 209 end loop; 210 211 -- If --version was used, display version and exit 212 213 if Version_Switch_Present then 214 Display_Version (Tool_Name, Initial_Year, Version_String); 215 216 Put_Line (Free_Software); 217 New_Line; 218 219 OS_Exit (0); 220 end if; 221 222 -- If --help was used, display help and exit 223 224 if Help_Switch_Present then 225 Usage; 226 New_Line; 227 Put_Line ("Report bugs to report@adacore.com"); 228 OS_Exit (0); 229 end if; 230 end Check_Version_And_Help_G; 231 232 -------------------------------- 233 -- Create_Export_Symbols_File -- 234 -------------------------------- 235 236 procedure Create_Export_Symbols_File 237 (Driver_Path : String; 238 Options : Argument_List; 239 Sym_Matcher : String; 240 Format : Export_File_Format; 241 Objects : String_List; 242 Library_Symbol_File : String; 243 Export_File_Name : out Path_Name_Type) 244 is 245 use type Containers.Count_Type; 246 247 package Syms_List is new Containers.Indefinite_Ordered_Sets (String); 248 249 procedure Get_Syms (Object_File : String); 250 -- Read exported symbols from Object_File and add them into Syms 251 252 procedure Write (Str : String); 253 -- Write Str into the export file 254 255 Pattern : constant Pattern_Matcher := Compile (Sym_Matcher); 256 257 Syms : Syms_List.Set; 258 FD : File_Descriptor; 259 260 -------------- 261 -- Get_Syms -- 262 -------------- 263 264 procedure Get_Syms (Object_File : String) is 265 Success : Boolean; 266 Ret : Integer; 267 Opts : Argument_List (1 .. Options'Length + 1); 268 File : File_Type; 269 Buffer : String (1 .. 512); 270 Last : Natural; 271 File_Name : Temp_File_Name; 272 Matches : Match_Array (0 .. 1); 273 274 function Filename return String 275 is (File_Name (File_Name'First .. File_Name'Last - 1)); 276 -- Remove the ASCII.NUL from end of temporary file-name 277 278 begin 279 Opts (1 .. Options'Length) := Options; 280 Opts (Opts'Last) := new String'(Object_File); 281 282 Create_Temp_File (FD, File_Name); 283 Close (FD); 284 285 if Verbose_Mode then 286 Put (Driver_Path); 287 for O of Opts loop 288 Put (' '); 289 Put (O.all); 290 end loop; 291 New_Line; 292 end if; 293 294 Spawn (Driver_Path, Opts, Filename, Success, Ret); 295 296 if Success then 297 Open (File, In_File, Filename); 298 299 while not End_Of_File (File) loop 300 Get_Line (File, Buffer, Last); 301 302 Match (Pattern, Buffer (1 .. Last), Matches); 303 304 if Matches (1) /= No_Match then 305 Syms.Include 306 (Buffer (Matches (1).First .. Matches (1).Last)); 307 end if; 308 end loop; 309 310 Close (File); 311 end if; 312 313 Delete_File (Filename); 314 315 Free (Opts (Opts'Last)); 316 end Get_Syms; 317 318 ----------- 319 -- Write -- 320 ----------- 321 322 procedure Write (Str : String) is 323 S : constant String := Str & ASCII.LF; 324 R : Integer with Unreferenced; 325 begin 326 R := Write (FD, S (S'First)'Address, S'Length); 327 end Write; 328 329 begin 330 Export_File_Name := No_Path; 331 332 if Format = None then 333 return; 334 end if; 335 336 if Library_Symbol_File = "" then 337 -- Get the exported symbols from every object files, first get the nm 338 -- tool for the target. 339 340 for K in Objects'Range loop 341 Get_Syms (Objects (K).all); 342 end loop; 343 344 else 345 -- Get the symbols from the symbol file, one symbol per line 346 347 if Is_Readable_File (Library_Symbol_File) then 348 declare 349 File : File_Type; 350 Line : String (1 .. 1_024); 351 Last : Natural; 352 begin 353 Open (File, In_File, Library_Symbol_File); 354 355 while not End_Of_File (File) loop 356 Get_Line (File, Line, Last); 357 358 if Last > 0 then 359 Syms.Include (Line (1 .. Last)); 360 end if; 361 end loop; 362 363 Close (File); 364 end; 365 366 else 367 raise Constraint_Error 368 with "unable to locate Library_Symbol_File""" 369 & Library_Symbol_File & '"'; 370 end if; 371 end if; 372 373 if Syms.Length = 0 then 374 return; 375 end if; 376 377 -- Now create the export file, either GNU or DEF format 378 379 Create_Export_File : declare 380 File_Name : Temp_File_Name; 381 begin 382 -- Create (Export_File, Out_File); 383 384 Create_Temp_File (FD, File_Name); 385 386 Name_Len := File_Name'Length; 387 Name_Buffer (1 .. Name_Len) := File_Name; 388 389 -- Always add .def at the end, this is needed for Windows 390 391 Name_Buffer (Name_Len .. Name_Len + 3) := ".def"; 392 Name_Len := Name_Len + 3; 393 Export_File_Name := Name_Find; 394 395 -- Header 396 397 case Format is 398 when GNU => 399 Write ("SYMS {"); 400 Write (" global:"); 401 402 when Def => 403 Write ("EXPORTS"); 404 405 when None | Flat => 406 null; 407 end case; 408 409 -- Symbols 410 411 for Sym of Syms loop 412 case Format is 413 when GNU => 414 Write (Sym & ";"); 415 416 when Def | Flat => 417 Write (Sym); 418 419 when None => 420 null; 421 end case; 422 end loop; 423 424 -- Footer 425 426 case Format is 427 when GNU => 428 Write (" local: *;"); 429 Write ("};"); 430 431 when None | Def | Flat => 432 null; 433 end case; 434 435 Close (FD); 436 437 Rename_File (File_Name, Get_Name_String (Export_File_Name), Success); 438 end Create_Export_File; 439 end Create_Export_Symbols_File; 440 441 -------------------------- 442 -- Create_Response_File -- 443 -------------------------- 444 445 procedure Create_Response_File 446 (Format : Response_File_Format; 447 Objects : String_List; 448 Other_Arguments : String_List; 449 Resp_File_Options : String_List; 450 Name_1 : out Path_Name_Type; 451 Name_2 : out Path_Name_Type) 452 is 453 Resp_File : File_Descriptor; 454 Status : Integer; 455 pragma Warnings (Off, Status); 456 Closing_Status : Boolean; 457 pragma Warnings (Off, Closing_Status); 458 459 function Modified_Argument (Arg : String) return String; 460 -- If the argument includes a space, a backslash, or a double quote, 461 -- escape the character with a preceding backsash. 462 463 ----------------------- 464 -- Modified_Argument -- 465 ----------------------- 466 467 function Modified_Argument (Arg : String) return String is 468 Result : String (1 .. 2 * Arg'Length); 469 Last : Natural := 0; 470 471 procedure Add (C : Character); 472 473 --------- 474 -- Add -- 475 --------- 476 477 procedure Add (C : Character) is 478 begin 479 Last := Last + 1; 480 Result (Last) := C; 481 end Add; 482 483 begin 484 for J in Arg'Range loop 485 if Arg (J) = '\' or else Arg (J) = ' ' or else Arg (J) = '"' then 486 Add ('\'); 487 end if; 488 489 Add (Arg (J)); 490 end loop; 491 492 return Result (1 .. Last); 493 end Modified_Argument; 494 495 begin 496 Name_2 := No_Path; 497 Tempdir.Create_Temp_File (Resp_File, Name => Name_1); 498 499 if Format = GNU or else Format = GCC_GNU then 500 Status := Write (Resp_File, GNU_Header'Address, GNU_Header'Length); 501 end if; 502 503 for J in Objects'Range loop 504 if Format = GNU or else Format = GCC_GNU then 505 Status := 506 Write (Resp_File, GNU_Opening'Address, GNU_Opening'Length); 507 end if; 508 509 Status := 510 Write (Resp_File, Objects (J).all'Address, Objects (J)'Length); 511 512 if Format = GNU or else Format = GCC_GNU then 513 Status := 514 Write (Resp_File, GNU_Closing'Address, GNU_Closing'Length); 515 516 else 517 Status := 518 Write (Resp_File, ASCII.LF'Address, 1); 519 end if; 520 end loop; 521 522 if Format = GNU or else Format = GCC_GNU then 523 Status := Write (Resp_File, GNU_Footer'Address, GNU_Footer'Length); 524 end if; 525 526 case Format is 527 when GCC_GNU | GCC_Object_List | GCC_Option_List => 528 Close (Resp_File, Closing_Status); 529 Name_2 := Name_1; 530 Tempdir.Create_Temp_File (Resp_File, Name => Name_1); 531 532 declare 533 Arg : constant String := 534 Modified_Argument (Get_Name_String (Name_2)); 535 536 begin 537 for J in Resp_File_Options'Range loop 538 Status := 539 Write 540 (Resp_File, 541 Resp_File_Options (J) (1)'Address, 542 Resp_File_Options (J)'Length); 543 544 if J < Resp_File_Options'Last then 545 Status := Write (Resp_File, ASCII.LF'Address, 1); 546 end if; 547 end loop; 548 549 Status := Write (Resp_File, Arg (1)'Address, Arg'Length); 550 end; 551 552 Status := Write (Resp_File, ASCII.LF'Address, 1); 553 554 when GCC => 555 null; 556 557 when others => 558 Close (Resp_File, Closing_Status); 559 end case; 560 561 if Format = GCC 562 or else Format = GCC_GNU 563 or else Format = GCC_Object_List 564 or else Format = GCC_Option_List 565 then 566 for J in Other_Arguments'Range loop 567 declare 568 Arg : constant String := 569 Modified_Argument (Other_Arguments (J).all); 570 571 begin 572 Status := Write (Resp_File, Arg (1)'Address, Arg'Length); 573 end; 574 575 Status := Write (Resp_File, ASCII.LF'Address, 1); 576 end loop; 577 578 Close (Resp_File, Closing_Status); 579 end if; 580 end Create_Response_File; 581 582 --------------------- 583 -- Create_Sym_Link -- 584 --------------------- 585 586 procedure Create_Sym_Link (From, To : String) is 587 588 function Symlink 589 (Oldpath : System.Address; 590 Newpath : System.Address) return Integer; 591 pragma Import (C, Symlink, "__gnat_symlink"); 592 593 C_From : constant String := From & ASCII.NUL; 594 C_To : constant String := 595 Relative_Path 596 (Containing_Directory (To), Containing_Directory (From)) 597 & Ada.Directories.Simple_Name (To) & ASCII.NUL; 598 Result : Integer; 599 Success : Boolean; 600 pragma Unreferenced (Success, Result); 601 602 begin 603 Delete_File (From, Success); 604 Result := Symlink (C_To'Address, C_From'Address); 605 end Create_Sym_Link; 606 607 ---------------------- 608 -- Create_Sym_Links -- 609 ---------------------- 610 611 procedure Create_Sym_Links 612 (Lib_Path : String; 613 Lib_Version : String; 614 Lib_Dir : String; 615 Maj_Version : String) 616 is 617 function Symlink 618 (Oldpath : System.Address; 619 Newpath : System.Address) return Integer; 620 pragma Import (C, Symlink, "__gnat_symlink"); 621 622 Version_Path : String_Access; 623 624 Success : Boolean; 625 Result : Integer; 626 pragma Unreferenced (Success, Result); 627 628 begin 629 Version_Path := new String (1 .. Lib_Version'Length + 1); 630 Version_Path (1 .. Lib_Version'Length) := Lib_Version; 631 Version_Path (Version_Path'Last) := ASCII.NUL; 632 633 if Maj_Version'Length = 0 then 634 declare 635 Newpath : String (1 .. Lib_Path'Length + 1); 636 begin 637 Newpath (1 .. Lib_Path'Length) := Lib_Path; 638 Newpath (Newpath'Last) := ASCII.NUL; 639 Delete_File (Lib_Path, Success); 640 Result := Symlink (Version_Path (1)'Address, Newpath'Address); 641 end; 642 643 else 644 declare 645 Newpath1 : String (1 .. Lib_Path'Length + 1); 646 Maj_Path : constant String := 647 Lib_Dir & Directory_Separator & Maj_Version; 648 Newpath2 : String (1 .. Maj_Path'Length + 1); 649 Maj_Ver : String (1 .. Maj_Version'Length + 1); 650 651 begin 652 Newpath1 (1 .. Lib_Path'Length) := Lib_Path; 653 Newpath1 (Newpath1'Last) := ASCII.NUL; 654 655 Newpath2 (1 .. Maj_Path'Length) := Maj_Path; 656 Newpath2 (Newpath2'Last) := ASCII.NUL; 657 658 Maj_Ver (1 .. Maj_Version'Length) := Maj_Version; 659 Maj_Ver (Maj_Ver'Last) := ASCII.NUL; 660 661 Delete_File (Maj_Path, Success); 662 663 Result := Symlink (Version_Path (1)'Address, Newpath2'Address); 664 665 Delete_File (Lib_Path, Success); 666 667 Result := Symlink (Maj_Ver'Address, Newpath1'Address); 668 end; 669 end if; 670 end Create_Sym_Links; 671 672 ------------------------------------ 673 -- Display_Usage_Version_And_Help -- 674 ------------------------------------ 675 676 procedure Display_Usage_Version_And_Help is 677 begin 678 Put_Line (" --version Display version and exit"); 679 Put_Line (" --help Display usage and exit"); 680 New_Line; 681 end Display_Usage_Version_And_Help; 682 683 --------------------- 684 -- Display_Version -- 685 --------------------- 686 687 procedure Display_Version 688 (Tool_Name : String; 689 Initial_Year : String; 690 Version_String : String) 691 is 692 begin 693 Put_Line (Tool_Name & " " & Version_String); 694 695 Put ("Copyright (C) "); 696 Put (Initial_Year); 697 Put ('-'); 698 Put (Current_Year); 699 Put (", "); 700 Put (Copyright_Holder); 701 New_Line; 702 end Display_Version; 703 ---------------------- 704 -- Ensure_Directory -- 705 ---------------------- 706 707 function Ensure_Directory (Path : String) return String is 708 begin 709 if Path'Length = 0 710 or else Path (Path'Last) = Directory_Separator 711 or else Path (Path'Last) = '/' -- on Windows check also for / 712 then 713 return Path; 714 else 715 return Path & Directory_Separator; 716 end if; 717 end Ensure_Directory; 718 719-- --------------- 720-- -- Error_Msg -- 721-- --------------- 722-- 723-- procedure Error_Msg (Msg : String; Flag_Location : Source_Ptr) is 724-- pragma Warnings (Off, Msg); 725-- pragma Warnings (Off, Flag_Location); 726-- begin 727-- null; 728-- end Error_Msg; 729-- 730-- ----------------- 731-- -- Error_Msg_S -- 732-- ----------------- 733-- 734-- procedure Error_Msg_S (Msg : String) is 735-- pragma Warnings (Off, Msg); 736-- begin 737-- null; 738-- end Error_Msg_S; 739-- 740-- ------------------ 741-- -- Error_Msg_SC -- 742-- ------------------ 743-- 744-- procedure Error_Msg_SC (Msg : String) is 745-- pragma Warnings (Off, Msg); 746-- begin 747-- null; 748-- end Error_Msg_SC; 749-- 750-- ------------------ 751-- -- Error_Msg_SP -- 752-- ------------------ 753-- 754-- procedure Error_Msg_SP (Msg : String) is 755-- pragma Warnings (Off, Msg); 756-- begin 757-- null; 758-- end Error_Msg_SP; 759 760 -------------- 761 -- File_MD5 -- 762 -------------- 763 764 function File_MD5 (Pathname : String) return Message_Digest is 765 use Stream_IO; 766 767 C : Context; 768 S : Stream_IO.File_Type; 769 B : Stream_Element_Array (1 .. 100 * 1024); 770 -- Buffer to read chunk of data 771 L : Stream_Element_Offset; 772 begin 773 Open (S, In_File, Pathname); 774 775 while not End_Of_File (S) loop 776 Read (S, B, L); 777 Update (C, B (1 .. L)); 778 end loop; 779 780 Close (S); 781 782 return Digest (C); 783 end File_MD5; 784 785 ------------------------------ 786 -- Get_Compiler_Driver_Path -- 787 ------------------------------ 788 789 function Get_Compiler_Driver_Path 790 (Project_Tree : Project_Tree_Ref; 791 Lang : Language_Ptr) return String_Access 792 is 793 pragma Unreferenced (Project_Tree); 794 begin 795 if Lang.Config.Compiler_Driver_Path = null then 796 declare 797 Compiler : Name_Id := Compiler_Subst_HTable.Get (Lang.Name); 798 begin 799 -- If --compiler-subst was used to specify an alternate compiler, 800 -- then Compiler /= No_Name. In the usual case, Compiler = 801 -- No_Name, so we set Compiler to the Compiler_Driver from the 802 -- config file. 803 804 if Compiler = No_Name then 805 Compiler := Name_Id (Lang.Config.Compiler_Driver); 806 end if; 807 808 -- No compiler found, return now 809 810 if Compiler = No_Name then 811 return null; 812 end if; 813 814 declare 815 Compiler_Name : constant String := Get_Name_String (Compiler); 816 begin 817 if Compiler_Name = "" then 818 return null; 819 end if; 820 821 Lang.Config.Compiler_Driver_Path := 822 Locate_Exec_On_Path (Compiler_Name); 823 824 if Lang.Config.Compiler_Driver_Path = null then 825 raise Constraint_Error 826 with "unable to locate """ & Compiler_Name & '"'; 827 end if; 828 end; 829 end; 830 end if; 831 832 return Lang.Config.Compiler_Driver_Path; 833 end Get_Compiler_Driver_Path; 834 835 ---------------------- 836 -- Get_Slaves_Hosts -- 837 ---------------------- 838 839 function Get_Slaves_Hosts 840 (Project_Tree : Project_Tree_Ref; 841 Arg : String) return String 842 is 843 use Ada.Strings.Unbounded; 844 Hosts : Unbounded_String; 845 begin 846 if Arg'Length > Distributed_Option'Length 847 and then Arg (Arg'First + Distributed_Option'Length) = '=' 848 then 849 -- The hosts are specified on the command-line 850 Hosts := To_Unbounded_String 851 (Arg (Arg'First + Distributed_Option'Length + 1 .. Arg'Last)); 852 853 elsif Environment_Variables.Exists ("GPR_SLAVES") then 854 Hosts := To_Unbounded_String (Value ("GPR_SLAVES")); 855 856 elsif Environment_Variables.Exists ("GPR_SLAVES_FILE") then 857 declare 858 F_Name : constant String := Value ("GPR_SLAVES_FILE"); 859 F : Text_IO.File_Type; 860 Buffer : String (1 .. 100); 861 Last : Natural; 862 begin 863 if Ada.Directories.Exists (F_Name) then 864 Open (F, In_File, F_Name); 865 866 while not Text_IO.End_Of_File (F) loop 867 Text_IO.Get_Line (F, Buffer, Last); 868 869 if Last > 0 then 870 if Hosts /= Null_Unbounded_String then 871 Append (Hosts, ","); 872 end if; 873 Append (Hosts, Buffer (1 .. Last)); 874 end if; 875 end loop; 876 877 Text_IO.Close (F); 878 879 else 880 Fail_Program 881 (Project_Tree, 882 "hosts distributed file " & F_Name & " not found"); 883 end if; 884 end; 885 end if; 886 887 return To_String (Hosts); 888 end Get_Slaves_Hosts; 889 890 ---------------------------- 891 -- Find_Binding_Languages -- 892 ---------------------------- 893 894 procedure Find_Binding_Languages 895 (Tree : Project_Tree_Ref; 896 Root_Project : Project_Id) 897 is 898 Data : constant Builder_Data_Access := Builder_Data (Tree); 899 B_Index : Binding_Data; 900 901 Language_Name : Name_Id; 902 Binder_Driver_Name : File_Name_Type := No_File; 903 Binder_Driver_Path : String_Access; 904 Binder_Prefix : Name_Id; 905 Language : Language_Ptr; 906 907 Config : Language_Config; 908 Project : Project_List; 909 910 begin 911 -- Have we already processed this tree ? 912 913 if Data.There_Are_Binder_Drivers 914 and then Data.Binding /= null 915 then 916 return; 917 end if; 918 919 if Current_Verbosity = High then 920 Debug_Output ("Find_Binding_Languages for", Debug_Name (Tree)); 921 end if; 922 923 Data.There_Are_Binder_Drivers := False; 924 925 Project := Tree.Projects; 926 while Project /= null loop 927 Language := Project.Project.Languages; 928 929 while Language /= No_Language_Index loop 930 Config := Language.Config; 931 932 Binder_Driver_Name := Config.Binder_Driver; 933 934 if Language.First_Source /= No_Source 935 and then Binder_Driver_Name /= No_File 936 then 937 Data.There_Are_Binder_Drivers := True; 938 Language_Name := Language.Name; 939 940 B_Index := Data.Binding; 941 while B_Index /= null 942 and then B_Index.Language_Name /= Language_Name 943 loop 944 B_Index := B_Index.Next; 945 end loop; 946 947 if B_Index = null then 948 Get_Name_String (Binder_Driver_Name); 949 Binder_Driver_Path := 950 Locate_Exec_On_Path (Name_Buffer (1 .. Name_Len)); 951 952 if Binder_Driver_Path = null then 953 Fail_Program 954 (Tree, 955 "unable to find binder driver " & 956 Name_Buffer (1 .. Name_Len)); 957 end if; 958 959 if Current_Verbosity = High then 960 Debug_Output 961 ("Binder_Driver=" & Binder_Driver_Path.all 962 & " for Lang", Language_Name); 963 end if; 964 965 if Config.Binder_Prefix = No_Name then 966 Binder_Prefix := Empty_String; 967 else 968 Binder_Prefix := Config.Binder_Prefix; 969 end if; 970 971 B_Index := Data.Binding; 972 while B_Index /= null loop 973 if Binder_Prefix = B_Index.Binder_Prefix then 974 Fail_Program 975 (Tree, 976 "binding prefix cannot be the same for" 977 & " two languages"); 978 end if; 979 B_Index := B_Index.Next; 980 end loop; 981 982 Data.Binding := new Binding_Data_Record' 983 (Language => Language, 984 Language_Name => Language_Name, 985 Binder_Driver_Name => Binder_Driver_Name, 986 Binder_Driver_Path => Binder_Driver_Path, 987 Binder_Prefix => Binder_Prefix, 988 Next => Data.Binding); 989 end if; 990 end if; 991 992 Language := Language.Next; 993 end loop; 994 995 Project := Project.Next; 996 end loop; 997 998 if Root_Project.Qualifier = Aggregate then 999 declare 1000 Agg : Aggregated_Project_List := Root_Project.Aggregated_Projects; 1001 begin 1002 while Agg /= null loop 1003 Find_Binding_Languages (Agg.Tree, Agg.Project); 1004 Agg := Agg.Next; 1005 end loop; 1006 end; 1007 end if; 1008 end Find_Binding_Languages; 1009 1010 ---------------- 1011 -- Get_Target -- 1012 ---------------- 1013 1014 function Get_Target return String is 1015 begin 1016 if Target_Name = null or else Target_Name.all = "" then 1017 return GprConfig.Sdefault.Hostname; 1018 else 1019 return Target_Name.all; 1020 end if; 1021 end Get_Target; 1022 1023 -------------------- 1024 -- Locate_Runtime -- 1025 -------------------- 1026 1027 procedure Locate_Runtime 1028 (Project_Tree : Project_Tree_Ref; 1029 Language : Name_Id) 1030 is 1031 function Is_RTS_Directory (Path : String) return Boolean; 1032 -- Returns True if Path is a directory for a runtime. This simply check 1033 -- that Path has a "adalib" subdirectoy, which is a property for 1034 -- runtimes on the project path. 1035 1036 function Is_Base_Name (Path : String) return Boolean; 1037 -- Returns True if Path has no directory separator 1038 1039 ---------------------- 1040 -- Is_RTS_Directory -- 1041 ---------------------- 1042 1043 function Is_RTS_Directory (Path : String) return Boolean is 1044 begin 1045 return Is_Directory (Path & Directory_Separator & "adalib"); 1046 end Is_RTS_Directory; 1047 1048 -- Local declarations 1049 1050 function Find_Rts_In_Path is new GPR.Env.Find_Name_In_Path 1051 (Check_Filename => Is_RTS_Directory); 1052 1053 ------------------ 1054 -- Is_Base_Name -- 1055 ------------------ 1056 1057 function Is_Base_Name (Path : String) return Boolean is 1058 begin 1059 for I in Path'Range loop 1060 if Path (I) = Directory_Separator or else Path (I) = '/' then 1061 return False; 1062 end if; 1063 end loop; 1064 return True; 1065 end Is_Base_Name; 1066 1067 RTS_Name : constant String := GPR.Conf.Runtime_Name_For (Language); 1068 1069 Full_Path : String_Access; 1070 1071 begin 1072 Full_Path := Find_Rts_In_Path (Root_Environment.Project_Path, RTS_Name); 1073 if Full_Path /= null then 1074 GPR.Conf.Set_Runtime_For 1075 (Language, Normalize_Pathname (Full_Path.all)); 1076 Free (Full_Path); 1077 elsif not Is_Base_Name (RTS_Name) then 1078 Fail_Program (Project_Tree, "cannot find RTS " & RTS_Name); 1079 end if; 1080 end Locate_Runtime; 1081 1082 ------------------------------ 1083 -- Look_For_Default_Project -- 1084 ------------------------------ 1085 1086 procedure Look_For_Default_Project (Never_Fail : Boolean := False) is 1087 begin 1088 No_Project_File_Found := False; 1089 1090 if Is_Regular_File (Default_Project_File_Name) then 1091 Project_File_Name := new String'(Default_Project_File_Name); 1092 1093 else 1094 -- Check if there is a single project file in the current 1095 -- directory. If there is one and only one, use it. 1096 1097 declare 1098 Dir : Dir_Type; 1099 Str : String (1 .. 255); 1100 Last : Natural; 1101 Single : String_Access := null; 1102 1103 begin 1104 No_Project_File_Found := True; 1105 1106 Open (Dir, "."); 1107 1108 loop 1109 Read (Dir, Str, Last); 1110 exit when Last = 0; 1111 1112 if Last > Project_File_Extension'Length 1113 and then Is_Regular_File (Str (1 .. Last)) 1114 then 1115 Canonical_Case_File_Name (Str (1 .. Last)); 1116 1117 if Str (Last - Project_File_Extension'Length + 1 .. Last) 1118 = Project_File_Extension 1119 then 1120 No_Project_File_Found := False; 1121 1122 if Single = null then 1123 Single := new String'(Str (1 .. Last)); 1124 1125 else 1126 -- There are several project files in the current 1127 -- directory. Reset Single to null and exit. 1128 1129 Single := null; 1130 exit; 1131 end if; 1132 end if; 1133 end if; 1134 end loop; 1135 1136 Close (Dir); 1137 1138 Project_File_Name := Single; 1139 end; 1140 1141 if No_Project_File_Found or else 1142 (Never_Fail and then Project_File_Name = null) 1143 then 1144 Project_File_Name := 1145 new String'(Executable_Prefix_Path & Implicit_Project_File_Path); 1146 1147 if not Is_Regular_File (Project_File_Name.all) then 1148 Project_File_Name := null; 1149 end if; 1150 end if; 1151 end if; 1152 1153 if (not Quiet_Output) and then Project_File_Name /= null then 1154 Put ("using project file "); 1155 Put_Line (Project_File_Name.all); 1156 end if; 1157 end Look_For_Default_Project; 1158 1159 ------------------- 1160 -- Major_Id_Name -- 1161 ------------------- 1162 1163 function Major_Id_Name 1164 (Lib_Filename : String; 1165 Lib_Version : String) 1166 return String 1167 is 1168 Maj_Version : constant String := Lib_Version; 1169 Last_Maj : Positive; 1170 Last : Positive; 1171 Ok_Maj : Boolean := False; 1172 1173 begin 1174 Last_Maj := Maj_Version'Last; 1175 while Last_Maj > Maj_Version'First loop 1176 if Maj_Version (Last_Maj) in '0' .. '9' then 1177 Last_Maj := Last_Maj - 1; 1178 1179 else 1180 Ok_Maj := Last_Maj /= Maj_Version'Last and then 1181 Maj_Version (Last_Maj) = '.'; 1182 1183 if Ok_Maj then 1184 Last_Maj := Last_Maj - 1; 1185 end if; 1186 1187 exit; 1188 end if; 1189 end loop; 1190 1191 if Ok_Maj then 1192 Last := Last_Maj; 1193 while Last > Maj_Version'First loop 1194 if Maj_Version (Last) in '0' .. '9' then 1195 Last := Last - 1; 1196 1197 else 1198 Ok_Maj := Last /= Last_Maj and then 1199 Maj_Version (Last) = '.'; 1200 1201 if Ok_Maj then 1202 Last := Last - 1; 1203 Ok_Maj := 1204 Maj_Version (Maj_Version'First .. Last) = Lib_Filename; 1205 end if; 1206 1207 exit; 1208 end if; 1209 end loop; 1210 end if; 1211 1212 if Ok_Maj then 1213 return Maj_Version (Maj_Version'First .. Last_Maj); 1214 else 1215 return ""; 1216 end if; 1217 end Major_Id_Name; 1218 1219 -------------------- 1220 -- Object_Project -- 1221 -------------------- 1222 1223 function Object_Project (Project : Project_Id) return Project_Id is 1224 Result : Project_Id := No_Project; 1225 1226 procedure Check_Project (P : Project_Id); 1227 -- Find a project with an object dir 1228 1229 ------------------- 1230 -- Check_Project -- 1231 ------------------- 1232 1233 procedure Check_Project (P : Project_Id) is 1234 begin 1235 if P.Qualifier = Aggregate 1236 or else 1237 P.Qualifier = Aggregate_Library 1238 then 1239 declare 1240 List : Aggregated_Project_List := P.Aggregated_Projects; 1241 1242 begin 1243 -- Look for a non aggregate project until one is found 1244 1245 while Result = No_Project and then List /= null loop 1246 Check_Project (List.Project); 1247 List := List.Next; 1248 end loop; 1249 end; 1250 1251 elsif P.Object_Directory.Name /= No_Path then 1252 Result := P; 1253 end if; 1254 end Check_Project; 1255 1256 begin 1257 Check_Project (Project); 1258 return Result; 1259 end Object_Project; 1260 1261 ------------------ 1262 -- Partial_Name -- 1263 ------------------ 1264 1265 function Partial_Name 1266 (Lib_Name : String; 1267 Number : Natural; 1268 Object_Suffix : String) return String 1269 is 1270 Img : constant String := Number'Img; 1271 begin 1272 return 1273 Partial_Prefix & Lib_Name & 1274 '_' & Img (Img'First + 1 .. Img'Last) 1275 & Object_Suffix; 1276 end Partial_Name; 1277 1278 -------------------------------- 1279 -- Project_Compilation_Failed -- 1280 -------------------------------- 1281 1282 function Project_Compilation_Failed 1283 (Prj : Project_Id; 1284 Recursive : Boolean := True) return Boolean 1285 is 1286 use Project_Name_Boolean_Htable; 1287 begin 1288 if Get (Project_Failure, Prj.Name) then 1289 return True; 1290 1291 elsif not Recursive then 1292 return False; 1293 1294 else 1295 -- Check all imported projects directly or indirectly 1296 declare 1297 Plist : Project_List := Prj.All_Imported_Projects; 1298 begin 1299 while Plist /= null loop 1300 if Get (Project_Failure, Plist.Project.Name) then 1301 return True; 1302 else 1303 Plist := Plist.Next; 1304 end if; 1305 end loop; 1306 return False; 1307 end; 1308 end if; 1309 end Project_Compilation_Failed; 1310 1311 ----------------------------------- 1312 -- Set_Failed_Compilation_Status -- 1313 ----------------------------------- 1314 1315 procedure Set_Failed_Compilation_Status (Prj : Project_Id) is 1316 begin 1317 Project_Name_Boolean_Htable.Set (Project_Failure, Prj.Name, True); 1318 end Set_Failed_Compilation_Status; 1319 1320 ----------------------- 1321 -- Shared_Libgcc_Dir -- 1322 ----------------------- 1323 1324 function Shared_Libgcc_Dir (Run_Time_Dir : String) return String is 1325 Path : String (1 .. Run_Time_Dir'Length + 15); 1326 Path_Last : constant Natural := Run_Time_Dir'Length; 1327 GCC_Index : Natural := 0; 1328 1329 begin 1330 Path (1 .. Path_Last) := Run_Time_Dir; 1331 GCC_Index := Index (Path (1 .. Path_Last), "gcc-lib"); 1332 1333 if GCC_Index /= 0 then 1334 -- This is gcc 2.8.2: the shared version of libgcc is 1335 -- located in the parent directory of "gcc-lib". 1336 1337 GCC_Index := GCC_Index - 1; 1338 1339 else 1340 GCC_Index := Index (Path (1 .. Path_Last), "/lib/"); 1341 1342 if GCC_Index = 0 then 1343 GCC_Index := 1344 Index 1345 (Path (1 .. Path_Last), 1346 Directory_Separator & "lib" & Directory_Separator); 1347 end if; 1348 1349 if GCC_Index /= 0 then 1350 -- We have found "lib" as a subdirectory in the runtime dir path. 1351 -- The 1352 declare 1353 Subdir : constant String := 1354 Interfaces.C.Strings.Value (Libgcc_Subdir_Ptr); 1355 begin 1356 Path 1357 (GCC_Index + 1 .. 1358 GCC_Index + Subdir'Length) := 1359 Subdir; 1360 GCC_Index := 1361 GCC_Index + Subdir'Length; 1362 end; 1363 end if; 1364 end if; 1365 1366 return Path (1 .. GCC_Index); 1367 end Shared_Libgcc_Dir; 1368 1369 --------------------- 1370 -- Need_To_Compile -- 1371 --------------------- 1372 1373 procedure Need_To_Compile 1374 (Source : GPR.Source_Id; 1375 Tree : Project_Tree_Ref; 1376 In_Project : Project_Id; 1377 Must_Compile : out Boolean; 1378 The_ALI : out ALI.ALI_Id; 1379 Object_Check : Boolean; 1380 Always_Compile : Boolean) 1381 is 1382 Source_Path : constant String := 1383 Get_Name_String (Source.Path.Display_Name); 1384 C_Source_Path : constant String := 1385 Get_Name_String (Source.Path.Name); 1386 Runtime_Source_Dirs : constant Name_List_Index := 1387 Source.Language.Config.Runtime_Source_Dirs; 1388 1389 Start : Natural; 1390 Finish : Natural; 1391 Last_Obj : Natural; 1392 Stamp : Time_Stamp_Type; 1393 1394 Looping : Boolean := False; 1395 -- Set to True at the end of the first Big_Loop for Makefile fragments 1396 1397 Source_In_Dependencies : Boolean := False; 1398 -- Set True if source was found in dependency file of its object file 1399 1400 C_Object_Name : String_Access := null; 1401 -- The canonical file name for the object file 1402 1403 Object_Path : String_Access := null; 1404 -- The absolute path name for the object file 1405 1406 Switches_Name : String_Access := null; 1407 -- The file name of the file that contains the switches that were used 1408 -- in the last compilation. 1409 1410 Num_Ext : Natural; 1411 -- Number of extending projects 1412 1413 ALI_Project : Project_Id; 1414 -- If the ALI file is in the object directory of a project, this is 1415 -- the project id. 1416 1417 Externally_Built : constant Boolean := In_Project.Externally_Built; 1418 -- True if the project of the source is externally built 1419 1420 function Process_Makefile_Deps 1421 (Dep_Name, Obj_Dir : String) return Boolean; 1422 function Process_ALI_Deps return Boolean; 1423 function Process_ALI_Closure_Deps return Boolean; 1424 -- Process the dependencies for the current source file for the various 1425 -- dependency modes. 1426 -- They return True if the file needs to be recompiled 1427 1428 procedure Cleanup; 1429 -- Cleanup local variables 1430 1431 function Check_Time_Stamps 1432 (Path : String; 1433 Stamp : Time_Stamp_Type) 1434 return Boolean; 1435 1436 ----------------------- 1437 -- Check_Time_Stamps -- 1438 ----------------------- 1439 1440 function Check_Time_Stamps 1441 (Path : String; 1442 Stamp : Time_Stamp_Type) 1443 return Boolean 1444 is 1445 begin 1446 Name_Len := 0; 1447 Add_Str_To_Name_Buffer (Path); 1448 1449 declare 1450 TS : constant Time_Stamp_Type := 1451 File_Stamp (Path_Name_Type'(Name_Find)); 1452 begin 1453 if TS /= Empty_Time_Stamp and then TS /= Stamp then 1454 if Verbose_Mode then 1455 Put_Line (" -> different time stamp for " & Path); 1456 1457 if Debug.Debug_Flag_T then 1458 Put_Line (" in ALI file: " & String (Stamp)); 1459 Put_Line (" actual file: " & String (TS)); 1460 end if; 1461 end if; 1462 1463 return True; 1464 end if; 1465 end; 1466 1467 return False; 1468 end Check_Time_Stamps; 1469 1470 --------------------------- 1471 -- Process_Makefile_Deps -- 1472 --------------------------- 1473 1474 function Process_Makefile_Deps 1475 (Dep_Name, Obj_Dir : String) return Boolean 1476 is 1477 Dep_File : GPR.Util.Text_File; 1478 Last_Source : String_Access; 1479 Last_TS : Time_Stamp_Type := Empty_Time_Stamp; 1480 1481 function Is_Time_Stamp (S : String) return Boolean; 1482 -- Return True iff S has the format of a Time_Stamp_Type 1483 1484 ------------------- 1485 -- Is_Time_Stamp -- 1486 ------------------- 1487 1488 function Is_Time_Stamp (S : String) return Boolean is 1489 Result : Boolean := False; 1490 begin 1491 if S'Length = Time_Stamp_Length then 1492 Result := True; 1493 1494 for J in S'Range loop 1495 if S (J) not in '0' .. '9' then 1496 Result := False; 1497 exit; 1498 end if; 1499 end loop; 1500 end if; 1501 1502 return Result; 1503 end Is_Time_Stamp; 1504 1505 begin 1506 Open (Dep_File, Dep_Name); 1507 1508 -- If dependency file cannot be open, we need to recompile 1509 -- the source. 1510 1511 if not Is_Valid (Dep_File) then 1512 if Verbose_Mode then 1513 Put (" -> could not open dependency file "); 1514 Put_Line (Dep_Name); 1515 end if; 1516 1517 return True; 1518 end if; 1519 1520 -- Loop Big_Loop is executed several times only when the 1521 -- dependency file contains several times 1522 -- <object file>: <source1> ... 1523 -- When there is only one of such occurence, Big_Loop is exited 1524 -- successfully at the beginning of the second loop. 1525 1526 Big_Loop : 1527 loop 1528 declare 1529 End_Of_File_Reached : Boolean := False; 1530 Object_Found : Boolean := False; 1531 1532 begin 1533 loop 1534 if End_Of_File (Dep_File) then 1535 End_Of_File_Reached := True; 1536 exit; 1537 end if; 1538 1539 Get_Line (Dep_File, Name_Buffer, Name_Len); 1540 1541 if Name_Len > 0 1542 and then Name_Buffer (1) /= '#' 1543 then 1544 -- Skip a first line that is an empty continuation line 1545 1546 for J in 1 .. Name_Len - 1 loop 1547 if Name_Buffer (J) /= ' ' then 1548 Object_Found := True; 1549 exit; 1550 end if; 1551 end loop; 1552 1553 exit when Object_Found 1554 or else Name_Buffer (Name_Len) /= '\'; 1555 end if; 1556 end loop; 1557 1558 -- If dependency file contains only empty lines or comments, 1559 -- then dependencies are unknown, and the source needs to be 1560 -- recompiled. 1561 1562 if End_Of_File_Reached then 1563 -- If we have reached the end of file after the first 1564 -- loop, there is nothing else to do. 1565 1566 exit Big_Loop when Looping; 1567 1568 if Verbose_Mode then 1569 Put (" -> dependency file "); 1570 Put (Dep_Name); 1571 Put_Line (" is empty"); 1572 end if; 1573 1574 Close (Dep_File); 1575 return True; 1576 end if; 1577 end; 1578 1579 Start := 1; 1580 Finish := Index (Name_Buffer (1 .. Name_Len), ": "); 1581 1582 if Finish = 0 then 1583 Finish := 1584 Index 1585 (Name_Buffer (1 .. Name_Len), (1 => ':', 2 => ASCII.HT)); 1586 end if; 1587 1588 if Finish /= 0 then 1589 Last_Obj := Finish; 1590 loop 1591 Last_Obj := Last_Obj - 1; 1592 exit when Last_Obj = Start 1593 or else Name_Buffer (Last_Obj) /= ' '; 1594 end loop; 1595 1596 while Start < Last_Obj and then Name_Buffer (Start) = ' ' loop 1597 Start := Start + 1; 1598 end loop; 1599 1600 Canonical_Case_File_Name (Name_Buffer (Start .. Last_Obj)); 1601 end if; 1602 1603 -- First line must start with name of object file, followed by 1604 -- colon. 1605 1606 if Finish = 0 1607 or else 1608 (C_Object_Name /= null 1609 and then Name_Buffer (Start .. Last_Obj) /= C_Object_Name.all) 1610 then 1611 if Verbose_Mode then 1612 Put (" -> dependency file "); 1613 Put (Dep_Name); 1614 Put_Line (" has wrong format"); 1615 1616 if Finish = 0 then 1617 Put_Line (" no colon"); 1618 1619 else 1620 Put (" expected object file name "); 1621 Put (C_Object_Name.all); 1622 Put (", got "); 1623 Put_Line (Name_Buffer (Start .. Last_Obj)); 1624 end if; 1625 end if; 1626 1627 Close (Dep_File); 1628 return True; 1629 1630 else 1631 Start := Finish + 2; 1632 1633 -- Process each line 1634 1635 Line_Loop : loop 1636 declare 1637 Line : String := Name_Buffer (1 .. Name_Len); 1638 Last : Natural := Name_Len; 1639 1640 begin 1641 Name_Loop : loop 1642 1643 -- Find the beginning of the next source path name 1644 1645 while Start <= Last and then Line (Start) = ' ' loop 1646 Start := Start + 1; 1647 end loop; 1648 1649 exit Line_Loop when Start > Last; 1650 1651 -- Go to next line when there is a continuation 1652 -- character \ at the end of the line. 1653 1654 exit Name_Loop when Start = Last 1655 and then Line (Start) = '\'; 1656 1657 -- We should not be at the end of the line, without 1658 -- a continuation character \. 1659 1660 if Start = Last then 1661 if Verbose_Mode then 1662 Put (" -> dependency file "); 1663 Put (Dep_Name); 1664 Put_Line (" has wrong format"); 1665 end if; 1666 1667 Close (Dep_File); 1668 return True; 1669 end if; 1670 1671 -- Look for the end of the source path name 1672 1673 Finish := Start; 1674 1675 while Finish < Last loop 1676 if Line (Finish) = '\' then 1677 -- On Windows, a '\' is part of the path 1678 -- name, except when it is not the first 1679 -- character followed by another '\' or by a 1680 -- space. On other platforms, when we are 1681 -- getting a '\' that is not the last 1682 -- character of the line, the next character 1683 -- is part of the path name, even if it is a 1684 -- space. 1685 1686 if On_Windows 1687 and then Finish = Start 1688 and then Line (Finish + 1) = '\' 1689 then 1690 Finish := Finish + 2; 1691 1692 elsif On_Windows 1693 and then Line (Finish + 1) /= '\' 1694 and then Line (Finish + 1) /= ' ' 1695 then 1696 Finish := Finish + 1; 1697 1698 else 1699 Line (Finish .. Last - 1) := 1700 Line (Finish + 1 .. Last); 1701 Last := Last - 1; 1702 end if; 1703 1704 else 1705 -- A space that is not preceded by '\' 1706 -- indicates the end of the path name. 1707 1708 exit when Line (Finish + 1) = ' '; 1709 Finish := Finish + 1; 1710 end if; 1711 end loop; 1712 1713 if Last_Source /= null 1714 and then Is_Time_Stamp (Line (Start .. Finish)) 1715 then 1716 -- If we have a time stamp, check if it is the 1717 -- same as the source time stamp. 1718 1719 declare 1720 Tstring : constant 1721 String (1 .. Time_Stamp_Length) := 1722 Line (Start .. Finish); 1723 TS : constant Time_Stamp_Type := 1724 Time_Stamp_Type (Tstring); 1725 OK : constant Boolean := Last_TS = TS; 1726 1727 begin 1728 if not OK and then Verbose_Mode then 1729 Put (" -> source "); 1730 Put (Last_Source.all); 1731 Put_Line 1732 (" has modified time stamp"); 1733 end if; 1734 1735 Free (Last_Source); 1736 1737 if not OK then 1738 Close (Dep_File); 1739 return True; 1740 end if; 1741 end; 1742 1743 else 1744 -- Check this source 1745 1746 declare 1747 Src_Name : constant String := 1748 Normalize_Pathname 1749 (Name => Line (Start .. Finish), 1750 Directory => Obj_Dir, 1751 Resolve_Links => False); 1752 C_Src_Name : String := Src_Name; 1753 Src_TS : Time_Stamp_Type; 1754 Source_2 : GPR.Source_Id; 1755 1756 begin 1757 Canonical_Case_File_Name (C_Src_Name); 1758 1759 -- If it is original source, set 1760 -- Source_In_Dependencies. 1761 1762 if C_Src_Name = C_Source_Path then 1763 Source_In_Dependencies := True; 1764 end if; 1765 1766 -- Get the time stamp of the source, which is 1767 -- not necessarily a source of any project. 1768 1769 Name_Len := 0; 1770 Add_Str_To_Name_Buffer (Src_Name); 1771 Src_TS := File_Stamp 1772 (Path_Name_Type'(Name_Find)); 1773 1774 -- If the source does not exist, we need to 1775 -- recompile. 1776 1777 if Src_TS = Empty_Time_Stamp then 1778 if Verbose_Mode then 1779 Put (" -> source "); 1780 Put (Src_Name); 1781 Put_Line (" does not exist"); 1782 end if; 1783 1784 Close (Dep_File); 1785 return True; 1786 1787 -- If the source has been modified after the 1788 -- object file, we need to recompile. 1789 1790 elsif Src_TS > Source.Object_TS 1791 and then Object_Check 1792 and then 1793 Source.Language.Config.Object_Generated 1794 then 1795 if Verbose_Mode then 1796 Put (" -> source "); 1797 Put (Src_Name); 1798 Put_Line 1799 (" has time stamp later than object file"); 1800 end if; 1801 1802 Close (Dep_File); 1803 return True; 1804 1805 else 1806 Name_Len := Src_Name'Length; 1807 Name_Buffer (1 .. Name_Len) := Src_Name; 1808 Source_2 := Source_Paths_Htable.Get 1809 (Tree.Source_Paths_HT, Name_Find); 1810 1811 if Source_2 /= No_Source 1812 and then Source_2.Replaced_By /= No_Source 1813 then 1814 if Verbose_Mode then 1815 Put (" -> source "); 1816 Put (Src_Name); 1817 Put_Line (" has been replaced"); 1818 end if; 1819 1820 Close (Dep_File); 1821 return True; 1822 1823 else 1824 Last_Source := new String'(Src_Name); 1825 Last_TS := Src_TS; 1826 end if; 1827 end if; 1828 end; 1829 end if; 1830 1831 -- If the source path name ends the line, we are 1832 -- done. 1833 1834 exit Line_Loop when Finish = Last; 1835 1836 -- Go get the next source on the line 1837 1838 Start := Finish + 1; 1839 end loop Name_Loop; 1840 end; 1841 1842 -- If we are here, we had a continuation character \ at 1843 -- the end of the line, so we continue with the next 1844 -- line. 1845 1846 Get_Line (Dep_File, Name_Buffer, Name_Len); 1847 Start := 1; 1848 Finish := 1; 1849 end loop Line_Loop; 1850 end if; 1851 1852 -- Set Looping at the end of the first loop 1853 Looping := True; 1854 end loop Big_Loop; 1855 1856 Close (Dep_File); 1857 1858 -- If the original sources were not in the dependency file, then 1859 -- we need to recompile. It may mean that we are using a different 1860 -- source (different variant) for this object file. 1861 1862 if not Source_In_Dependencies then 1863 if Verbose_Mode then 1864 Put (" -> source "); 1865 Put (Source_Path); 1866 Put_Line (" is not in the dependencies"); 1867 end if; 1868 1869 return True; 1870 end if; 1871 1872 return False; 1873 end Process_Makefile_Deps; 1874 1875 ---------------------- 1876 -- Process_ALI_Deps -- 1877 ---------------------- 1878 1879 function Process_ALI_Deps return Boolean is 1880 Text : Text_Buffer_Ptr := 1881 Read_Library_Info_From_Full 1882 (File_Name_Type (Source.Dep_Path), 1883 Source.Dep_TS'Access); 1884 Sfile : File_Name_Type; 1885 Dep_Src : GPR.Source_Id; 1886 Proj : Project_Id; 1887 1888 Found : Boolean := False; 1889 1890 begin 1891 if Text = null then 1892 if Verbose_Mode then 1893 Put (" -> cannot read "); 1894 Put_Line (Get_Name_String (Source.Dep_Path)); 1895 end if; 1896 1897 return True; 1898 end if; 1899 1900 -- Read only the necessary lines of the ALI file 1901 1902 The_ALI := 1903 ALI.Scan_ALI 1904 (File_Name_Type (Source.Dep_Path), 1905 Text, 1906 Ignore_ED => False, 1907 Err => True, 1908 Read_Lines => "PDW"); 1909 Free (Text); 1910 1911 if The_ALI = ALI.No_ALI_Id then 1912 if Verbose_Mode then 1913 Put (" -> "); 1914 Put (Get_Name_String (Source.Dep_Path)); 1915 Put_Line (" is incorrectly formatted"); 1916 end if; 1917 1918 return True; 1919 end if; 1920 1921 if ALI.ALIs.Table (The_ALI).Compile_Errors then 1922 if Verbose_Mode then 1923 Put_Line (" -> last compilation had errors"); 1924 end if; 1925 1926 return True; 1927 end if; 1928 1929 if Object_Check and then ALI.ALIs.Table (The_ALI).No_Object then 1930 if Verbose_Mode then 1931 Put_Line 1932 (" -> no object generated during last compilation"); 1933 end if; 1934 1935 return True; 1936 end if; 1937 1938 if Check_Source_Info_In_ALI (The_ALI, Tree) = No_Name then 1939 return True; 1940 end if; 1941 1942 -- We need to check that the ALI file is in the correct object 1943 -- directory. If it is in the object directory of a project 1944 -- that is extended and it depends on a source that is in one 1945 -- of its extending projects, then the ALI file is not in the 1946 -- correct object directory. 1947 1948 ALI_Project := Source.Object_Project; 1949 1950 -- Count the extending projects 1951 1952 Num_Ext := 0; 1953 Proj := ALI_Project; 1954 loop 1955 Proj := Proj.Extended_By; 1956 exit when Proj = No_Project; 1957 Num_Ext := Num_Ext + 1; 1958 end loop; 1959 1960 declare 1961 Projects : array (1 .. Num_Ext) of Project_Id; 1962 begin 1963 Proj := ALI_Project; 1964 for J in Projects'Range loop 1965 Proj := Proj.Extended_By; 1966 Projects (J) := Proj; 1967 end loop; 1968 1969 for D in ALI.ALIs.Table (The_ALI).First_Sdep .. 1970 ALI.ALIs.Table (The_ALI).Last_Sdep 1971 loop 1972 Sfile := ALI.Sdep.Table (D).Sfile; 1973 1974 if ALI.Sdep.Table (D).Stamp /= Empty_Time_Stamp then 1975 Dep_Src := Source_Files_Htable.Get 1976 (Tree.Source_Files_HT, Sfile); 1977 Found := False; 1978 1979 if Dep_Src = No_Source and then 1980 ALI.Sdep.Table (D).Checksum /= 0 and then 1981 not Is_Ada_Predefined_File_Name (Sfile) 1982 then 1983 if Verbose_Mode then 1984 Put (" -> """); 1985 Put (Get_Name_String (Sfile)); 1986 Put_Line (""" missing"); 1987 end if; 1988 1989 return True; 1990 end if; 1991 1992 while Dep_Src /= No_Source loop 1993 Initialize_Source_Record (Dep_Src); 1994 1995 if not Dep_Src.Locally_Removed 1996 and then Dep_Src.Unit /= No_Unit_Index 1997 then 1998 Found := True; 1999 2000 if Opt.Minimal_Recompilation 2001 and then ALI.Sdep.Table (D).Stamp /= 2002 Dep_Src.Source_TS 2003 then 2004 -- If minimal recompilation is in action, replace 2005 -- the stamp of the source file in the table if 2006 -- checksums match. 2007 2008 declare 2009 Source_Index : Source_File_Index; 2010 use Scans; 2011 2012 begin 2013 Source_Index := 2014 Sinput.Load_File 2015 (Get_Name_String 2016 (Dep_Src.Path.Display_Name)); 2017 2018 if Source_Index /= No_Source_File then 2019 2020 Err.Scanner.Initialize_Scanner 2021 (Source_Index, Err.Scanner.Ada); 2022 2023 -- Scan the complete file to compute its 2024 -- checksum. 2025 2026 loop 2027 Err.Scanner.Scan; 2028 exit when Token = Tok_EOF; 2029 end loop; 2030 2031 if Scans.Checksum = 2032 ALI.Sdep.Table (D).Checksum 2033 then 2034 if Verbose_Mode then 2035 Put (" "); 2036 Put 2037 (Get_Name_String 2038 (ALI.Sdep.Table (D).Sfile)); 2039 Put (": up to date, " & 2040 "different timestamps " & 2041 "but same checksum"); 2042 New_Line; 2043 end if; 2044 2045 ALI.Sdep.Table (D).Stamp := 2046 Dep_Src.Source_TS; 2047 end if; 2048 end if; 2049 2050 -- To avoid using too much memory, free the 2051 -- memory allocated. 2052 2053 Sinput.Clear_Source_File_Table; 2054 end; 2055 end if; 2056 2057 if ALI.Sdep.Table (D).Stamp /= Dep_Src.Source_TS then 2058 if Verbose_Mode then 2059 Put 2060 (" -> different time stamp for "); 2061 Put_Line (Get_Name_String (Sfile)); 2062 2063 if Debug.Debug_Flag_T then 2064 Put (" in ALI file: "); 2065 Put_Line 2066 (String (ALI.Sdep.Table (D).Stamp)); 2067 Put (" actual file: "); 2068 Put_Line (String (Dep_Src.Source_TS)); 2069 end if; 2070 end if; 2071 2072 return True; 2073 2074 else 2075 for J in Projects'Range loop 2076 if Dep_Src.Project = Projects (J) then 2077 if Verbose_Mode then 2078 Put_Line 2079 (" -> wrong object directory"); 2080 end if; 2081 2082 return True; 2083 end if; 2084 end loop; 2085 2086 exit; 2087 end if; 2088 end if; 2089 2090 Dep_Src := Dep_Src.Next_With_File_Name; 2091 end loop; 2092 2093 -- If the source was not found and the runtime source 2094 -- directory is defined, check if the file exists there, and 2095 -- if it does, check its timestamp. 2096 2097 if not Found 2098 and then 2099 (Runtime_Source_Dirs /= No_Name_List 2100 or else 2101 Is_Absolute_Path (Get_Name_String (Sfile))) 2102 then 2103 if Is_Absolute_Path (Get_Name_String (Sfile)) then 2104 if Check_Time_Stamps 2105 (Get_Name_String (Sfile), ALI.Sdep.Table (D).Stamp) 2106 then 2107 return True; 2108 end if; 2109 2110 else 2111 declare 2112 R_Dirs : Name_List_Index := Runtime_Source_Dirs; 2113 begin 2114 while R_Dirs /= No_Name_List loop 2115 declare 2116 Nam_Nod : constant Name_Node := 2117 Tree.Shared.Name_Lists.Table (R_Dirs); 2118 begin 2119 if Check_Time_Stamps 2120 (Get_Name_String (Nam_Nod.Name) & 2121 Directory_Separator & 2122 Get_Name_String (Sfile), 2123 ALI.Sdep.Table (D).Stamp) 2124 then 2125 return True; 2126 end if; 2127 2128 R_Dirs := Nam_Nod.Next; 2129 end; 2130 end loop; 2131 end; 2132 end if; 2133 end if; 2134 end if; 2135 end loop; 2136 end; 2137 2138 return False; 2139 end Process_ALI_Deps; 2140 2141 package Processed_Sources is new GNAT.Table 2142 (Table_Component_Type => GPR.Source_Id, 2143 Table_Index_Type => Positive, 2144 Table_Low_Bound => 1, 2145 Table_Initial => 10, 2146 Table_Increment => 100); 2147 2148 ------------------------------ 2149 -- Process_ALI_Closure_Deps -- 2150 ------------------------------ 2151 2152 function Process_ALI_Closure_Deps return Boolean is 2153 Attr : aliased File_Attributes := Unknown_Attributes; 2154 Text : Text_Buffer_Ptr := 2155 Read_Library_Info_From_Full 2156 (File_Name_Type (Source.Dep_Path), Attr'Access); 2157 Sfile : File_Name_Type; 2158 Dep_Src : GPR.Source_Id; 2159 Proj : Project_Id; 2160 TS0 : Time_Stamp_Type; 2161 2162 Found : Boolean := False; 2163 2164 Last_Processed_Source : Natural := 0; 2165 Next_Source : GPR.Source_Id; 2166 Insert_Source : Boolean := False; 2167 2168 Other_ALI : ALI.ALI_Id; 2169 begin 2170 if Text = null then 2171 if Verbose_Mode then 2172 Put (" -> cannot read "); 2173 Put_Line (Get_Name_String (Source.Dep_Path)); 2174 end if; 2175 2176 return True; 2177 end if; 2178 2179 TS0 := File_Stamp (Source.Dep_Path); 2180 2181 -- Read only the necessary lines of the ALI file 2182 2183 The_ALI := 2184 ALI.Scan_ALI 2185 (File_Name_Type (Source.Dep_Path), 2186 Text, 2187 Ignore_ED => False, 2188 Err => True, 2189 Read_Lines => "PDW"); 2190 Free (Text); 2191 2192 if The_ALI = ALI.No_ALI_Id then 2193 if Verbose_Mode then 2194 Put (" -> "); 2195 Put (Get_Name_String (Source.Dep_Path)); 2196 Put_Line (" is incorrectly formatted"); 2197 end if; 2198 2199 return True; 2200 end if; 2201 2202 if ALI.ALIs.Table (The_ALI).Compile_Errors then 2203 if Verbose_Mode then 2204 Put_Line (" -> last compilation had errors"); 2205 end if; 2206 2207 return True; 2208 end if; 2209 2210 if Object_Check and then ALI.ALIs.Table (The_ALI).No_Object then 2211 if Verbose_Mode then 2212 Put_Line 2213 (" -> no object generated during last compilation"); 2214 end if; 2215 2216 return True; 2217 end if; 2218 2219 if Check_Source_Info_In_ALI (The_ALI, Tree) = No_Name then 2220 return True; 2221 end if; 2222 2223 Processed_Sources.Init; 2224 Processed_Sources.Append (Source); 2225 Last_Processed_Source := 2; 2226 2227 -- We need to check that the ALI file is in the correct object 2228 -- directory. If it is in the object directory of a project 2229 -- that is extended and it depends on a source that is in one 2230 -- of its extending projects, then the ALI file is not in the 2231 -- correct object directory. 2232 2233 ALI_Project := Source.Object_Project; 2234 2235 -- Count the extending projects 2236 2237 Num_Ext := 0; 2238 Proj := ALI_Project; 2239 loop 2240 Proj := Proj.Extended_By; 2241 exit when Proj = No_Project; 2242 Num_Ext := Num_Ext + 1; 2243 end loop; 2244 2245 declare 2246 Projects : array (1 .. Num_Ext) of Project_Id; 2247 begin 2248 Proj := ALI_Project; 2249 for J in Projects'Range loop 2250 Proj := Proj.Extended_By; 2251 Projects (J) := Proj; 2252 end loop; 2253 2254 for D in ALI.ALIs.Table (The_ALI).First_Sdep .. 2255 ALI.ALIs.Table (The_ALI).Last_Sdep 2256 loop 2257 Sfile := ALI.Sdep.Table (D).Sfile; 2258 2259 if ALI.Sdep.Table (D).Stamp /= Empty_Time_Stamp then 2260 Dep_Src := Source_Files_Htable.Get 2261 (Tree.Source_Files_HT, Sfile); 2262 Found := False; 2263 2264 if Dep_Src /= No_Source then 2265 Insert_Source := True; 2266 for J in 1 .. Processed_Sources.Last loop 2267 if Processed_Sources.Table (J) = Dep_Src then 2268 Insert_Source := False; 2269 exit; 2270 end if; 2271 end loop; 2272 2273 if Insert_Source then 2274 Processed_Sources.Append (Dep_Src); 2275 end if; 2276 end if; 2277 2278 while Dep_Src /= No_Source loop 2279 Initialize_Source_Record (Dep_Src); 2280 2281 if not Dep_Src.Locally_Removed 2282 and then Dep_Src.Unit /= No_Unit_Index 2283 then 2284 Found := True; 2285 2286 if Opt.Minimal_Recompilation 2287 and then ALI.Sdep.Table (D).Stamp /= 2288 Dep_Src.Source_TS 2289 then 2290 -- If minimal recompilation is in action, replace 2291 -- the stamp of the source file in the table if 2292 -- checksums match. 2293 2294 declare 2295 Source_Index : Source_File_Index; 2296 use Scans; 2297 2298 begin 2299 Source_Index := 2300 Sinput.Load_File 2301 (Get_Name_String 2302 (Dep_Src.Path.Display_Name)); 2303 2304 if Source_Index /= No_Source_File then 2305 2306 Err.Scanner.Initialize_Scanner 2307 (Source_Index, Err.Scanner.Ada); 2308 2309 -- Scan the complete file to compute its 2310 -- checksum. 2311 2312 loop 2313 Err.Scanner.Scan; 2314 exit when Token = Tok_EOF; 2315 end loop; 2316 2317 if Scans.Checksum = 2318 ALI.Sdep.Table (D).Checksum 2319 then 2320 if Verbose_Mode then 2321 Put (" "); 2322 Put 2323 (Get_Name_String 2324 (ALI.Sdep.Table (D).Sfile)); 2325 Put (": up to date, " & 2326 "different timestamps " & 2327 "but same checksum"); 2328 New_Line; 2329 end if; 2330 2331 ALI.Sdep.Table (D).Stamp := 2332 Dep_Src.Source_TS; 2333 end if; 2334 end if; 2335 2336 -- To avoid using too much memory, free the 2337 -- memory allocated. 2338 2339 Sinput.Clear_Source_File_Table; 2340 end; 2341 end if; 2342 2343 if ALI.Sdep.Table (D).Stamp /= Dep_Src.Source_TS then 2344 if Verbose_Mode then 2345 Put 2346 (" -> different time stamp for "); 2347 Put_Line (Get_Name_String (Sfile)); 2348 2349 if Debug.Debug_Flag_T then 2350 Put (" in ALI file: "); 2351 Put_Line 2352 (String (ALI.Sdep.Table (D).Stamp)); 2353 Put (" actual file: "); 2354 Put_Line (String (Dep_Src.Source_TS)); 2355 end if; 2356 end if; 2357 2358 return True; 2359 2360 else 2361 for J in Projects'Range loop 2362 if Dep_Src.Project = Projects (J) then 2363 if Verbose_Mode then 2364 Put_Line 2365 (" -> wrong object directory"); 2366 end if; 2367 2368 return True; 2369 end if; 2370 end loop; 2371 2372 exit; 2373 end if; 2374 end if; 2375 2376 Dep_Src := Dep_Src.Next_With_File_Name; 2377 end loop; 2378 2379 -- If the source was not found and the runtime source 2380 -- directory is defined, check if the file exists there, and 2381 -- if it does, check its timestamp. 2382 2383 if not Found and then Runtime_Source_Dirs /= No_Name_List 2384 then 2385 declare 2386 R_Dirs : Name_List_Index := Runtime_Source_Dirs; 2387 begin 2388 while R_Dirs /= No_Name_List loop 2389 declare 2390 Nam_Nod : constant Name_Node := 2391 Tree.Shared.Name_Lists.Table (R_Dirs); 2392 begin 2393 if Check_Time_Stamps 2394 (Get_Name_String (Nam_Nod.Name) & 2395 Directory_Separator & 2396 Get_Name_String (Sfile), 2397 ALI.Sdep.Table (D).Stamp) 2398 then 2399 return True; 2400 end if; 2401 2402 R_Dirs := Nam_Nod.Next; 2403 end; 2404 end loop; 2405 end; 2406 end if; 2407 end if; 2408 end loop; 2409 end; 2410 2411 while Last_Processed_Source <= Processed_Sources.Last loop 2412 Next_Source := Processed_Sources.Table (Last_Processed_Source); 2413 declare 2414 Attrib : aliased File_Attributes := Unknown_Attributes; 2415 begin 2416 Text := 2417 Read_Library_Info_From_Full 2418 (File_Name_Type (Next_Source.Dep_Path), Attrib'Access); 2419 end; 2420 2421 Last_Processed_Source := Last_Processed_Source + 1; 2422 2423 if Text = null then 2424 if Verbose_Mode then 2425 Put (" -> cannot read "); 2426 Put_Line (Get_Name_String (Next_Source.Dep_Path)); 2427 end if; 2428 2429 return True; 2430 end if; 2431 2432 -- Read only the necessary lines of the ALI file 2433 2434 Other_ALI := 2435 ALI.Scan_ALI 2436 (File_Name_Type (Next_Source.Dep_Path), 2437 Text, 2438 Ignore_ED => False, 2439 Err => True, 2440 Read_Lines => "PDW"); 2441 Free (Text); 2442 2443 if Other_ALI = ALI.No_ALI_Id then 2444 if Verbose_Mode then 2445 Put (" -> "); 2446 Put (Get_Name_String (Next_Source.Dep_Path)); 2447 Put_Line (" is incorrectly formatted"); 2448 end if; 2449 2450 return True; 2451 end if; 2452 2453 if ALI.ALIs.Table (Other_ALI).Compile_Errors then 2454 if Verbose_Mode then 2455 Put (" -> last compilation of "); 2456 Put (Get_Name_String (Next_Source.Dep_Path)); 2457 Put_Line (" had errors"); 2458 end if; 2459 2460 return True; 2461 end if; 2462 2463 for D in ALI.ALIs.Table (Other_ALI).First_Sdep .. 2464 ALI.ALIs.Table (Other_ALI).Last_Sdep 2465 loop 2466 Sfile := ALI.Sdep.Table (D).Sfile; 2467 2468 if ALI.Sdep.Table (D).Stamp /= Empty_Time_Stamp then 2469 Dep_Src := Source_Files_Htable.Get 2470 (Tree.Source_Files_HT, Sfile); 2471 Found := False; 2472 2473 if Dep_Src /= No_Source then 2474 Insert_Source := True; 2475 for J in 1 .. Processed_Sources.Last loop 2476 if Processed_Sources.Table (J) = Dep_Src then 2477 Insert_Source := False; 2478 exit; 2479 end if; 2480 end loop; 2481 2482 if Insert_Source then 2483 Processed_Sources.Append (Dep_Src); 2484 end if; 2485 end if; 2486 2487 while Dep_Src /= No_Source loop 2488 Initialize_Source_Record (Dep_Src); 2489 2490 if not Dep_Src.Locally_Removed 2491 and then Dep_Src.Unit /= No_Unit_Index 2492 then 2493 Found := True; 2494 2495 if Opt.Minimal_Recompilation 2496 and then ALI.Sdep.Table (D).Stamp /= 2497 Dep_Src.Source_TS 2498 then 2499 -- If minimal recompilation is in action, replace 2500 -- the stamp of the source file in the table if 2501 -- checksums match. 2502 2503 declare 2504 Source_Index : Source_File_Index; 2505 use Scans; 2506 2507 begin 2508 Source_Index := 2509 Sinput.Load_File 2510 (Get_Name_String 2511 (Dep_Src.Path.Display_Name)); 2512 2513 if Source_Index /= No_Source_File then 2514 2515 Err.Scanner.Initialize_Scanner 2516 (Source_Index, Err.Scanner.Ada); 2517 2518 -- Scan the complete file to compute its 2519 -- checksum. 2520 2521 loop 2522 Err.Scanner.Scan; 2523 exit when Token = Tok_EOF; 2524 end loop; 2525 2526 if Scans.Checksum = 2527 ALI.Sdep.Table (D).Checksum 2528 then 2529 ALI.Sdep.Table (D).Stamp := 2530 Dep_Src.Source_TS; 2531 end if; 2532 end if; 2533 2534 -- To avoid using too much memory, free the 2535 -- memory allocated. 2536 2537 Sinput.Clear_Source_File_Table; 2538 end; 2539 end if; 2540 2541 if ALI.Sdep.Table (D).Stamp /= Dep_Src.Source_TS then 2542 if Verbose_Mode then 2543 Put 2544 (" -> different time stamp for "); 2545 Put_Line (Get_Name_String (Sfile)); 2546 2547 if Debug.Debug_Flag_T then 2548 Put (" in ALI file: "); 2549 Put_Line 2550 (String (ALI.Sdep.Table (D).Stamp)); 2551 Put (" actual file: "); 2552 Put_Line (String (Dep_Src.Source_TS)); 2553 end if; 2554 end if; 2555 2556 return True; 2557 2558 elsif TS0 < Dep_Src.Source_TS then 2559 if Verbose_Mode then 2560 Put (" -> file "); 2561 Put 2562 (Get_Name_String (Dep_Src.Path.Display_Name)); 2563 Put_Line (" later than ALI file"); 2564 end if; 2565 2566 return True; 2567 end if; 2568 end if; 2569 2570 Dep_Src := Dep_Src.Next_With_File_Name; 2571 end loop; 2572 end if; 2573 end loop; 2574 end loop; 2575 2576 return False; 2577 end Process_ALI_Closure_Deps; 2578 2579 ------------- 2580 -- Cleanup -- 2581 ------------- 2582 2583 procedure Cleanup is 2584 begin 2585 Free (C_Object_Name); 2586 Free (Object_Path); 2587 Free (Switches_Name); 2588 end Cleanup; 2589 2590 begin 2591 The_ALI := ALI.No_ALI_Id; 2592 2593 -- Never attempt to compile header files 2594 2595 if Source.Language.Config.Kind = File_Based 2596 and then Source.Kind = Spec 2597 then 2598 Must_Compile := False; 2599 return; 2600 end if; 2601 2602 if Force_Compilations then 2603 Must_Compile := Always_Compile or else (not Externally_Built); 2604 return; 2605 end if; 2606 2607 -- No need to compile if there is no "compiler" 2608 2609 if Length_Of_Name (Source.Language.Config.Compiler_Driver) = 0 then 2610 Must_Compile := False; 2611 return; 2612 end if; 2613 2614 if Source.Language.Config.Object_Generated and then Object_Check then 2615 C_Object_Name := new String'(Get_Name_String (Source.Object)); 2616 Canonical_Case_File_Name (C_Object_Name.all); 2617 Object_Path := new String'(Get_Name_String (Source.Object_Path)); 2618 2619 if Source.Switches_Path /= No_Path then 2620 Switches_Name := 2621 new String'(Get_Name_String (Source.Switches_Path)); 2622 end if; 2623 end if; 2624 2625 if Verbose_Mode and then Verbosity_Level > Opt.Low then 2626 Put (" Checking "); 2627 Put (Source_Path); 2628 2629 if Source.Index /= 0 then 2630 Put (" at"); 2631 Put (Source.Index'Img); 2632 end if; 2633 2634 Put_Line (" ... "); 2635 end if; 2636 2637 -- No need to compile if project is externally built 2638 2639 if Externally_Built then 2640 if Verbose_Mode then 2641 Put_Line (" project is externally built"); 2642 end if; 2643 2644 Must_Compile := False; 2645 Cleanup; 2646 return; 2647 end if; 2648 2649 if not Source.Language.Config.Object_Generated then 2650 -- If no object file is generated, the "compiler" need to be invoked 2651 -- if there is no dependency file. 2652 2653 if Source.Language.Config.Dependency_Kind = None then 2654 if Verbose_Mode then 2655 Put_Line (" -> no object file generated"); 2656 end if; 2657 2658 Must_Compile := True; 2659 Cleanup; 2660 return; 2661 end if; 2662 2663 elsif Object_Check then 2664 -- If object file does not exist, of course source need to be 2665 -- compiled. 2666 2667 if Source.Object_TS = Empty_Time_Stamp then 2668 if Verbose_Mode then 2669 Put (" -> object file "); 2670 Put (Object_Path.all); 2671 Put_Line (" does not exist"); 2672 end if; 2673 2674 Must_Compile := True; 2675 Cleanup; 2676 return; 2677 end if; 2678 2679 -- If the object file has been created before the last modification 2680 -- of the source, the source need to be recompiled. 2681 2682 if (not Opt.Minimal_Recompilation) 2683 and then Source.Object_TS < Source.Source_TS 2684 then 2685 if Verbose_Mode then 2686 Put (" -> object file "); 2687 Put (Object_Path.all); 2688 Put_Line (" has time stamp earlier than source"); 2689 end if; 2690 2691 Must_Compile := True; 2692 Cleanup; 2693 return; 2694 end if; 2695 2696 if Verbose_Mode and then Debug.Debug_Flag_T then 2697 Put (" object file "); 2698 Put (Object_Path.all); 2699 Put (": "); 2700 Put_Line (String (Source.Object_TS)); 2701 2702 Put (" source file: "); 2703 Put_Line (String (Source.Source_TS)); 2704 end if; 2705 end if; 2706 2707 if Source.Language.Config.Dependency_Kind /= None then 2708 2709 -- If there is no dependency file, then the source needs to be 2710 -- recompiled and the dependency file need to be created. 2711 2712 Stamp := File_Time_Stamp (Source.Dep_Path, Source.Dep_TS'Access); 2713 2714 if Stamp = Empty_Time_Stamp then 2715 if Verbose_Mode then 2716 Put (" -> dependency file "); 2717 Put (Get_Name_String (Source.Dep_Path)); 2718 Put_Line (" does not exist"); 2719 end if; 2720 2721 Must_Compile := True; 2722 Cleanup; 2723 return; 2724 end if; 2725 2726 -- If the ALI file has been created after the object file, we need 2727 -- to recompile. 2728 2729 if Object_Check 2730 and then 2731 (Source.Language.Config.Dependency_Kind = ALI_File 2732 or else Source.Language.Config.Dependency_Kind = ALI_Closure) 2733 and then 2734 Source.Object_TS < Stamp 2735 then 2736 if Verbose_Mode then 2737 Put (" -> ALI file "); 2738 Put (Get_Name_String (Source.Dep_Path)); 2739 Put_Line (" has timestamp earlier than object file"); 2740 end if; 2741 2742 Must_Compile := True; 2743 Cleanup; 2744 return; 2745 end if; 2746 2747 -- The source needs to be recompiled if the source has been modified 2748 -- after the dependency file has been created. 2749 2750 if not Opt.Minimal_Recompilation 2751 and then Stamp < Source.Source_TS 2752 then 2753 if Verbose_Mode then 2754 Put (" -> dependency file "); 2755 Put (Get_Name_String (Source.Dep_Path)); 2756 Put_Line (" has time stamp earlier than source"); 2757 end if; 2758 2759 Must_Compile := True; 2760 Cleanup; 2761 return; 2762 end if; 2763 end if; 2764 2765 -- If we are checking the switches and there is no switches file, then 2766 -- the source needs to be recompiled and the switches file need to be 2767 -- created. 2768 2769 if Check_Switches and then Switches_Name /= null then 2770 if Source.Switches_TS = Empty_Time_Stamp then 2771 if Verbose_Mode then 2772 Put (" -> switches file "); 2773 Put (Switches_Name.all); 2774 Put_Line (" does not exist"); 2775 end if; 2776 2777 Must_Compile := True; 2778 Cleanup; 2779 return; 2780 end if; 2781 2782 -- The source needs to be recompiled if the source has been modified 2783 -- after the switches file has been created. 2784 2785 if not Opt.Minimal_Recompilation 2786 and then Source.Switches_TS < Source.Source_TS 2787 then 2788 if Verbose_Mode then 2789 Put (" -> switches file "); 2790 Put (Switches_Name.all); 2791 Put_Line (" has time stamp earlier than source"); 2792 end if; 2793 2794 Must_Compile := True; 2795 Cleanup; 2796 return; 2797 end if; 2798 end if; 2799 2800 case Source.Language.Config.Dependency_Kind is 2801 when None => 2802 null; 2803 2804 when Makefile => 2805 if Process_Makefile_Deps 2806 (Get_Name_String (Source.Dep_Path), 2807 Get_Name_String 2808 (Source.Project.Object_Directory.Display_Name)) 2809 then 2810 Must_Compile := True; 2811 Cleanup; 2812 return; 2813 end if; 2814 2815 when ALI_File => 2816 if Process_ALI_Deps then 2817 Must_Compile := True; 2818 Cleanup; 2819 return; 2820 end if; 2821 2822 when ALI_Closure => 2823 if Process_ALI_Closure_Deps then 2824 Must_Compile := True; 2825 Cleanup; 2826 return; 2827 end if; 2828 end case; 2829 2830 -- If we are here, then everything is OK, and we don't need 2831 -- to recompile. 2832 2833 if (not Object_Check) and then Verbose_Mode then 2834 Put_Line (" -> up to date"); 2835 end if; 2836 2837 Must_Compile := False; 2838 Cleanup; 2839 end Need_To_Compile; 2840 2841 --------------------------- 2842 -- Set_Default_Verbosity -- 2843 --------------------------- 2844 2845 procedure Set_Default_Verbosity is 2846 Gpr_Verbosity : String_Access := Getenv ("GPR_VERBOSITY"); 2847 begin 2848 if Gpr_Verbosity /= null and then Gpr_Verbosity'Length > 0 then 2849 declare 2850 Verbosity : String := Gpr_Verbosity.all; 2851 begin 2852 To_Lower (Verbosity); 2853 2854 if Verbosity = "quiet" then 2855 Quiet_Output := True; 2856 Verbose_Mode := False; 2857 2858 elsif Verbosity = "default" then 2859 Quiet_Output := False; 2860 Verbose_Mode := False; 2861 2862 elsif Verbosity = "verbose" or else Verbosity = "verbose_high" then 2863 Quiet_Output := False; 2864 Verbose_Mode := True; 2865 Verbosity_Level := Opt.High; 2866 2867 elsif Verbosity = "verbose_medium" then 2868 Quiet_Output := False; 2869 Verbose_Mode := True; 2870 Verbosity_Level := Opt.Medium; 2871 2872 elsif Verbosity = "verbose_low" then 2873 Quiet_Output := False; 2874 Verbose_Mode := True; 2875 Verbosity_Level := Opt.Low; 2876 end if; 2877 end; 2878 end if; 2879 2880 Free (Gpr_Verbosity); 2881 end Set_Default_Verbosity; 2882 2883 --------------- 2884 -- Knowledge -- 2885 --------------- 2886 2887 package body Knowledge is separate; 2888 2889 -------------- 2890 -- UTC_Time -- 2891 -------------- 2892 2893 function UTC_Time return Time_Stamp_Type is 2894 Now : constant Time := Clock - Duration (UTC_Time_Offset) * 60; 2895 -- The UTC_Time_Offset is in minutes 2896 begin 2897 return Time_Stamp_Type (Image (Now, "%Y%m%d%H%M%S")); 2898 end UTC_Time; 2899 2900 ---------------- 2901 -- Check_Diff -- 2902 ---------------- 2903 2904 function Check_Diff 2905 (Ts1, Ts2 : Time_Stamp_Type; Max_Drift : Duration := 5.0) return Boolean 2906 is 2907 use GNAT.Calendar; 2908 2909 function Get (T : String) return Time is 2910 (Time_Of 2911 (Year => Year_Number'Value (T (T'First .. T'First + 3)), 2912 Month => Month_Number'Value (T (T'First + 4 .. T'First + 5)), 2913 Day => Day_Number'Value (T (T'First + 6 .. T'First + 7)), 2914 Hour => Hour_Number'Value (T (T'First + 8 .. T'First + 9)), 2915 Minute => Minute_Number'Value (T (T'First + 10 .. T'First + 11)), 2916 Second => Second_Number'Value (T (T'First + 12 .. T'First + 13)))); 2917 2918 T1 : constant Time := Get (String (Ts1)); 2919 T2 : constant Time := Get (String (Ts2)); 2920 2921 begin 2922 return abs (T1 - T2) <= Max_Drift; 2923 end Check_Diff; 2924 2925 ------------------- 2926 -- To_Time_Stamp -- 2927 ------------------- 2928 2929 function To_Time_Stamp 2930 (Time : Calendar.Time) return Stamps.Time_Stamp_Type is 2931 begin 2932 return Time_Stamp_Type (Image (Time, "%Y%m%d%H%M%S")); 2933 end To_Time_Stamp; 2934 2935 package body Project_Output is 2936 ---------------- 2937 -- Write_Char -- 2938 ---------------- 2939 procedure Write_A_Char (C : Character) is 2940 begin 2941 Write_A_String ((1 => C)); 2942 end Write_A_Char; 2943 2944 --------------- 2945 -- Write_Eol -- 2946 --------------- 2947 2948 procedure Write_Eol is 2949 begin 2950 Write_A_String ((1 => ASCII.LF)); 2951 end Write_Eol; 2952 2953 -------------------- 2954 -- Write_A_String -- 2955 -------------------- 2956 2957 procedure Write_A_String (S : String) is 2958 Str : String (1 .. S'Length); 2959 2960 begin 2961 if S'Length > 0 then 2962 Str := S; 2963 2964 if Write (Output_FD, Str (1)'Address, Str'Length) /= Str'Length 2965 then 2966 GPR.Com.Fail ("disk full"); 2967 end if; 2968 end if; 2969 end Write_A_String; 2970 2971 end Project_Output; 2972 2973end Gpr_Util; 2974