1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- P R J -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2001-2015, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Opt; 27with Osint; use Osint; 28with Output; use Output; 29with Prj.Attr; 30with Prj.Com; 31with Prj.Err; use Prj.Err; 32with Snames; use Snames; 33with Uintp; use Uintp; 34 35with Ada.Characters.Handling; use Ada.Characters.Handling; 36with Ada.Containers.Ordered_Sets; 37with Ada.Unchecked_Deallocation; 38 39with GNAT.Case_Util; use GNAT.Case_Util; 40with GNAT.Directory_Operations; use GNAT.Directory_Operations; 41with GNAT.HTable; 42 43package body Prj is 44 45 type Restricted_Lang; 46 type Restricted_Lang_Access is access Restricted_Lang; 47 type Restricted_Lang is record 48 Name : Name_Id; 49 Next : Restricted_Lang_Access; 50 end record; 51 52 Restricted_Languages : Restricted_Lang_Access := null; 53 -- When null, all languages are allowed, otherwise only the languages in 54 -- the list are allowed. 55 56 Object_Suffix : constant String := Get_Target_Object_Suffix.all; 57 -- File suffix for object files 58 59 Initial_Buffer_Size : constant := 100; 60 -- Initial size for extensible buffer used in Add_To_Buffer 61 62 The_Empty_String : Name_Id := No_Name; 63 The_Dot_String : Name_Id := No_Name; 64 65 Debug_Level : Integer := 0; 66 -- Current indentation level for debug traces 67 68 type Cst_String_Access is access constant String; 69 70 All_Lower_Case_Image : aliased constant String := "lowercase"; 71 All_Upper_Case_Image : aliased constant String := "UPPERCASE"; 72 Mixed_Case_Image : aliased constant String := "MixedCase"; 73 74 The_Casing_Images : constant array (Known_Casing) of Cst_String_Access := 75 (All_Lower_Case => All_Lower_Case_Image'Access, 76 All_Upper_Case => All_Upper_Case_Image'Access, 77 Mixed_Case => Mixed_Case_Image'Access); 78 79 package Name_Id_Set is 80 new Ada.Containers.Ordered_Sets (Element_Type => Name_Id); 81 82 procedure Free (Project : in out Project_Id); 83 -- Free memory allocated for Project 84 85 procedure Free_List (Languages : in out Language_Ptr); 86 procedure Free_List (Source : in out Source_Id); 87 procedure Free_List (Languages : in out Language_List); 88 -- Free memory allocated for the list of languages or sources 89 90 procedure Reset_Units_In_Table (Table : in out Units_Htable.Instance); 91 -- Resets all Units to No_Unit_Index Unit.File_Names (Spec).Unit & 92 -- Unit.File_Names (Impl).Unit in the given table. 93 94 procedure Free_Units (Table : in out Units_Htable.Instance); 95 -- Free memory allocated for unit information in the project 96 97 procedure Language_Changed (Iter : in out Source_Iterator); 98 procedure Project_Changed (Iter : in out Source_Iterator); 99 -- Called when a new project or language was selected for this iterator 100 101 function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean; 102 -- Return True if there is at least one ALI file in the directory Dir 103 104 ----------------------------- 105 -- Add_Restricted_Language -- 106 ----------------------------- 107 108 procedure Add_Restricted_Language (Name : String) is 109 N : String (1 .. Name'Length) := Name; 110 begin 111 To_Lower (N); 112 Name_Len := 0; 113 Add_Str_To_Name_Buffer (N); 114 Restricted_Languages := 115 new Restricted_Lang'(Name => Name_Find, Next => Restricted_Languages); 116 end Add_Restricted_Language; 117 118 ------------------------------------- 119 -- Remove_All_Restricted_Languages -- 120 ------------------------------------- 121 122 procedure Remove_All_Restricted_Languages is 123 begin 124 Restricted_Languages := null; 125 end Remove_All_Restricted_Languages; 126 127 ------------------- 128 -- Add_To_Buffer -- 129 ------------------- 130 131 procedure Add_To_Buffer 132 (S : String; 133 To : in out String_Access; 134 Last : in out Natural) 135 is 136 begin 137 if To = null then 138 To := new String (1 .. Initial_Buffer_Size); 139 Last := 0; 140 end if; 141 142 -- If Buffer is too small, double its size 143 144 while Last + S'Length > To'Last loop 145 declare 146 New_Buffer : constant String_Access := 147 new String (1 .. 2 * To'Length); 148 begin 149 New_Buffer (1 .. Last) := To (1 .. Last); 150 Free (To); 151 To := New_Buffer; 152 end; 153 end loop; 154 155 To (Last + 1 .. Last + S'Length) := S; 156 Last := Last + S'Length; 157 end Add_To_Buffer; 158 159 --------------------------------- 160 -- Current_Object_Path_File_Of -- 161 --------------------------------- 162 163 function Current_Object_Path_File_Of 164 (Shared : Shared_Project_Tree_Data_Access) return Path_Name_Type 165 is 166 begin 167 return Shared.Private_Part.Current_Object_Path_File; 168 end Current_Object_Path_File_Of; 169 170 --------------------------------- 171 -- Current_Source_Path_File_Of -- 172 --------------------------------- 173 174 function Current_Source_Path_File_Of 175 (Shared : Shared_Project_Tree_Data_Access) 176 return Path_Name_Type is 177 begin 178 return Shared.Private_Part.Current_Source_Path_File; 179 end Current_Source_Path_File_Of; 180 181 --------------------------- 182 -- Delete_Temporary_File -- 183 --------------------------- 184 185 procedure Delete_Temporary_File 186 (Shared : Shared_Project_Tree_Data_Access := null; 187 Path : Path_Name_Type) 188 is 189 Dont_Care : Boolean; 190 pragma Warnings (Off, Dont_Care); 191 192 begin 193 if not Opt.Keep_Temporary_Files then 194 if Current_Verbosity = High then 195 Write_Line ("Removing temp file: " & Get_Name_String (Path)); 196 end if; 197 198 Delete_File (Get_Name_String (Path), Dont_Care); 199 200 if Shared /= null then 201 for Index in 202 1 .. Temp_Files_Table.Last (Shared.Private_Part.Temp_Files) 203 loop 204 if Shared.Private_Part.Temp_Files.Table (Index) = Path then 205 Shared.Private_Part.Temp_Files.Table (Index) := No_Path; 206 end if; 207 end loop; 208 end if; 209 end if; 210 end Delete_Temporary_File; 211 212 ------------------------------ 213 -- Delete_Temp_Config_Files -- 214 ------------------------------ 215 216 procedure Delete_Temp_Config_Files (Project_Tree : Project_Tree_Ref) is 217 Success : Boolean; 218 pragma Warnings (Off, Success); 219 220 Proj : Project_List; 221 222 begin 223 if not Opt.Keep_Temporary_Files then 224 if Project_Tree /= null then 225 Proj := Project_Tree.Projects; 226 while Proj /= null loop 227 if Proj.Project.Config_File_Temp then 228 Delete_Temporary_File 229 (Project_Tree.Shared, Proj.Project.Config_File_Name); 230 231 -- Make sure that we don't have a config file for this 232 -- project, in case there are several mains. In this case, 233 -- we will recreate another config file: we cannot reuse the 234 -- one that we just deleted. 235 236 Proj.Project.Config_Checked := False; 237 Proj.Project.Config_File_Name := No_Path; 238 Proj.Project.Config_File_Temp := False; 239 end if; 240 241 Proj := Proj.Next; 242 end loop; 243 end if; 244 end if; 245 end Delete_Temp_Config_Files; 246 247 --------------------------- 248 -- Delete_All_Temp_Files -- 249 --------------------------- 250 251 procedure Delete_All_Temp_Files 252 (Shared : Shared_Project_Tree_Data_Access) 253 is 254 Dont_Care : Boolean; 255 pragma Warnings (Off, Dont_Care); 256 257 Path : Path_Name_Type; 258 259 begin 260 if not Opt.Keep_Temporary_Files then 261 for Index in 262 1 .. Temp_Files_Table.Last (Shared.Private_Part.Temp_Files) 263 loop 264 Path := Shared.Private_Part.Temp_Files.Table (Index); 265 266 if Path /= No_Path then 267 if Current_Verbosity = High then 268 Write_Line ("Removing temp file: " 269 & Get_Name_String (Path)); 270 end if; 271 272 Delete_File (Get_Name_String (Path), Dont_Care); 273 end if; 274 end loop; 275 276 Temp_Files_Table.Free (Shared.Private_Part.Temp_Files); 277 Temp_Files_Table.Init (Shared.Private_Part.Temp_Files); 278 end if; 279 280 -- If any of the environment variables ADA_PRJ_INCLUDE_FILE or 281 -- ADA_PRJ_OBJECTS_FILE has been set, then reset their value to 282 -- the empty string. 283 284 if Shared.Private_Part.Current_Source_Path_File /= No_Path then 285 Setenv (Project_Include_Path_File, ""); 286 end if; 287 288 if Shared.Private_Part.Current_Object_Path_File /= No_Path then 289 Setenv (Project_Objects_Path_File, ""); 290 end if; 291 end Delete_All_Temp_Files; 292 293 --------------------- 294 -- Dependency_Name -- 295 --------------------- 296 297 function Dependency_Name 298 (Source_File_Name : File_Name_Type; 299 Dependency : Dependency_File_Kind) return File_Name_Type 300 is 301 begin 302 case Dependency is 303 when None => 304 return No_File; 305 306 when Makefile => 307 return Extend_Name (Source_File_Name, Makefile_Dependency_Suffix); 308 309 when ALI_File | ALI_Closure => 310 return Extend_Name (Source_File_Name, ALI_Dependency_Suffix); 311 end case; 312 end Dependency_Name; 313 314 ---------------- 315 -- Dot_String -- 316 ---------------- 317 318 function Dot_String return Name_Id is 319 begin 320 return The_Dot_String; 321 end Dot_String; 322 323 ---------------- 324 -- Empty_File -- 325 ---------------- 326 327 function Empty_File return File_Name_Type is 328 begin 329 return File_Name_Type (The_Empty_String); 330 end Empty_File; 331 332 ------------------- 333 -- Empty_Project -- 334 ------------------- 335 336 function Empty_Project 337 (Qualifier : Project_Qualifier) return Project_Data 338 is 339 begin 340 Prj.Initialize (Tree => No_Project_Tree); 341 342 declare 343 Data : Project_Data (Qualifier => Qualifier); 344 345 begin 346 -- Only the fields for which no default value could be provided in 347 -- prj.ads are initialized below. 348 349 Data.Config := Default_Project_Config; 350 return Data; 351 end; 352 end Empty_Project; 353 354 ------------------ 355 -- Empty_String -- 356 ------------------ 357 358 function Empty_String return Name_Id is 359 begin 360 return The_Empty_String; 361 end Empty_String; 362 363 ------------ 364 -- Expect -- 365 ------------ 366 367 procedure Expect (The_Token : Token_Type; Token_Image : String) is 368 begin 369 if Token /= The_Token then 370 371 -- ??? Should pass user flags here instead 372 373 Error_Msg (Gnatmake_Flags, Token_Image & " expected", Token_Ptr); 374 end if; 375 end Expect; 376 377 ----------------- 378 -- Extend_Name -- 379 ----------------- 380 381 function Extend_Name 382 (File : File_Name_Type; 383 With_Suffix : String) return File_Name_Type 384 is 385 Last : Positive; 386 387 begin 388 Get_Name_String (File); 389 Last := Name_Len + 1; 390 391 while Name_Len /= 0 and then Name_Buffer (Name_Len) /= '.' loop 392 Name_Len := Name_Len - 1; 393 end loop; 394 395 if Name_Len <= 1 then 396 Name_Len := Last; 397 end if; 398 399 for J in With_Suffix'Range loop 400 Name_Buffer (Name_Len) := With_Suffix (J); 401 Name_Len := Name_Len + 1; 402 end loop; 403 404 Name_Len := Name_Len - 1; 405 return Name_Find; 406 end Extend_Name; 407 408 ------------------------- 409 -- Is_Allowed_Language -- 410 ------------------------- 411 412 function Is_Allowed_Language (Name : Name_Id) return Boolean is 413 R : Restricted_Lang_Access := Restricted_Languages; 414 Lang : constant String := Get_Name_String (Name); 415 416 begin 417 if R = null then 418 return True; 419 420 else 421 while R /= null loop 422 if Get_Name_String (R.Name) = Lang then 423 return True; 424 end if; 425 426 R := R.Next; 427 end loop; 428 429 return False; 430 end if; 431 end Is_Allowed_Language; 432 433 --------------------- 434 -- Project_Changed -- 435 --------------------- 436 437 procedure Project_Changed (Iter : in out Source_Iterator) is 438 begin 439 if Iter.Project /= null then 440 Iter.Language := Iter.Project.Project.Languages; 441 Language_Changed (Iter); 442 end if; 443 end Project_Changed; 444 445 ---------------------- 446 -- Language_Changed -- 447 ---------------------- 448 449 procedure Language_Changed (Iter : in out Source_Iterator) is 450 begin 451 Iter.Current := No_Source; 452 453 if Iter.Language_Name /= No_Name then 454 while Iter.Language /= null 455 and then Iter.Language.Name /= Iter.Language_Name 456 loop 457 Iter.Language := Iter.Language.Next; 458 end loop; 459 end if; 460 461 -- If there is no matching language in this project, move to next 462 463 if Iter.Language = No_Language_Index then 464 if Iter.All_Projects then 465 loop 466 Iter.Project := Iter.Project.Next; 467 exit when Iter.Project = null 468 or else Iter.Encapsulated_Libs 469 or else not Iter.Project.From_Encapsulated_Lib; 470 end loop; 471 472 Project_Changed (Iter); 473 else 474 Iter.Project := null; 475 end if; 476 477 else 478 Iter.Current := Iter.Language.First_Source; 479 480 if Iter.Current = No_Source then 481 Iter.Language := Iter.Language.Next; 482 Language_Changed (Iter); 483 484 elsif not Iter.Locally_Removed 485 and then Iter.Current.Locally_Removed 486 then 487 Next (Iter); 488 end if; 489 end if; 490 end Language_Changed; 491 492 --------------------- 493 -- For_Each_Source -- 494 --------------------- 495 496 function For_Each_Source 497 (In_Tree : Project_Tree_Ref; 498 Project : Project_Id := No_Project; 499 Language : Name_Id := No_Name; 500 Encapsulated_Libs : Boolean := True; 501 Locally_Removed : Boolean := True) return Source_Iterator 502 is 503 Iter : Source_Iterator; 504 begin 505 Iter := Source_Iterator' 506 (In_Tree => In_Tree, 507 Project => In_Tree.Projects, 508 All_Projects => Project = No_Project, 509 Language_Name => Language, 510 Language => No_Language_Index, 511 Current => No_Source, 512 Encapsulated_Libs => Encapsulated_Libs, 513 Locally_Removed => Locally_Removed); 514 515 if Project /= null then 516 while Iter.Project /= null 517 and then Iter.Project.Project /= Project 518 loop 519 Iter.Project := Iter.Project.Next; 520 end loop; 521 522 else 523 while not Iter.Encapsulated_Libs 524 and then Iter.Project.From_Encapsulated_Lib 525 loop 526 Iter.Project := Iter.Project.Next; 527 end loop; 528 end if; 529 530 Project_Changed (Iter); 531 532 return Iter; 533 end For_Each_Source; 534 535 ------------- 536 -- Element -- 537 ------------- 538 539 function Element (Iter : Source_Iterator) return Source_Id is 540 begin 541 return Iter.Current; 542 end Element; 543 544 ---------- 545 -- Next -- 546 ---------- 547 548 procedure Next (Iter : in out Source_Iterator) is 549 begin 550 loop 551 Iter.Current := Iter.Current.Next_In_Lang; 552 553 exit when Iter.Locally_Removed 554 or else Iter.Current = No_Source 555 or else not Iter.Current.Locally_Removed; 556 end loop; 557 558 if Iter.Current = No_Source then 559 Iter.Language := Iter.Language.Next; 560 Language_Changed (Iter); 561 end if; 562 end Next; 563 564 -------------------------------- 565 -- For_Every_Project_Imported -- 566 -------------------------------- 567 568 procedure For_Every_Project_Imported_Context 569 (By : Project_Id; 570 Tree : Project_Tree_Ref; 571 With_State : in out State; 572 Include_Aggregated : Boolean := True; 573 Imported_First : Boolean := False) 574 is 575 use Project_Boolean_Htable; 576 577 procedure Recursive_Check_Context 578 (Project : Project_Id; 579 Tree : Project_Tree_Ref; 580 In_Aggregate_Lib : Boolean; 581 From_Encapsulated_Lib : Boolean); 582 -- Recursively handle the project tree creating a new context for 583 -- keeping track about already handled projects. 584 585 ----------------------------- 586 -- Recursive_Check_Context -- 587 ----------------------------- 588 589 procedure Recursive_Check_Context 590 (Project : Project_Id; 591 Tree : Project_Tree_Ref; 592 In_Aggregate_Lib : Boolean; 593 From_Encapsulated_Lib : Boolean) 594 is 595 package Name_Id_Set is 596 new Ada.Containers.Ordered_Sets (Element_Type => Path_Name_Type); 597 598 Seen_Name : Name_Id_Set.Set; 599 -- This set is needed to ensure that we do not handle the same 600 -- project twice in the context of aggregate libraries. 601 -- Since duplicate project names are possible in the context of 602 -- aggregated projects, we need to check the full paths. 603 604 procedure Recursive_Check 605 (Project : Project_Id; 606 Tree : Project_Tree_Ref; 607 In_Aggregate_Lib : Boolean; 608 From_Encapsulated_Lib : Boolean); 609 -- Check if project has already been seen. If not, mark it as Seen, 610 -- Call Action, and check all its imported and aggregated projects. 611 612 --------------------- 613 -- Recursive_Check -- 614 --------------------- 615 616 procedure Recursive_Check 617 (Project : Project_Id; 618 Tree : Project_Tree_Ref; 619 In_Aggregate_Lib : Boolean; 620 From_Encapsulated_Lib : Boolean) 621 is 622 623 function Has_Sources (P : Project_Id) return Boolean; 624 -- Returns True if P has sources 625 626 function Get_From_Tree (P : Project_Id) return Project_Id; 627 -- Get project P from Tree. If P has no sources get another 628 -- instance of this project with sources. If P has sources, 629 -- returns it. 630 631 ----------------- 632 -- Has_Sources -- 633 ----------------- 634 635 function Has_Sources (P : Project_Id) return Boolean is 636 Lang : Language_Ptr; 637 638 begin 639 Lang := P.Languages; 640 while Lang /= No_Language_Index loop 641 if Lang.First_Source /= No_Source then 642 return True; 643 end if; 644 645 Lang := Lang.Next; 646 end loop; 647 648 return False; 649 end Has_Sources; 650 651 ------------------- 652 -- Get_From_Tree -- 653 ------------------- 654 655 function Get_From_Tree (P : Project_Id) return Project_Id is 656 List : Project_List := Tree.Projects; 657 658 begin 659 if not Has_Sources (P) then 660 while List /= null loop 661 if List.Project.Name = P.Name 662 and then Has_Sources (List.Project) 663 then 664 return List.Project; 665 end if; 666 667 List := List.Next; 668 end loop; 669 end if; 670 671 return P; 672 end Get_From_Tree; 673 674 -- Local variables 675 676 List : Project_List; 677 678 -- Start of processing for Recursive_Check 679 680 begin 681 if not Seen_Name.Contains (Project.Path.Name) then 682 683 -- Even if a project is aggregated multiple times in an 684 -- aggregated library, we will only return it once. 685 686 Seen_Name.Include (Project.Path.Name); 687 688 if not Imported_First then 689 Action 690 (Get_From_Tree (Project), 691 Tree, 692 Project_Context'(In_Aggregate_Lib, From_Encapsulated_Lib), 693 With_State); 694 end if; 695 696 -- Visit all extended projects 697 698 if Project.Extends /= No_Project then 699 Recursive_Check 700 (Project.Extends, Tree, 701 In_Aggregate_Lib, From_Encapsulated_Lib); 702 end if; 703 704 -- Visit all imported projects 705 706 List := Project.Imported_Projects; 707 while List /= null loop 708 Recursive_Check 709 (List.Project, Tree, 710 In_Aggregate_Lib, 711 From_Encapsulated_Lib 712 or else Project.Standalone_Library = Encapsulated); 713 List := List.Next; 714 end loop; 715 716 -- Visit all aggregated projects 717 718 if Include_Aggregated 719 and then Project.Qualifier in Aggregate_Project 720 then 721 declare 722 Agg : Aggregated_Project_List; 723 724 begin 725 Agg := Project.Aggregated_Projects; 726 while Agg /= null loop 727 pragma Assert (Agg.Project /= No_Project); 728 729 -- For aggregated libraries, the tree must be the one 730 -- of the aggregate library. 731 732 if Project.Qualifier = Aggregate_Library then 733 Recursive_Check 734 (Agg.Project, Tree, 735 True, 736 From_Encapsulated_Lib 737 or else 738 Project.Standalone_Library = Encapsulated); 739 740 else 741 -- Use a new context as we want to returns the same 742 -- project in different project tree for aggregated 743 -- projects. 744 745 Recursive_Check_Context 746 (Agg.Project, Agg.Tree, False, False); 747 end if; 748 749 Agg := Agg.Next; 750 end loop; 751 end; 752 end if; 753 754 if Imported_First then 755 Action 756 (Get_From_Tree (Project), 757 Tree, 758 Project_Context'(In_Aggregate_Lib, From_Encapsulated_Lib), 759 With_State); 760 end if; 761 end if; 762 end Recursive_Check; 763 764 -- Start of processing for Recursive_Check_Context 765 766 begin 767 Recursive_Check 768 (Project, Tree, In_Aggregate_Lib, From_Encapsulated_Lib); 769 end Recursive_Check_Context; 770 771 -- Start of processing for For_Every_Project_Imported 772 773 begin 774 Recursive_Check_Context 775 (Project => By, 776 Tree => Tree, 777 In_Aggregate_Lib => False, 778 From_Encapsulated_Lib => False); 779 end For_Every_Project_Imported_Context; 780 781 procedure For_Every_Project_Imported 782 (By : Project_Id; 783 Tree : Project_Tree_Ref; 784 With_State : in out State; 785 Include_Aggregated : Boolean := True; 786 Imported_First : Boolean := False) 787 is 788 procedure Internal 789 (Project : Project_Id; 790 Tree : Project_Tree_Ref; 791 Context : Project_Context; 792 With_State : in out State); 793 -- Action wrapper for handling the context 794 795 -------------- 796 -- Internal -- 797 -------------- 798 799 procedure Internal 800 (Project : Project_Id; 801 Tree : Project_Tree_Ref; 802 Context : Project_Context; 803 With_State : in out State) 804 is 805 pragma Unreferenced (Context); 806 begin 807 Action (Project, Tree, With_State); 808 end Internal; 809 810 procedure For_Projects is 811 new For_Every_Project_Imported_Context (State, Internal); 812 813 begin 814 For_Projects (By, Tree, With_State, Include_Aggregated, Imported_First); 815 end For_Every_Project_Imported; 816 817 ----------------- 818 -- Find_Source -- 819 ----------------- 820 821 function Find_Source 822 (In_Tree : Project_Tree_Ref; 823 Project : Project_Id; 824 In_Imported_Only : Boolean := False; 825 In_Extended_Only : Boolean := False; 826 Base_Name : File_Name_Type; 827 Index : Int := 0) return Source_Id 828 is 829 Result : Source_Id := No_Source; 830 831 procedure Look_For_Sources 832 (Proj : Project_Id; 833 Tree : Project_Tree_Ref; 834 Src : in out Source_Id); 835 -- Look for Base_Name in the sources of Proj 836 837 ---------------------- 838 -- Look_For_Sources -- 839 ---------------------- 840 841 procedure Look_For_Sources 842 (Proj : Project_Id; 843 Tree : Project_Tree_Ref; 844 Src : in out Source_Id) 845 is 846 Iterator : Source_Iterator; 847 848 begin 849 Iterator := For_Each_Source (In_Tree => Tree, Project => Proj); 850 while Element (Iterator) /= No_Source loop 851 if Element (Iterator).File = Base_Name 852 and then (Index = 0 or else Element (Iterator).Index = Index) 853 then 854 Src := Element (Iterator); 855 856 -- If the source has been excluded, continue looking. We will 857 -- get the excluded source only if there is no other source 858 -- with the same base name that is not locally removed. 859 860 if not Element (Iterator).Locally_Removed then 861 return; 862 end if; 863 end if; 864 865 Next (Iterator); 866 end loop; 867 end Look_For_Sources; 868 869 procedure For_Imported_Projects is new For_Every_Project_Imported 870 (State => Source_Id, Action => Look_For_Sources); 871 872 Proj : Project_Id; 873 874 -- Start of processing for Find_Source 875 876 begin 877 if In_Extended_Only then 878 Proj := Project; 879 while Proj /= No_Project loop 880 Look_For_Sources (Proj, In_Tree, Result); 881 exit when Result /= No_Source; 882 883 Proj := Proj.Extends; 884 end loop; 885 886 elsif In_Imported_Only then 887 Look_For_Sources (Project, In_Tree, Result); 888 889 if Result = No_Source then 890 For_Imported_Projects 891 (By => Project, 892 Tree => In_Tree, 893 Include_Aggregated => False, 894 With_State => Result); 895 end if; 896 897 else 898 Look_For_Sources (No_Project, In_Tree, Result); 899 end if; 900 901 return Result; 902 end Find_Source; 903 904 ---------------------- 905 -- Find_All_Sources -- 906 ---------------------- 907 908 function Find_All_Sources 909 (In_Tree : Project_Tree_Ref; 910 Project : Project_Id; 911 In_Imported_Only : Boolean := False; 912 In_Extended_Only : Boolean := False; 913 Base_Name : File_Name_Type; 914 Index : Int := 0) return Source_Ids 915 is 916 Result : Source_Ids (1 .. 1_000); 917 Last : Natural := 0; 918 919 type Empty_State is null record; 920 No_State : Empty_State; 921 -- This is needed for the State parameter of procedure Look_For_Sources 922 -- below, because of the instantiation For_Imported_Projects of generic 923 -- procedure For_Every_Project_Imported. As procedure Look_For_Sources 924 -- does not modify parameter State, there is no need to give its type 925 -- more than one value. 926 927 procedure Look_For_Sources 928 (Proj : Project_Id; 929 Tree : Project_Tree_Ref; 930 State : in out Empty_State); 931 -- Look for Base_Name in the sources of Proj 932 933 ---------------------- 934 -- Look_For_Sources -- 935 ---------------------- 936 937 procedure Look_For_Sources 938 (Proj : Project_Id; 939 Tree : Project_Tree_Ref; 940 State : in out Empty_State) 941 is 942 Iterator : Source_Iterator; 943 Src : Source_Id; 944 945 begin 946 State := No_State; 947 948 Iterator := For_Each_Source (In_Tree => Tree, Project => Proj); 949 while Element (Iterator) /= No_Source loop 950 if Element (Iterator).File = Base_Name 951 and then (Index = 0 952 or else 953 (Element (Iterator).Unit /= No_Unit_Index 954 and then 955 Element (Iterator).Index = Index)) 956 then 957 Src := Element (Iterator); 958 959 -- If the source has been excluded, continue looking. We will 960 -- get the excluded source only if there is no other source 961 -- with the same base name that is not locally removed. 962 963 if not Element (Iterator).Locally_Removed then 964 Last := Last + 1; 965 Result (Last) := Src; 966 end if; 967 end if; 968 969 Next (Iterator); 970 end loop; 971 end Look_For_Sources; 972 973 procedure For_Imported_Projects is new For_Every_Project_Imported 974 (State => Empty_State, Action => Look_For_Sources); 975 976 Proj : Project_Id; 977 978 -- Start of processing for Find_All_Sources 979 980 begin 981 if In_Extended_Only then 982 Proj := Project; 983 while Proj /= No_Project loop 984 Look_For_Sources (Proj, In_Tree, No_State); 985 exit when Last > 0; 986 Proj := Proj.Extends; 987 end loop; 988 989 elsif In_Imported_Only then 990 Look_For_Sources (Project, In_Tree, No_State); 991 992 if Last = 0 then 993 For_Imported_Projects 994 (By => Project, 995 Tree => In_Tree, 996 Include_Aggregated => False, 997 With_State => No_State); 998 end if; 999 1000 else 1001 Look_For_Sources (No_Project, In_Tree, No_State); 1002 end if; 1003 1004 return Result (1 .. Last); 1005 end Find_All_Sources; 1006 1007 ---------- 1008 -- Hash -- 1009 ---------- 1010 1011 function Hash is new GNAT.HTable.Hash (Header_Num => Header_Num); 1012 -- Used in implementation of other functions Hash below 1013 1014 ---------- 1015 -- Hash -- 1016 ---------- 1017 1018 function Hash (Name : File_Name_Type) return Header_Num is 1019 begin 1020 return Hash (Get_Name_String (Name)); 1021 end Hash; 1022 1023 function Hash (Name : Name_Id) return Header_Num is 1024 begin 1025 return Hash (Get_Name_String (Name)); 1026 end Hash; 1027 1028 function Hash (Name : Path_Name_Type) return Header_Num is 1029 begin 1030 return Hash (Get_Name_String (Name)); 1031 end Hash; 1032 1033 function Hash (Project : Project_Id) return Header_Num is 1034 begin 1035 if Project = No_Project then 1036 return Header_Num'First; 1037 else 1038 return Hash (Get_Name_String (Project.Name)); 1039 end if; 1040 end Hash; 1041 1042 ----------- 1043 -- Image -- 1044 ----------- 1045 1046 function Image (The_Casing : Casing_Type) return String is 1047 begin 1048 return The_Casing_Images (The_Casing).all; 1049 end Image; 1050 1051 ----------------------------- 1052 -- Is_Standard_GNAT_Naming -- 1053 ----------------------------- 1054 1055 function Is_Standard_GNAT_Naming 1056 (Naming : Lang_Naming_Data) return Boolean 1057 is 1058 begin 1059 return Get_Name_String (Naming.Spec_Suffix) = ".ads" 1060 and then Get_Name_String (Naming.Body_Suffix) = ".adb" 1061 and then Get_Name_String (Naming.Dot_Replacement) = "-"; 1062 end Is_Standard_GNAT_Naming; 1063 1064 ---------------- 1065 -- Initialize -- 1066 ---------------- 1067 1068 procedure Initialize (Tree : Project_Tree_Ref) is 1069 begin 1070 if The_Empty_String = No_Name then 1071 Uintp.Initialize; 1072 Name_Len := 0; 1073 The_Empty_String := Name_Find; 1074 1075 Name_Len := 1; 1076 Name_Buffer (1) := '.'; 1077 The_Dot_String := Name_Find; 1078 1079 Prj.Attr.Initialize; 1080 1081 -- Make sure that new reserved words after Ada 95 may be used as 1082 -- identifiers. 1083 1084 Opt.Ada_Version := Opt.Ada_95; 1085 Opt.Ada_Version_Pragma := Empty; 1086 1087 Set_Name_Table_Byte (Name_Project, Token_Type'Pos (Tok_Project)); 1088 Set_Name_Table_Byte (Name_Extends, Token_Type'Pos (Tok_Extends)); 1089 Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External)); 1090 Set_Name_Table_Byte 1091 (Name_External_As_List, Token_Type'Pos (Tok_External_As_List)); 1092 end if; 1093 1094 if Tree /= No_Project_Tree then 1095 Reset (Tree); 1096 end if; 1097 end Initialize; 1098 1099 ------------------ 1100 -- Is_Extending -- 1101 ------------------ 1102 1103 function Is_Extending 1104 (Extending : Project_Id; 1105 Extended : Project_Id) return Boolean 1106 is 1107 Proj : Project_Id; 1108 1109 begin 1110 Proj := Extending; 1111 while Proj /= No_Project loop 1112 if Proj = Extended then 1113 return True; 1114 end if; 1115 1116 Proj := Proj.Extends; 1117 end loop; 1118 1119 return False; 1120 end Is_Extending; 1121 1122 ----------------- 1123 -- Object_Name -- 1124 ----------------- 1125 1126 function Object_Name 1127 (Source_File_Name : File_Name_Type; 1128 Object_File_Suffix : Name_Id := No_Name) return File_Name_Type 1129 is 1130 begin 1131 if Object_File_Suffix = No_Name then 1132 return Extend_Name 1133 (Source_File_Name, Object_Suffix); 1134 else 1135 return Extend_Name 1136 (Source_File_Name, Get_Name_String (Object_File_Suffix)); 1137 end if; 1138 end Object_Name; 1139 1140 function Object_Name 1141 (Source_File_Name : File_Name_Type; 1142 Source_Index : Int; 1143 Index_Separator : Character; 1144 Object_File_Suffix : Name_Id := No_Name) return File_Name_Type 1145 is 1146 Index_Img : constant String := Source_Index'Img; 1147 Last : Natural; 1148 1149 begin 1150 Get_Name_String (Source_File_Name); 1151 1152 Last := Name_Len; 1153 while Last > 1 and then Name_Buffer (Last) /= '.' loop 1154 Last := Last - 1; 1155 end loop; 1156 1157 if Last > 1 then 1158 Name_Len := Last - 1; 1159 end if; 1160 1161 Add_Char_To_Name_Buffer (Index_Separator); 1162 Add_Str_To_Name_Buffer (Index_Img (2 .. Index_Img'Last)); 1163 1164 if Object_File_Suffix = No_Name then 1165 Add_Str_To_Name_Buffer (Object_Suffix); 1166 else 1167 Add_Str_To_Name_Buffer (Get_Name_String (Object_File_Suffix)); 1168 end if; 1169 1170 return Name_Find; 1171 end Object_Name; 1172 1173 ---------------------- 1174 -- Record_Temp_File -- 1175 ---------------------- 1176 1177 procedure Record_Temp_File 1178 (Shared : Shared_Project_Tree_Data_Access; 1179 Path : Path_Name_Type) 1180 is 1181 begin 1182 Temp_Files_Table.Append (Shared.Private_Part.Temp_Files, Path); 1183 end Record_Temp_File; 1184 1185 ---------- 1186 -- Free -- 1187 ---------- 1188 1189 procedure Free (List : in out Aggregated_Project_List) is 1190 procedure Unchecked_Free is new Ada.Unchecked_Deallocation 1191 (Aggregated_Project, Aggregated_Project_List); 1192 Tmp : Aggregated_Project_List; 1193 begin 1194 while List /= null loop 1195 Tmp := List.Next; 1196 1197 Free (List.Tree); 1198 1199 Unchecked_Free (List); 1200 List := Tmp; 1201 end loop; 1202 end Free; 1203 1204 ---------------------------- 1205 -- Add_Aggregated_Project -- 1206 ---------------------------- 1207 1208 procedure Add_Aggregated_Project 1209 (Project : Project_Id; 1210 Path : Path_Name_Type) 1211 is 1212 Aggregated : Aggregated_Project_List; 1213 1214 begin 1215 -- Check if the project is already in the aggregated project list. If it 1216 -- is, do not add it again. 1217 1218 Aggregated := Project.Aggregated_Projects; 1219 while Aggregated /= null loop 1220 if Path = Aggregated.Path then 1221 return; 1222 else 1223 Aggregated := Aggregated.Next; 1224 end if; 1225 end loop; 1226 1227 Project.Aggregated_Projects := new Aggregated_Project' 1228 (Path => Path, 1229 Project => No_Project, 1230 Tree => null, 1231 Next => Project.Aggregated_Projects); 1232 end Add_Aggregated_Project; 1233 1234 ---------- 1235 -- Free -- 1236 ---------- 1237 1238 procedure Free (Project : in out Project_Id) is 1239 procedure Unchecked_Free is new Ada.Unchecked_Deallocation 1240 (Project_Data, Project_Id); 1241 1242 begin 1243 if Project /= null then 1244 Free (Project.Ada_Include_Path); 1245 Free (Project.Objects_Path); 1246 Free (Project.Ada_Objects_Path); 1247 Free (Project.Ada_Objects_Path_No_Libs); 1248 Free_List (Project.Imported_Projects, Free_Project => False); 1249 Free_List (Project.All_Imported_Projects, Free_Project => False); 1250 Free_List (Project.Languages); 1251 1252 case Project.Qualifier is 1253 when Aggregate | Aggregate_Library => 1254 Free (Project.Aggregated_Projects); 1255 1256 when others => 1257 null; 1258 end case; 1259 1260 Unchecked_Free (Project); 1261 end if; 1262 end Free; 1263 1264 --------------- 1265 -- Free_List -- 1266 --------------- 1267 1268 procedure Free_List (Languages : in out Language_List) is 1269 procedure Unchecked_Free is new Ada.Unchecked_Deallocation 1270 (Language_List_Element, Language_List); 1271 Tmp : Language_List; 1272 begin 1273 while Languages /= null loop 1274 Tmp := Languages.Next; 1275 Unchecked_Free (Languages); 1276 Languages := Tmp; 1277 end loop; 1278 end Free_List; 1279 1280 --------------- 1281 -- Free_List -- 1282 --------------- 1283 1284 procedure Free_List (Source : in out Source_Id) is 1285 procedure Unchecked_Free is new 1286 Ada.Unchecked_Deallocation (Source_Data, Source_Id); 1287 1288 Tmp : Source_Id; 1289 1290 begin 1291 while Source /= No_Source loop 1292 Tmp := Source.Next_In_Lang; 1293 Free_List (Source.Alternate_Languages); 1294 1295 if Source.Unit /= null 1296 and then Source.Kind in Spec_Or_Body 1297 then 1298 Source.Unit.File_Names (Source.Kind) := null; 1299 end if; 1300 1301 Unchecked_Free (Source); 1302 Source := Tmp; 1303 end loop; 1304 end Free_List; 1305 1306 --------------- 1307 -- Free_List -- 1308 --------------- 1309 1310 procedure Free_List 1311 (List : in out Project_List; 1312 Free_Project : Boolean) 1313 is 1314 procedure Unchecked_Free is new 1315 Ada.Unchecked_Deallocation (Project_List_Element, Project_List); 1316 1317 Tmp : Project_List; 1318 1319 begin 1320 while List /= null loop 1321 Tmp := List.Next; 1322 1323 if Free_Project then 1324 Free (List.Project); 1325 end if; 1326 1327 Unchecked_Free (List); 1328 List := Tmp; 1329 end loop; 1330 end Free_List; 1331 1332 --------------- 1333 -- Free_List -- 1334 --------------- 1335 1336 procedure Free_List (Languages : in out Language_Ptr) is 1337 procedure Unchecked_Free is new 1338 Ada.Unchecked_Deallocation (Language_Data, Language_Ptr); 1339 1340 Tmp : Language_Ptr; 1341 1342 begin 1343 while Languages /= null loop 1344 Tmp := Languages.Next; 1345 Free_List (Languages.First_Source); 1346 Unchecked_Free (Languages); 1347 Languages := Tmp; 1348 end loop; 1349 end Free_List; 1350 1351 -------------------------- 1352 -- Reset_Units_In_Table -- 1353 -------------------------- 1354 1355 procedure Reset_Units_In_Table (Table : in out Units_Htable.Instance) is 1356 Unit : Unit_Index; 1357 1358 begin 1359 Unit := Units_Htable.Get_First (Table); 1360 while Unit /= No_Unit_Index loop 1361 if Unit.File_Names (Spec) /= null then 1362 Unit.File_Names (Spec).Unit := No_Unit_Index; 1363 end if; 1364 1365 if Unit.File_Names (Impl) /= null then 1366 Unit.File_Names (Impl).Unit := No_Unit_Index; 1367 end if; 1368 1369 Unit := Units_Htable.Get_Next (Table); 1370 end loop; 1371 end Reset_Units_In_Table; 1372 1373 ---------------- 1374 -- Free_Units -- 1375 ---------------- 1376 1377 procedure Free_Units (Table : in out Units_Htable.Instance) is 1378 procedure Unchecked_Free is new 1379 Ada.Unchecked_Deallocation (Unit_Data, Unit_Index); 1380 1381 Unit : Unit_Index; 1382 1383 begin 1384 Unit := Units_Htable.Get_First (Table); 1385 while Unit /= No_Unit_Index loop 1386 1387 -- We cannot reset Unit.File_Names (Impl or Spec).Unit here as 1388 -- Source_Data buffer is freed by the following instruction 1389 -- Free_List (Tree.Projects, Free_Project => True); 1390 1391 Unchecked_Free (Unit); 1392 Unit := Units_Htable.Get_Next (Table); 1393 end loop; 1394 1395 Units_Htable.Reset (Table); 1396 end Free_Units; 1397 1398 ---------- 1399 -- Free -- 1400 ---------- 1401 1402 procedure Free (Tree : in out Project_Tree_Ref) is 1403 procedure Unchecked_Free is new 1404 Ada.Unchecked_Deallocation 1405 (Project_Tree_Data, Project_Tree_Ref); 1406 1407 procedure Unchecked_Free is new 1408 Ada.Unchecked_Deallocation 1409 (Project_Tree_Appdata'Class, Project_Tree_Appdata_Access); 1410 1411 begin 1412 if Tree /= null then 1413 if Tree.Is_Root_Tree then 1414 Name_List_Table.Free (Tree.Shared.Name_Lists); 1415 Number_List_Table.Free (Tree.Shared.Number_Lists); 1416 String_Element_Table.Free (Tree.Shared.String_Elements); 1417 Variable_Element_Table.Free (Tree.Shared.Variable_Elements); 1418 Array_Element_Table.Free (Tree.Shared.Array_Elements); 1419 Array_Table.Free (Tree.Shared.Arrays); 1420 Package_Table.Free (Tree.Shared.Packages); 1421 Temp_Files_Table.Free (Tree.Shared.Private_Part.Temp_Files); 1422 end if; 1423 1424 if Tree.Appdata /= null then 1425 Free (Tree.Appdata.all); 1426 Unchecked_Free (Tree.Appdata); 1427 end if; 1428 1429 Source_Paths_Htable.Reset (Tree.Source_Paths_HT); 1430 Source_Files_Htable.Reset (Tree.Source_Files_HT); 1431 1432 Reset_Units_In_Table (Tree.Units_HT); 1433 Free_List (Tree.Projects, Free_Project => True); 1434 Free_Units (Tree.Units_HT); 1435 1436 Unchecked_Free (Tree); 1437 end if; 1438 end Free; 1439 1440 ----------- 1441 -- Reset -- 1442 ----------- 1443 1444 procedure Reset (Tree : Project_Tree_Ref) is 1445 begin 1446 -- Visible tables 1447 1448 if Tree.Is_Root_Tree then 1449 1450 -- We cannot use 'Access here: 1451 -- "illegal attribute for discriminant-dependent component" 1452 -- However, we know this is valid since Shared and Shared_Data have 1453 -- the same lifetime and will always exist concurrently. 1454 1455 Tree.Shared := Tree.Shared_Data'Unrestricted_Access; 1456 Name_List_Table.Init (Tree.Shared.Name_Lists); 1457 Number_List_Table.Init (Tree.Shared.Number_Lists); 1458 String_Element_Table.Init (Tree.Shared.String_Elements); 1459 Variable_Element_Table.Init (Tree.Shared.Variable_Elements); 1460 Array_Element_Table.Init (Tree.Shared.Array_Elements); 1461 Array_Table.Init (Tree.Shared.Arrays); 1462 Package_Table.Init (Tree.Shared.Packages); 1463 1464 -- Create Dot_String_List 1465 1466 String_Element_Table.Append 1467 (Tree.Shared.String_Elements, 1468 String_Element' 1469 (Value => The_Dot_String, 1470 Index => 0, 1471 Display_Value => The_Dot_String, 1472 Location => No_Location, 1473 Flag => False, 1474 Next => Nil_String)); 1475 Tree.Shared.Dot_String_List := 1476 String_Element_Table.Last (Tree.Shared.String_Elements); 1477 1478 -- Private part table 1479 1480 Temp_Files_Table.Init (Tree.Shared.Private_Part.Temp_Files); 1481 1482 Tree.Shared.Private_Part.Current_Source_Path_File := No_Path; 1483 Tree.Shared.Private_Part.Current_Object_Path_File := No_Path; 1484 end if; 1485 1486 Source_Paths_Htable.Reset (Tree.Source_Paths_HT); 1487 Source_Files_Htable.Reset (Tree.Source_Files_HT); 1488 Replaced_Source_HTable.Reset (Tree.Replaced_Sources); 1489 1490 Tree.Replaced_Source_Number := 0; 1491 1492 Reset_Units_In_Table (Tree.Units_HT); 1493 Free_List (Tree.Projects, Free_Project => True); 1494 Free_Units (Tree.Units_HT); 1495 end Reset; 1496 1497 ------------------------------------- 1498 -- Set_Current_Object_Path_File_Of -- 1499 ------------------------------------- 1500 1501 procedure Set_Current_Object_Path_File_Of 1502 (Shared : Shared_Project_Tree_Data_Access; 1503 To : Path_Name_Type) 1504 is 1505 begin 1506 Shared.Private_Part.Current_Object_Path_File := To; 1507 end Set_Current_Object_Path_File_Of; 1508 1509 ------------------------------------- 1510 -- Set_Current_Source_Path_File_Of -- 1511 ------------------------------------- 1512 1513 procedure Set_Current_Source_Path_File_Of 1514 (Shared : Shared_Project_Tree_Data_Access; 1515 To : Path_Name_Type) 1516 is 1517 begin 1518 Shared.Private_Part.Current_Source_Path_File := To; 1519 end Set_Current_Source_Path_File_Of; 1520 1521 ----------------------- 1522 -- Set_Path_File_Var -- 1523 ----------------------- 1524 1525 procedure Set_Path_File_Var (Name : String; Value : String) is 1526 Host_Spec : String_Access := To_Host_File_Spec (Value); 1527 begin 1528 if Host_Spec = null then 1529 Prj.Com.Fail 1530 ("could not convert file name """ & Value & """ to host spec"); 1531 else 1532 Setenv (Name, Host_Spec.all); 1533 Free (Host_Spec); 1534 end if; 1535 end Set_Path_File_Var; 1536 1537 ------------------- 1538 -- Switches_Name -- 1539 ------------------- 1540 1541 function Switches_Name 1542 (Source_File_Name : File_Name_Type) return File_Name_Type 1543 is 1544 begin 1545 return Extend_Name (Source_File_Name, Switches_Dependency_Suffix); 1546 end Switches_Name; 1547 1548 ----------- 1549 -- Value -- 1550 ----------- 1551 1552 function Value (Image : String) return Casing_Type is 1553 begin 1554 for Casing in The_Casing_Images'Range loop 1555 if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then 1556 return Casing; 1557 end if; 1558 end loop; 1559 1560 raise Constraint_Error; 1561 end Value; 1562 1563 --------------------- 1564 -- Has_Ada_Sources -- 1565 --------------------- 1566 1567 function Has_Ada_Sources (Data : Project_Id) return Boolean is 1568 Lang : Language_Ptr; 1569 1570 begin 1571 Lang := Data.Languages; 1572 while Lang /= No_Language_Index loop 1573 if Lang.Name = Name_Ada then 1574 return Lang.First_Source /= No_Source; 1575 end if; 1576 Lang := Lang.Next; 1577 end loop; 1578 1579 return False; 1580 end Has_Ada_Sources; 1581 1582 ------------------------ 1583 -- Contains_ALI_Files -- 1584 ------------------------ 1585 1586 function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean is 1587 Dir_Name : constant String := Get_Name_String (Dir); 1588 Direct : Dir_Type; 1589 Name : String (1 .. 1_000); 1590 Last : Natural; 1591 Result : Boolean := False; 1592 1593 begin 1594 Open (Direct, Dir_Name); 1595 1596 -- For each file in the directory, check if it is an ALI file 1597 1598 loop 1599 Read (Direct, Name, Last); 1600 exit when Last = 0; 1601 Canonical_Case_File_Name (Name (1 .. Last)); 1602 Result := Last >= 5 and then Name (Last - 3 .. Last) = ".ali"; 1603 exit when Result; 1604 end loop; 1605 1606 Close (Direct); 1607 return Result; 1608 1609 exception 1610 -- If there is any problem, close the directory if open and return True. 1611 -- The library directory will be added to the path. 1612 1613 when others => 1614 if Is_Open (Direct) then 1615 Close (Direct); 1616 end if; 1617 1618 return True; 1619 end Contains_ALI_Files; 1620 1621 -------------------------- 1622 -- Get_Object_Directory -- 1623 -------------------------- 1624 1625 function Get_Object_Directory 1626 (Project : Project_Id; 1627 Including_Libraries : Boolean; 1628 Only_If_Ada : Boolean := False) return Path_Name_Type 1629 is 1630 begin 1631 if (Project.Library and then Including_Libraries) 1632 or else 1633 (Project.Object_Directory /= No_Path_Information 1634 and then (not Including_Libraries or else not Project.Library)) 1635 then 1636 -- For a library project, add the library ALI directory if there is 1637 -- no object directory or if the library ALI directory contains ALI 1638 -- files; otherwise add the object directory. 1639 1640 if Project.Library then 1641 if Project.Object_Directory = No_Path_Information 1642 or else 1643 (Including_Libraries 1644 and then 1645 Contains_ALI_Files (Project.Library_ALI_Dir.Display_Name)) 1646 then 1647 return Project.Library_ALI_Dir.Display_Name; 1648 else 1649 return Project.Object_Directory.Display_Name; 1650 end if; 1651 1652 -- For a non-library project, add object directory if it is not a 1653 -- virtual project, and if there are Ada sources in the project or 1654 -- one of the projects it extends. If there are no Ada sources, 1655 -- adding the object directory could disrupt the order of the 1656 -- object dirs in the path. 1657 1658 elsif not Project.Virtual then 1659 declare 1660 Add_Object_Dir : Boolean; 1661 Prj : Project_Id; 1662 1663 begin 1664 Add_Object_Dir := not Only_If_Ada; 1665 Prj := Project; 1666 while not Add_Object_Dir and then Prj /= No_Project loop 1667 if Has_Ada_Sources (Prj) then 1668 Add_Object_Dir := True; 1669 else 1670 Prj := Prj.Extends; 1671 end if; 1672 end loop; 1673 1674 if Add_Object_Dir then 1675 return Project.Object_Directory.Display_Name; 1676 end if; 1677 end; 1678 end if; 1679 end if; 1680 1681 return No_Path; 1682 end Get_Object_Directory; 1683 1684 ----------------------------------- 1685 -- Ultimate_Extending_Project_Of -- 1686 ----------------------------------- 1687 1688 function Ultimate_Extending_Project_Of 1689 (Proj : Project_Id) return Project_Id 1690 is 1691 Prj : Project_Id; 1692 1693 begin 1694 Prj := Proj; 1695 while Prj /= null and then Prj.Extended_By /= No_Project loop 1696 Prj := Prj.Extended_By; 1697 end loop; 1698 1699 return Prj; 1700 end Ultimate_Extending_Project_Of; 1701 1702 ----------------------------------- 1703 -- Compute_All_Imported_Projects -- 1704 ----------------------------------- 1705 1706 procedure Compute_All_Imported_Projects 1707 (Root_Project : Project_Id; 1708 Tree : Project_Tree_Ref) 1709 is 1710 procedure Analyze_Tree 1711 (Local_Root : Project_Id; 1712 Local_Tree : Project_Tree_Ref; 1713 Context : Project_Context); 1714 -- Process Project and all its aggregated project to analyze their own 1715 -- imported projects. 1716 1717 ------------------ 1718 -- Analyze_Tree -- 1719 ------------------ 1720 1721 procedure Analyze_Tree 1722 (Local_Root : Project_Id; 1723 Local_Tree : Project_Tree_Ref; 1724 Context : Project_Context) 1725 is 1726 pragma Unreferenced (Local_Root); 1727 1728 Project : Project_Id; 1729 1730 procedure Recursive_Add 1731 (Prj : Project_Id; 1732 Tree : Project_Tree_Ref; 1733 Context : Project_Context; 1734 Dummy : in out Boolean); 1735 -- Recursively add the projects imported by project Project, but not 1736 -- those that are extended. 1737 1738 ------------------- 1739 -- Recursive_Add -- 1740 ------------------- 1741 1742 procedure Recursive_Add 1743 (Prj : Project_Id; 1744 Tree : Project_Tree_Ref; 1745 Context : Project_Context; 1746 Dummy : in out Boolean) 1747 is 1748 pragma Unreferenced (Tree); 1749 1750 List : Project_List; 1751 Prj2 : Project_Id; 1752 1753 begin 1754 -- A project is not importing itself 1755 1756 Prj2 := Ultimate_Extending_Project_Of (Prj); 1757 1758 if Project /= Prj2 then 1759 1760 -- Check that the project is not already in the list. We know 1761 -- the one passed to Recursive_Add have never been visited 1762 -- before, but the one passed it are the extended projects. 1763 1764 List := Project.All_Imported_Projects; 1765 while List /= null loop 1766 if List.Project = Prj2 then 1767 return; 1768 end if; 1769 1770 List := List.Next; 1771 end loop; 1772 1773 -- Add it to the list 1774 1775 Project.All_Imported_Projects := 1776 new Project_List_Element' 1777 (Project => Prj2, 1778 From_Encapsulated_Lib => 1779 Context.From_Encapsulated_Lib 1780 or else Analyze_Tree.Context.From_Encapsulated_Lib, 1781 Next => Project.All_Imported_Projects); 1782 end if; 1783 end Recursive_Add; 1784 1785 procedure For_All_Projects is 1786 new For_Every_Project_Imported_Context (Boolean, Recursive_Add); 1787 1788 Dummy : Boolean := False; 1789 List : Project_List; 1790 1791 begin 1792 List := Local_Tree.Projects; 1793 while List /= null loop 1794 Project := List.Project; 1795 Free_List 1796 (Project.All_Imported_Projects, Free_Project => False); 1797 For_All_Projects 1798 (Project, Local_Tree, Dummy, Include_Aggregated => False); 1799 List := List.Next; 1800 end loop; 1801 end Analyze_Tree; 1802 1803 procedure For_Aggregates is 1804 new For_Project_And_Aggregated_Context (Analyze_Tree); 1805 1806 -- Start of processing for Compute_All_Imported_Projects 1807 1808 begin 1809 For_Aggregates (Root_Project, Tree); 1810 end Compute_All_Imported_Projects; 1811 1812 ------------------- 1813 -- Is_Compilable -- 1814 ------------------- 1815 1816 function Is_Compilable (Source : Source_Id) return Boolean is 1817 begin 1818 case Source.Compilable is 1819 when Unknown => 1820 if Source.Language.Config.Compiler_Driver /= No_File 1821 and then 1822 Length_Of_Name (Source.Language.Config.Compiler_Driver) /= 0 1823 and then not Source.Locally_Removed 1824 and then (Source.Language.Config.Kind /= File_Based 1825 or else Source.Kind /= Spec) 1826 then 1827 -- Do not modify Source.Compilable before the source record 1828 -- has been initialized. 1829 1830 if Source.Source_TS /= Empty_Time_Stamp then 1831 Source.Compilable := Yes; 1832 end if; 1833 1834 return True; 1835 1836 else 1837 if Source.Source_TS /= Empty_Time_Stamp then 1838 Source.Compilable := No; 1839 end if; 1840 1841 return False; 1842 end if; 1843 1844 when Yes => 1845 return True; 1846 1847 when No => 1848 return False; 1849 end case; 1850 end Is_Compilable; 1851 1852 ------------------------------ 1853 -- Object_To_Global_Archive -- 1854 ------------------------------ 1855 1856 function Object_To_Global_Archive (Source : Source_Id) return Boolean is 1857 begin 1858 return Source.Language.Config.Kind = File_Based 1859 and then Source.Kind = Impl 1860 and then Source.Language.Config.Objects_Linked 1861 and then Is_Compilable (Source) 1862 and then Source.Language.Config.Object_Generated; 1863 end Object_To_Global_Archive; 1864 1865 ---------------------------- 1866 -- Get_Language_From_Name -- 1867 ---------------------------- 1868 1869 function Get_Language_From_Name 1870 (Project : Project_Id; 1871 Name : String) return Language_Ptr 1872 is 1873 N : Name_Id; 1874 Result : Language_Ptr; 1875 1876 begin 1877 Name_Len := Name'Length; 1878 Name_Buffer (1 .. Name_Len) := Name; 1879 To_Lower (Name_Buffer (1 .. Name_Len)); 1880 N := Name_Find; 1881 1882 Result := Project.Languages; 1883 while Result /= No_Language_Index loop 1884 if Result.Name = N then 1885 return Result; 1886 end if; 1887 1888 Result := Result.Next; 1889 end loop; 1890 1891 return No_Language_Index; 1892 end Get_Language_From_Name; 1893 1894 ---------------- 1895 -- Other_Part -- 1896 ---------------- 1897 1898 function Other_Part (Source : Source_Id) return Source_Id is 1899 begin 1900 if Source.Unit /= No_Unit_Index then 1901 case Source.Kind is 1902 when Impl => 1903 return Source.Unit.File_Names (Spec); 1904 when Spec => 1905 return Source.Unit.File_Names (Impl); 1906 when Sep => 1907 return No_Source; 1908 end case; 1909 else 1910 return No_Source; 1911 end if; 1912 end Other_Part; 1913 1914 ------------------ 1915 -- Create_Flags -- 1916 ------------------ 1917 1918 function Create_Flags 1919 (Report_Error : Error_Handler; 1920 When_No_Sources : Error_Warning; 1921 Require_Sources_Other_Lang : Boolean := True; 1922 Allow_Duplicate_Basenames : Boolean := True; 1923 Compiler_Driver_Mandatory : Boolean := False; 1924 Error_On_Unknown_Language : Boolean := True; 1925 Require_Obj_Dirs : Error_Warning := Error; 1926 Allow_Invalid_External : Error_Warning := Error; 1927 Missing_Source_Files : Error_Warning := Error; 1928 Ignore_Missing_With : Boolean := False) 1929 return Processing_Flags 1930 is 1931 begin 1932 return Processing_Flags' 1933 (Report_Error => Report_Error, 1934 When_No_Sources => When_No_Sources, 1935 Require_Sources_Other_Lang => Require_Sources_Other_Lang, 1936 Allow_Duplicate_Basenames => Allow_Duplicate_Basenames, 1937 Error_On_Unknown_Language => Error_On_Unknown_Language, 1938 Compiler_Driver_Mandatory => Compiler_Driver_Mandatory, 1939 Require_Obj_Dirs => Require_Obj_Dirs, 1940 Allow_Invalid_External => Allow_Invalid_External, 1941 Missing_Source_Files => Missing_Source_Files, 1942 Ignore_Missing_With => Ignore_Missing_With, 1943 Incomplete_Withs => False); 1944 end Create_Flags; 1945 1946 ------------ 1947 -- Length -- 1948 ------------ 1949 1950 function Length 1951 (Table : Name_List_Table.Instance; 1952 List : Name_List_Index) return Natural 1953 is 1954 Count : Natural := 0; 1955 Tmp : Name_List_Index; 1956 1957 begin 1958 Tmp := List; 1959 while Tmp /= No_Name_List loop 1960 Count := Count + 1; 1961 Tmp := Table.Table (Tmp).Next; 1962 end loop; 1963 1964 return Count; 1965 end Length; 1966 1967 ------------------ 1968 -- Debug_Output -- 1969 ------------------ 1970 1971 procedure Debug_Output (Str : String) is 1972 begin 1973 if Current_Verbosity > Default then 1974 Set_Standard_Error; 1975 Write_Line ((1 .. Debug_Level * 2 => ' ') & Str); 1976 Set_Standard_Output; 1977 end if; 1978 end Debug_Output; 1979 1980 ------------------ 1981 -- Debug_Indent -- 1982 ------------------ 1983 1984 procedure Debug_Indent is 1985 begin 1986 if Current_Verbosity = High then 1987 Set_Standard_Error; 1988 Write_Str ((1 .. Debug_Level * 2 => ' ')); 1989 Set_Standard_Output; 1990 end if; 1991 end Debug_Indent; 1992 1993 ------------------ 1994 -- Debug_Output -- 1995 ------------------ 1996 1997 procedure Debug_Output (Str : String; Str2 : Name_Id) is 1998 begin 1999 if Current_Verbosity > Default then 2000 Debug_Indent; 2001 Set_Standard_Error; 2002 Write_Str (Str); 2003 2004 if Str2 = No_Name then 2005 Write_Line (" <no_name>"); 2006 else 2007 Write_Line (" """ & Get_Name_String (Str2) & '"'); 2008 end if; 2009 2010 Set_Standard_Output; 2011 end if; 2012 end Debug_Output; 2013 2014 --------------------------- 2015 -- Debug_Increase_Indent -- 2016 --------------------------- 2017 2018 procedure Debug_Increase_Indent 2019 (Str : String := ""; Str2 : Name_Id := No_Name) 2020 is 2021 begin 2022 if Str2 /= No_Name then 2023 Debug_Output (Str, Str2); 2024 else 2025 Debug_Output (Str); 2026 end if; 2027 Debug_Level := Debug_Level + 1; 2028 end Debug_Increase_Indent; 2029 2030 --------------------------- 2031 -- Debug_Decrease_Indent -- 2032 --------------------------- 2033 2034 procedure Debug_Decrease_Indent (Str : String := "") is 2035 begin 2036 if Debug_Level > 0 then 2037 Debug_Level := Debug_Level - 1; 2038 end if; 2039 2040 if Str /= "" then 2041 Debug_Output (Str); 2042 end if; 2043 end Debug_Decrease_Indent; 2044 2045 ---------------- 2046 -- Debug_Name -- 2047 ---------------- 2048 2049 function Debug_Name (Tree : Project_Tree_Ref) return Name_Id is 2050 P : Project_List; 2051 2052 begin 2053 Name_Len := 0; 2054 Add_Str_To_Name_Buffer ("Tree ["); 2055 2056 P := Tree.Projects; 2057 while P /= null loop 2058 if P /= Tree.Projects then 2059 Add_Char_To_Name_Buffer (','); 2060 end if; 2061 2062 Add_Str_To_Name_Buffer (Get_Name_String (P.Project.Name)); 2063 2064 P := P.Next; 2065 end loop; 2066 2067 Add_Char_To_Name_Buffer (']'); 2068 2069 return Name_Find; 2070 end Debug_Name; 2071 2072 ---------- 2073 -- Free -- 2074 ---------- 2075 2076 procedure Free (Tree : in out Project_Tree_Appdata) is 2077 pragma Unreferenced (Tree); 2078 begin 2079 null; 2080 end Free; 2081 2082 -------------------------------- 2083 -- For_Project_And_Aggregated -- 2084 -------------------------------- 2085 2086 procedure For_Project_And_Aggregated 2087 (Root_Project : Project_Id; 2088 Root_Tree : Project_Tree_Ref) 2089 is 2090 Agg : Aggregated_Project_List; 2091 2092 begin 2093 Action (Root_Project, Root_Tree); 2094 2095 if Root_Project.Qualifier in Aggregate_Project then 2096 Agg := Root_Project.Aggregated_Projects; 2097 while Agg /= null loop 2098 For_Project_And_Aggregated (Agg.Project, Agg.Tree); 2099 Agg := Agg.Next; 2100 end loop; 2101 end if; 2102 end For_Project_And_Aggregated; 2103 2104 ---------------------------------------- 2105 -- For_Project_And_Aggregated_Context -- 2106 ---------------------------------------- 2107 2108 procedure For_Project_And_Aggregated_Context 2109 (Root_Project : Project_Id; 2110 Root_Tree : Project_Tree_Ref) 2111 is 2112 2113 procedure Recursive_Process 2114 (Project : Project_Id; 2115 Tree : Project_Tree_Ref; 2116 Context : Project_Context); 2117 -- Process Project and all aggregated projects recursively 2118 2119 ----------------------- 2120 -- Recursive_Process -- 2121 ----------------------- 2122 2123 procedure Recursive_Process 2124 (Project : Project_Id; 2125 Tree : Project_Tree_Ref; 2126 Context : Project_Context) 2127 is 2128 Agg : Aggregated_Project_List; 2129 Ctx : Project_Context; 2130 2131 begin 2132 Action (Project, Tree, Context); 2133 2134 if Project.Qualifier in Aggregate_Project then 2135 Ctx := 2136 (In_Aggregate_Lib => Project.Qualifier = Aggregate_Library, 2137 From_Encapsulated_Lib => 2138 Context.From_Encapsulated_Lib 2139 or else Project.Standalone_Library = Encapsulated); 2140 2141 Agg := Project.Aggregated_Projects; 2142 while Agg /= null loop 2143 Recursive_Process (Agg.Project, Agg.Tree, Ctx); 2144 Agg := Agg.Next; 2145 end loop; 2146 end if; 2147 end Recursive_Process; 2148 2149 -- Start of processing for For_Project_And_Aggregated_Context 2150 2151 begin 2152 Recursive_Process 2153 (Root_Project, Root_Tree, Project_Context'(False, False)); 2154 end For_Project_And_Aggregated_Context; 2155 2156 ----------------------------- 2157 -- Set_Ignore_Missing_With -- 2158 ----------------------------- 2159 2160 procedure Set_Ignore_Missing_With 2161 (Flags : in out Processing_Flags; 2162 Value : Boolean) 2163 is 2164 begin 2165 Flags.Ignore_Missing_With := Value; 2166 end Set_Ignore_Missing_With; 2167 2168-- Package initialization for Prj 2169 2170begin 2171 -- Make sure that the standard config and user project file extensions are 2172 -- compatible with canonical case file naming. 2173 2174 Canonical_Case_File_Name (Config_Project_File_Extension); 2175 Canonical_Case_File_Name (Project_File_Extension); 2176end Prj; 2177