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