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