1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- P R J . U T I L -- 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 Ada.Containers.Indefinite_Ordered_Sets; 27with Ada.Directories; 28with Ada.Unchecked_Deallocation; 29 30with GNAT.Case_Util; use GNAT.Case_Util; 31with GNAT.Regexp; use GNAT.Regexp; 32 33with ALI; use ALI; 34with Osint; use Osint; 35with Output; use Output; 36with Opt; 37with Prj.Com; 38with Snames; use Snames; 39with Table; 40with Targparm; use Targparm; 41 42with GNAT.HTable; 43 44package body Prj.Util is 45 46 package Source_Info_Table is new Table.Table 47 (Table_Component_Type => Source_Info_Iterator, 48 Table_Index_Type => Natural, 49 Table_Low_Bound => 1, 50 Table_Initial => 10, 51 Table_Increment => 100, 52 Table_Name => "Makeutl.Source_Info_Table"); 53 54 package Source_Info_Project_HTable is new GNAT.HTable.Simple_HTable 55 (Header_Num => Prj.Header_Num, 56 Element => Natural, 57 No_Element => 0, 58 Key => Name_Id, 59 Hash => Prj.Hash, 60 Equal => "="); 61 62 procedure Free is new Ada.Unchecked_Deallocation 63 (Text_File_Data, Text_File); 64 65 ----------- 66 -- Close -- 67 ----------- 68 69 procedure Close (File : in out Text_File) is 70 Len : Integer; 71 Status : Boolean; 72 73 begin 74 if File = null then 75 Prj.Com.Fail ("Close attempted on an invalid Text_File"); 76 end if; 77 78 if File.Out_File then 79 if File.Buffer_Len > 0 then 80 Len := Write (File.FD, File.Buffer'Address, File.Buffer_Len); 81 82 if Len /= File.Buffer_Len then 83 Prj.Com.Fail ("Unable to write to an out Text_File"); 84 end if; 85 end if; 86 87 Close (File.FD, Status); 88 89 if not Status then 90 Prj.Com.Fail ("Unable to close an out Text_File"); 91 end if; 92 93 else 94 95 -- Close in file, no need to test status, since this is a file that 96 -- we read, and the file was read successfully before we closed it. 97 98 Close (File.FD); 99 end if; 100 101 Free (File); 102 end Close; 103 104 ------------ 105 -- Create -- 106 ------------ 107 108 procedure Create (File : out Text_File; Name : String) is 109 FD : File_Descriptor; 110 File_Name : String (1 .. Name'Length + 1); 111 112 begin 113 File_Name (1 .. Name'Length) := Name; 114 File_Name (File_Name'Last) := ASCII.NUL; 115 FD := Create_File (Name => File_Name'Address, 116 Fmode => GNAT.OS_Lib.Text); 117 118 if FD = Invalid_FD then 119 File := null; 120 121 else 122 File := new Text_File_Data; 123 File.FD := FD; 124 File.Out_File := True; 125 File.End_Of_File_Reached := True; 126 end if; 127 end Create; 128 129 --------------- 130 -- Duplicate -- 131 --------------- 132 133 procedure Duplicate 134 (This : in out Name_List_Index; 135 Shared : Shared_Project_Tree_Data_Access) 136 is 137 Old_Current : Name_List_Index; 138 New_Current : Name_List_Index; 139 140 begin 141 if This /= No_Name_List then 142 Old_Current := This; 143 Name_List_Table.Increment_Last (Shared.Name_Lists); 144 New_Current := Name_List_Table.Last (Shared.Name_Lists); 145 This := New_Current; 146 Shared.Name_Lists.Table (New_Current) := 147 (Shared.Name_Lists.Table (Old_Current).Name, No_Name_List); 148 149 loop 150 Old_Current := Shared.Name_Lists.Table (Old_Current).Next; 151 exit when Old_Current = No_Name_List; 152 Shared.Name_Lists.Table (New_Current).Next := New_Current + 1; 153 Name_List_Table.Increment_Last (Shared.Name_Lists); 154 New_Current := New_Current + 1; 155 Shared.Name_Lists.Table (New_Current) := 156 (Shared.Name_Lists.Table (Old_Current).Name, No_Name_List); 157 end loop; 158 end if; 159 end Duplicate; 160 161 ----------------- 162 -- End_Of_File -- 163 ----------------- 164 165 function End_Of_File (File : Text_File) return Boolean is 166 begin 167 if File = null then 168 Prj.Com.Fail ("End_Of_File attempted on an invalid Text_File"); 169 end if; 170 171 return File.End_Of_File_Reached; 172 end End_Of_File; 173 174 ------------------- 175 -- Executable_Of -- 176 ------------------- 177 178 function Executable_Of 179 (Project : Project_Id; 180 Shared : Shared_Project_Tree_Data_Access; 181 Main : File_Name_Type; 182 Index : Int; 183 Ada_Main : Boolean := True; 184 Language : String := ""; 185 Include_Suffix : Boolean := True) return File_Name_Type 186 is 187 pragma Assert (Project /= No_Project); 188 189 The_Packages : constant Package_Id := Project.Decl.Packages; 190 191 Builder_Package : constant Prj.Package_Id := 192 Prj.Util.Value_Of 193 (Name => Name_Builder, 194 In_Packages => The_Packages, 195 Shared => Shared); 196 197 Executable : Variable_Value := 198 Prj.Util.Value_Of 199 (Name => Name_Id (Main), 200 Index => Index, 201 Attribute_Or_Array_Name => Name_Executable, 202 In_Package => Builder_Package, 203 Shared => Shared); 204 205 Lang : Language_Ptr; 206 207 Spec_Suffix : Name_Id := No_Name; 208 Body_Suffix : Name_Id := No_Name; 209 210 Spec_Suffix_Length : Natural := 0; 211 Body_Suffix_Length : Natural := 0; 212 213 procedure Get_Suffixes 214 (B_Suffix : File_Name_Type; 215 S_Suffix : File_Name_Type); 216 -- Get the non empty suffixes in variables Spec_Suffix and Body_Suffix 217 218 function Add_Suffix (File : File_Name_Type) return File_Name_Type; 219 -- Return the name of the executable, based on File, and adding the 220 -- executable suffix if needed 221 222 ------------------ 223 -- Get_Suffixes -- 224 ------------------ 225 226 procedure Get_Suffixes 227 (B_Suffix : File_Name_Type; 228 S_Suffix : File_Name_Type) 229 is 230 begin 231 if B_Suffix /= No_File then 232 Body_Suffix := Name_Id (B_Suffix); 233 Body_Suffix_Length := Natural (Length_Of_Name (Body_Suffix)); 234 end if; 235 236 if S_Suffix /= No_File then 237 Spec_Suffix := Name_Id (S_Suffix); 238 Spec_Suffix_Length := Natural (Length_Of_Name (Spec_Suffix)); 239 end if; 240 end Get_Suffixes; 241 242 ---------------- 243 -- Add_Suffix -- 244 ---------------- 245 246 function Add_Suffix (File : File_Name_Type) return File_Name_Type is 247 Saved_EEOT : constant Name_Id := Executable_Extension_On_Target; 248 Result : File_Name_Type; 249 Suffix_From_Project : Variable_Value; 250 begin 251 if Include_Suffix then 252 if Project.Config.Executable_Suffix /= No_Name then 253 Executable_Extension_On_Target := 254 Project.Config.Executable_Suffix; 255 end if; 256 257 Result := Executable_Name (File); 258 Executable_Extension_On_Target := Saved_EEOT; 259 return Result; 260 261 elsif Builder_Package /= No_Package then 262 263 -- If the suffix is specified in the project itself, as opposed to 264 -- the config file, it needs to be taken into account. However, 265 -- when the project was processed, in both cases the suffix was 266 -- stored in Project.Config, so get it from the project again. 267 268 Suffix_From_Project := 269 Prj.Util.Value_Of 270 (Variable_Name => Name_Executable_Suffix, 271 In_Variables => 272 Shared.Packages.Table (Builder_Package).Decl.Attributes, 273 Shared => Shared); 274 275 if Suffix_From_Project /= Nil_Variable_Value 276 and then Suffix_From_Project.Value /= No_Name 277 then 278 Executable_Extension_On_Target := Suffix_From_Project.Value; 279 Result := Executable_Name (File); 280 Executable_Extension_On_Target := Saved_EEOT; 281 return Result; 282 end if; 283 end if; 284 285 return File; 286 end Add_Suffix; 287 288 -- Start of processing for Executable_Of 289 290 begin 291 if Ada_Main then 292 Lang := Get_Language_From_Name (Project, "ada"); 293 elsif Language /= "" then 294 Lang := Get_Language_From_Name (Project, Language); 295 end if; 296 297 if Lang /= null then 298 Get_Suffixes 299 (B_Suffix => Lang.Config.Naming_Data.Body_Suffix, 300 S_Suffix => Lang.Config.Naming_Data.Spec_Suffix); 301 end if; 302 303 if Builder_Package /= No_Package then 304 if Executable = Nil_Variable_Value and then Ada_Main then 305 Get_Name_String (Main); 306 307 -- Try as index the name minus the implementation suffix or minus 308 -- the specification suffix. 309 310 declare 311 Name : constant String (1 .. Name_Len) := 312 Name_Buffer (1 .. Name_Len); 313 Last : Positive := Name_Len; 314 315 Truncated : Boolean := False; 316 317 begin 318 if Body_Suffix /= No_Name 319 and then Last > Natural (Length_Of_Name (Body_Suffix)) 320 and then Name (Last - Body_Suffix_Length + 1 .. Last) = 321 Get_Name_String (Body_Suffix) 322 then 323 Truncated := True; 324 Last := Last - Body_Suffix_Length; 325 end if; 326 327 if Spec_Suffix /= No_Name 328 and then not Truncated 329 and then Last > Spec_Suffix_Length 330 and then Name (Last - Spec_Suffix_Length + 1 .. Last) = 331 Get_Name_String (Spec_Suffix) 332 then 333 Truncated := True; 334 Last := Last - Spec_Suffix_Length; 335 end if; 336 337 if Truncated then 338 Name_Len := Last; 339 Name_Buffer (1 .. Name_Len) := Name (1 .. Last); 340 Executable := 341 Prj.Util.Value_Of 342 (Name => Name_Find, 343 Index => 0, 344 Attribute_Or_Array_Name => Name_Executable, 345 In_Package => Builder_Package, 346 Shared => Shared); 347 end if; 348 end; 349 end if; 350 351 -- If we have found an Executable attribute, return its value, 352 -- possibly suffixed by the executable suffix. 353 354 if Executable /= Nil_Variable_Value 355 and then Executable.Value /= No_Name 356 and then Length_Of_Name (Executable.Value) /= 0 357 then 358 return Add_Suffix (File_Name_Type (Executable.Value)); 359 end if; 360 end if; 361 362 Get_Name_String (Main); 363 364 -- If there is a body suffix or a spec suffix, remove this suffix, 365 -- otherwise remove any suffix ('.' followed by other characters), if 366 -- there is one. 367 368 if Body_Suffix /= No_Name 369 and then Name_Len > Body_Suffix_Length 370 and then Name_Buffer (Name_Len - Body_Suffix_Length + 1 .. Name_Len) = 371 Get_Name_String (Body_Suffix) 372 then 373 -- Found the body termination, remove it 374 375 Name_Len := Name_Len - Body_Suffix_Length; 376 377 elsif Spec_Suffix /= No_Name 378 and then Name_Len > Spec_Suffix_Length 379 and then 380 Name_Buffer (Name_Len - Spec_Suffix_Length + 1 .. Name_Len) = 381 Get_Name_String (Spec_Suffix) 382 then 383 -- Found the spec termination, remove it 384 385 Name_Len := Name_Len - Spec_Suffix_Length; 386 387 else 388 -- Remove any suffix, if there is one 389 390 Get_Name_String (Strip_Suffix (Main)); 391 end if; 392 393 return Add_Suffix (Name_Find); 394 end Executable_Of; 395 396 --------------------------- 397 -- For_Interface_Sources -- 398 --------------------------- 399 400 procedure For_Interface_Sources 401 (Tree : Project_Tree_Ref; 402 Project : Project_Id) 403 is 404 use Ada; 405 use type Ada.Containers.Count_Type; 406 407 package Dep_Names is new Containers.Indefinite_Ordered_Sets (String); 408 409 function Load_ALI (Filename : String) return ALI_Id; 410 -- Load an ALI file and return its id 411 412 -------------- 413 -- Load_ALI -- 414 -------------- 415 416 function Load_ALI (Filename : String) return ALI_Id is 417 Result : ALI_Id := No_ALI_Id; 418 Text : Text_Buffer_Ptr; 419 Lib_File : File_Name_Type; 420 421 begin 422 if Directories.Exists (Filename) then 423 Name_Len := 0; 424 Add_Str_To_Name_Buffer (Filename); 425 Lib_File := Name_Find; 426 Text := Osint.Read_Library_Info (Lib_File); 427 Result := 428 ALI.Scan_ALI 429 (Lib_File, 430 Text, 431 Ignore_ED => False, 432 Err => True, 433 Read_Lines => "UD"); 434 Free (Text); 435 end if; 436 437 return Result; 438 end Load_ALI; 439 440 -- Local declarations 441 442 Iter : Source_Iterator; 443 Sid : Source_Id; 444 ALI : ALI_Id; 445 446 First_Unit : Unit_Id; 447 Second_Unit : Unit_Id; 448 Body_Needed : Boolean; 449 Deps : Dep_Names.Set; 450 451 -- Start of processing for For_Interface_Sources 452 453 begin 454 if Project.Qualifier = Aggregate_Library then 455 Iter := For_Each_Source (Tree); 456 else 457 Iter := For_Each_Source (Tree, Project); 458 end if; 459 460 -- First look at each spec, check if the body is needed 461 462 loop 463 Sid := Element (Iter); 464 exit when Sid = No_Source; 465 466 -- Skip sources that are removed/excluded and sources not part of 467 -- the interface for standalone libraries. 468 469 if Sid.Kind = Spec 470 and then not Sid.Project.Externally_Built 471 and then not Sid.Locally_Removed 472 and then (Project.Standalone_Library = No 473 or else Sid.Declared_In_Interfaces) 474 475 -- Handle case of non-compilable languages 476 477 and then Sid.Dep_Name /= No_File 478 then 479 Action (Sid); 480 481 -- Check ALI for dependencies on body and sep 482 483 ALI := 484 Load_ALI 485 (Get_Name_String (Get_Object_Directory (Sid.Project, True)) 486 & Get_Name_String (Sid.Dep_Name)); 487 488 if ALI /= No_ALI_Id then 489 First_Unit := ALIs.Table (ALI).First_Unit; 490 Second_Unit := No_Unit_Id; 491 Body_Needed := True; 492 493 -- If there is both a spec and a body, check if both needed 494 495 if Units.Table (First_Unit).Utype = Is_Body then 496 Second_Unit := ALIs.Table (ALI).Last_Unit; 497 498 -- If the body is not needed, then reset First_Unit 499 500 if not Units.Table (Second_Unit).Body_Needed_For_SAL then 501 Body_Needed := False; 502 end if; 503 504 elsif Units.Table (First_Unit).Utype = Is_Spec_Only then 505 Body_Needed := False; 506 end if; 507 508 -- Handle all the separates, if any 509 510 if Body_Needed then 511 if Other_Part (Sid) /= null then 512 Deps.Include (Get_Name_String (Other_Part (Sid).File)); 513 end if; 514 515 for Dep in ALIs.Table (ALI).First_Sdep .. 516 ALIs.Table (ALI).Last_Sdep 517 loop 518 if Sdep.Table (Dep).Subunit_Name /= No_Name then 519 Deps.Include 520 (Get_Name_String (Sdep.Table (Dep).Sfile)); 521 end if; 522 end loop; 523 end if; 524 end if; 525 end if; 526 527 Next (Iter); 528 end loop; 529 530 -- Now handle the bodies and separates if needed 531 532 if Deps.Length /= 0 then 533 if Project.Qualifier = Aggregate_Library then 534 Iter := For_Each_Source (Tree); 535 else 536 Iter := For_Each_Source (Tree, Project); 537 end if; 538 539 loop 540 Sid := Element (Iter); 541 exit when Sid = No_Source; 542 543 if Sid.Kind /= Spec 544 and then Deps.Contains (Get_Name_String (Sid.File)) 545 then 546 Action (Sid); 547 end if; 548 549 Next (Iter); 550 end loop; 551 end if; 552 end For_Interface_Sources; 553 554 -------------- 555 -- Get_Line -- 556 -------------- 557 558 procedure Get_Line 559 (File : Text_File; 560 Line : out String; 561 Last : out Natural) 562 is 563 C : Character; 564 565 procedure Advance; 566 567 ------------- 568 -- Advance -- 569 ------------- 570 571 procedure Advance is 572 begin 573 if File.Cursor = File.Buffer_Len then 574 File.Buffer_Len := 575 Read 576 (FD => File.FD, 577 A => File.Buffer'Address, 578 N => File.Buffer'Length); 579 580 if File.Buffer_Len = 0 then 581 File.End_Of_File_Reached := True; 582 return; 583 else 584 File.Cursor := 1; 585 end if; 586 587 else 588 File.Cursor := File.Cursor + 1; 589 end if; 590 end Advance; 591 592 -- Start of processing for Get_Line 593 594 begin 595 if File = null then 596 Prj.Com.Fail ("Get_Line attempted on an invalid Text_File"); 597 598 elsif File.Out_File then 599 Prj.Com.Fail ("Get_Line attempted on an out file"); 600 end if; 601 602 Last := Line'First - 1; 603 604 if not File.End_Of_File_Reached then 605 loop 606 C := File.Buffer (File.Cursor); 607 exit when C = ASCII.CR or else C = ASCII.LF; 608 Last := Last + 1; 609 Line (Last) := C; 610 Advance; 611 612 if File.End_Of_File_Reached then 613 return; 614 end if; 615 616 exit when Last = Line'Last; 617 end loop; 618 619 if C = ASCII.CR or else C = ASCII.LF then 620 Advance; 621 622 if File.End_Of_File_Reached then 623 return; 624 end if; 625 end if; 626 627 if C = ASCII.CR 628 and then File.Buffer (File.Cursor) = ASCII.LF 629 then 630 Advance; 631 end if; 632 end if; 633 end Get_Line; 634 635 ---------------- 636 -- Initialize -- 637 ---------------- 638 639 procedure Initialize 640 (Iter : out Source_Info_Iterator; 641 For_Project : Name_Id) 642 is 643 Ind : constant Natural := Source_Info_Project_HTable.Get (For_Project); 644 begin 645 if Ind = 0 then 646 Iter := (No_Source_Info, 0); 647 else 648 Iter := Source_Info_Table.Table (Ind); 649 end if; 650 end Initialize; 651 652 -------------- 653 -- Is_Valid -- 654 -------------- 655 656 function Is_Valid (File : Text_File) return Boolean is 657 begin 658 return File /= null; 659 end Is_Valid; 660 661 ---------- 662 -- Next -- 663 ---------- 664 665 procedure Next (Iter : in out Source_Info_Iterator) is 666 begin 667 if Iter.Next = 0 then 668 Iter.Info := No_Source_Info; 669 670 else 671 Iter := Source_Info_Table.Table (Iter.Next); 672 end if; 673 end Next; 674 675 ---------- 676 -- Open -- 677 ---------- 678 679 procedure Open (File : out Text_File; Name : String) is 680 FD : File_Descriptor; 681 File_Name : String (1 .. Name'Length + 1); 682 683 begin 684 File_Name (1 .. Name'Length) := Name; 685 File_Name (File_Name'Last) := ASCII.NUL; 686 FD := Open_Read (Name => File_Name'Address, 687 Fmode => GNAT.OS_Lib.Text); 688 689 if FD = Invalid_FD then 690 File := null; 691 692 else 693 File := new Text_File_Data; 694 File.FD := FD; 695 File.Buffer_Len := 696 Read (FD => FD, 697 A => File.Buffer'Address, 698 N => File.Buffer'Length); 699 700 if File.Buffer_Len = 0 then 701 File.End_Of_File_Reached := True; 702 else 703 File.Cursor := 1; 704 end if; 705 end if; 706 end Open; 707 708 --------- 709 -- Put -- 710 --------- 711 712 procedure Put 713 (Into_List : in out Name_List_Index; 714 From_List : String_List_Id; 715 In_Tree : Project_Tree_Ref; 716 Lower_Case : Boolean := False) 717 is 718 Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared; 719 720 Current_Name : Name_List_Index; 721 List : String_List_Id; 722 Element : String_Element; 723 Last : Name_List_Index := 724 Name_List_Table.Last (Shared.Name_Lists); 725 Value : Name_Id; 726 727 begin 728 Current_Name := Into_List; 729 while Current_Name /= No_Name_List 730 and then Shared.Name_Lists.Table (Current_Name).Next /= No_Name_List 731 loop 732 Current_Name := Shared.Name_Lists.Table (Current_Name).Next; 733 end loop; 734 735 List := From_List; 736 while List /= Nil_String loop 737 Element := Shared.String_Elements.Table (List); 738 Value := Element.Value; 739 740 if Lower_Case then 741 Get_Name_String (Value); 742 To_Lower (Name_Buffer (1 .. Name_Len)); 743 Value := Name_Find; 744 end if; 745 746 Name_List_Table.Append 747 (Shared.Name_Lists, (Name => Value, Next => No_Name_List)); 748 749 Last := Last + 1; 750 751 if Current_Name = No_Name_List then 752 Into_List := Last; 753 else 754 Shared.Name_Lists.Table (Current_Name).Next := Last; 755 end if; 756 757 Current_Name := Last; 758 759 List := Element.Next; 760 end loop; 761 end Put; 762 763 procedure Put (File : Text_File; S : String) is 764 Len : Integer; 765 begin 766 if File = null then 767 Prj.Com.Fail ("Attempted to write on an invalid Text_File"); 768 769 elsif not File.Out_File then 770 Prj.Com.Fail ("Attempted to write an in Text_File"); 771 end if; 772 773 if File.Buffer_Len + S'Length > File.Buffer'Last then 774 -- Write buffer 775 Len := Write (File.FD, File.Buffer'Address, File.Buffer_Len); 776 777 if Len /= File.Buffer_Len then 778 Prj.Com.Fail ("Failed to write to an out Text_File"); 779 end if; 780 781 File.Buffer_Len := 0; 782 end if; 783 784 File.Buffer (File.Buffer_Len + 1 .. File.Buffer_Len + S'Length) := S; 785 File.Buffer_Len := File.Buffer_Len + S'Length; 786 end Put; 787 788 -------------- 789 -- Put_Line -- 790 -------------- 791 792 procedure Put_Line (File : Text_File; Line : String) is 793 L : String (1 .. Line'Length + 1); 794 begin 795 L (1 .. Line'Length) := Line; 796 L (L'Last) := ASCII.LF; 797 Put (File, L); 798 end Put_Line; 799 800 --------------------------- 801 -- Read_Source_Info_File -- 802 --------------------------- 803 804 procedure Read_Source_Info_File (Tree : Project_Tree_Ref) is 805 File : Text_File; 806 Info : Source_Info_Iterator; 807 Proj : Name_Id; 808 809 procedure Report_Error; 810 811 ------------------ 812 -- Report_Error -- 813 ------------------ 814 815 procedure Report_Error is 816 begin 817 Write_Line ("errors in source info file """ & 818 Tree.Source_Info_File_Name.all & '"'); 819 Tree.Source_Info_File_Exists := False; 820 end Report_Error; 821 822 begin 823 Source_Info_Project_HTable.Reset; 824 Source_Info_Table.Init; 825 826 if Tree.Source_Info_File_Name = null then 827 Tree.Source_Info_File_Exists := False; 828 return; 829 end if; 830 831 Open (File, Tree.Source_Info_File_Name.all); 832 833 if not Is_Valid (File) then 834 if Opt.Verbose_Mode then 835 Write_Line ("source info file " & Tree.Source_Info_File_Name.all & 836 " does not exist"); 837 end if; 838 839 Tree.Source_Info_File_Exists := False; 840 return; 841 end if; 842 843 Tree.Source_Info_File_Exists := True; 844 845 if Opt.Verbose_Mode then 846 Write_Line ("Reading source info file " & 847 Tree.Source_Info_File_Name.all); 848 end if; 849 850 Source_Loop : 851 while not End_Of_File (File) loop 852 Info := (new Source_Info_Data, 0); 853 Source_Info_Table.Increment_Last; 854 855 -- project name 856 Get_Line (File, Name_Buffer, Name_Len); 857 Proj := Name_Find; 858 Info.Info.Project := Proj; 859 Info.Next := Source_Info_Project_HTable.Get (Proj); 860 Source_Info_Project_HTable.Set (Proj, Source_Info_Table.Last); 861 862 if End_Of_File (File) then 863 Report_Error; 864 exit Source_Loop; 865 end if; 866 867 -- language name 868 Get_Line (File, Name_Buffer, Name_Len); 869 Info.Info.Language := Name_Find; 870 871 if End_Of_File (File) then 872 Report_Error; 873 exit Source_Loop; 874 end if; 875 876 -- kind 877 Get_Line (File, Name_Buffer, Name_Len); 878 Info.Info.Kind := Source_Kind'Value (Name_Buffer (1 .. Name_Len)); 879 880 if End_Of_File (File) then 881 Report_Error; 882 exit Source_Loop; 883 end if; 884 885 -- display path name 886 Get_Line (File, Name_Buffer, Name_Len); 887 Info.Info.Display_Path_Name := Name_Find; 888 Info.Info.Path_Name := Info.Info.Display_Path_Name; 889 890 if End_Of_File (File) then 891 Report_Error; 892 exit Source_Loop; 893 end if; 894 895 -- optional fields 896 Option_Loop : 897 loop 898 Get_Line (File, Name_Buffer, Name_Len); 899 exit Option_Loop when Name_Len = 0; 900 901 if Name_Len <= 2 then 902 Report_Error; 903 exit Source_Loop; 904 905 else 906 if Name_Buffer (1 .. 2) = "P=" then 907 Name_Buffer (1 .. Name_Len - 2) := 908 Name_Buffer (3 .. Name_Len); 909 Name_Len := Name_Len - 2; 910 Info.Info.Path_Name := Name_Find; 911 912 elsif Name_Buffer (1 .. 2) = "U=" then 913 Name_Buffer (1 .. Name_Len - 2) := 914 Name_Buffer (3 .. Name_Len); 915 Name_Len := Name_Len - 2; 916 Info.Info.Unit_Name := Name_Find; 917 918 elsif Name_Buffer (1 .. 2) = "I=" then 919 Info.Info.Index := Int'Value (Name_Buffer (3 .. Name_Len)); 920 921 elsif Name_Buffer (1 .. Name_Len) = "N=Y" then 922 Info.Info.Naming_Exception := Yes; 923 924 elsif Name_Buffer (1 .. Name_Len) = "N=I" then 925 Info.Info.Naming_Exception := Inherited; 926 927 else 928 Report_Error; 929 exit Source_Loop; 930 end if; 931 end if; 932 end loop Option_Loop; 933 934 Source_Info_Table.Table (Source_Info_Table.Last) := Info; 935 end loop Source_Loop; 936 937 Close (File); 938 939 exception 940 when others => 941 Close (File); 942 Report_Error; 943 end Read_Source_Info_File; 944 945 -------------------- 946 -- Source_Info_Of -- 947 -------------------- 948 949 function Source_Info_Of (Iter : Source_Info_Iterator) return Source_Info is 950 begin 951 return Iter.Info; 952 end Source_Info_Of; 953 954 -------------- 955 -- Value_Of -- 956 -------------- 957 958 function Value_Of 959 (Variable : Variable_Value; 960 Default : String) return String 961 is 962 begin 963 if Variable.Kind /= Single 964 or else Variable.Default 965 or else Variable.Value = No_Name 966 then 967 return Default; 968 else 969 return Get_Name_String (Variable.Value); 970 end if; 971 end Value_Of; 972 973 function Value_Of 974 (Index : Name_Id; 975 In_Array : Array_Element_Id; 976 Shared : Shared_Project_Tree_Data_Access) return Name_Id 977 is 978 979 Current : Array_Element_Id; 980 Element : Array_Element; 981 Real_Index : Name_Id := Index; 982 983 begin 984 Current := In_Array; 985 986 if Current = No_Array_Element then 987 return No_Name; 988 end if; 989 990 Element := Shared.Array_Elements.Table (Current); 991 992 if not Element.Index_Case_Sensitive then 993 Get_Name_String (Index); 994 To_Lower (Name_Buffer (1 .. Name_Len)); 995 Real_Index := Name_Find; 996 end if; 997 998 while Current /= No_Array_Element loop 999 Element := Shared.Array_Elements.Table (Current); 1000 1001 if Real_Index = Element.Index then 1002 exit when Element.Value.Kind /= Single; 1003 exit when Element.Value.Value = Empty_String; 1004 return Element.Value.Value; 1005 else 1006 Current := Element.Next; 1007 end if; 1008 end loop; 1009 1010 return No_Name; 1011 end Value_Of; 1012 1013 function Value_Of 1014 (Index : Name_Id; 1015 Src_Index : Int := 0; 1016 In_Array : Array_Element_Id; 1017 Shared : Shared_Project_Tree_Data_Access; 1018 Force_Lower_Case_Index : Boolean := False; 1019 Allow_Wildcards : Boolean := False) return Variable_Value 1020 is 1021 Current : Array_Element_Id; 1022 Element : Array_Element; 1023 Real_Index_1 : Name_Id; 1024 Real_Index_2 : Name_Id; 1025 1026 begin 1027 Current := In_Array; 1028 1029 if Current = No_Array_Element then 1030 return Nil_Variable_Value; 1031 end if; 1032 1033 Element := Shared.Array_Elements.Table (Current); 1034 1035 Real_Index_1 := Index; 1036 1037 if not Element.Index_Case_Sensitive or else Force_Lower_Case_Index then 1038 if Index /= All_Other_Names then 1039 Get_Name_String (Index); 1040 To_Lower (Name_Buffer (1 .. Name_Len)); 1041 Real_Index_1 := Name_Find; 1042 end if; 1043 end if; 1044 1045 while Current /= No_Array_Element loop 1046 Element := Shared.Array_Elements.Table (Current); 1047 Real_Index_2 := Element.Index; 1048 1049 if not Element.Index_Case_Sensitive 1050 or else Force_Lower_Case_Index 1051 then 1052 if Element.Index /= All_Other_Names then 1053 Get_Name_String (Element.Index); 1054 To_Lower (Name_Buffer (1 .. Name_Len)); 1055 Real_Index_2 := Name_Find; 1056 end if; 1057 end if; 1058 1059 if Src_Index = Element.Src_Index and then 1060 (Real_Index_1 = Real_Index_2 or else 1061 (Real_Index_2 /= All_Other_Names and then 1062 Allow_Wildcards and then 1063 Match (Get_Name_String (Real_Index_1), 1064 Compile (Get_Name_String (Real_Index_2), 1065 Glob => True)))) 1066 then 1067 return Element.Value; 1068 else 1069 Current := Element.Next; 1070 end if; 1071 end loop; 1072 1073 return Nil_Variable_Value; 1074 end Value_Of; 1075 1076 function Value_Of 1077 (Name : Name_Id; 1078 Index : Int := 0; 1079 Attribute_Or_Array_Name : Name_Id; 1080 In_Package : Package_Id; 1081 Shared : Shared_Project_Tree_Data_Access; 1082 Force_Lower_Case_Index : Boolean := False; 1083 Allow_Wildcards : Boolean := False) return Variable_Value 1084 is 1085 The_Array : Array_Element_Id; 1086 The_Attribute : Variable_Value := Nil_Variable_Value; 1087 1088 begin 1089 if In_Package /= No_Package then 1090 1091 -- First, look if there is an array element that fits 1092 1093 The_Array := 1094 Value_Of 1095 (Name => Attribute_Or_Array_Name, 1096 In_Arrays => Shared.Packages.Table (In_Package).Decl.Arrays, 1097 Shared => Shared); 1098 The_Attribute := 1099 Value_Of 1100 (Index => Name, 1101 Src_Index => Index, 1102 In_Array => The_Array, 1103 Shared => Shared, 1104 Force_Lower_Case_Index => Force_Lower_Case_Index, 1105 Allow_Wildcards => Allow_Wildcards); 1106 1107 -- If there is no array element, look for a variable 1108 1109 if The_Attribute = Nil_Variable_Value then 1110 The_Attribute := 1111 Value_Of 1112 (Variable_Name => Attribute_Or_Array_Name, 1113 In_Variables => Shared.Packages.Table 1114 (In_Package).Decl.Attributes, 1115 Shared => Shared); 1116 end if; 1117 end if; 1118 1119 return The_Attribute; 1120 end Value_Of; 1121 1122 function Value_Of 1123 (Index : Name_Id; 1124 In_Array : Name_Id; 1125 In_Arrays : Array_Id; 1126 Shared : Shared_Project_Tree_Data_Access) return Name_Id 1127 is 1128 Current : Array_Id; 1129 The_Array : Array_Data; 1130 1131 begin 1132 Current := In_Arrays; 1133 while Current /= No_Array loop 1134 The_Array := Shared.Arrays.Table (Current); 1135 if The_Array.Name = In_Array then 1136 return Value_Of 1137 (Index, In_Array => The_Array.Value, Shared => Shared); 1138 else 1139 Current := The_Array.Next; 1140 end if; 1141 end loop; 1142 1143 return No_Name; 1144 end Value_Of; 1145 1146 function Value_Of 1147 (Name : Name_Id; 1148 In_Arrays : Array_Id; 1149 Shared : Shared_Project_Tree_Data_Access) return Array_Element_Id 1150 is 1151 Current : Array_Id; 1152 The_Array : Array_Data; 1153 1154 begin 1155 Current := In_Arrays; 1156 while Current /= No_Array loop 1157 The_Array := Shared.Arrays.Table (Current); 1158 1159 if The_Array.Name = Name then 1160 return The_Array.Value; 1161 else 1162 Current := The_Array.Next; 1163 end if; 1164 end loop; 1165 1166 return No_Array_Element; 1167 end Value_Of; 1168 1169 function Value_Of 1170 (Name : Name_Id; 1171 In_Packages : Package_Id; 1172 Shared : Shared_Project_Tree_Data_Access) return Package_Id 1173 is 1174 Current : Package_Id; 1175 The_Package : Package_Element; 1176 1177 begin 1178 Current := In_Packages; 1179 while Current /= No_Package loop 1180 The_Package := Shared.Packages.Table (Current); 1181 exit when The_Package.Name /= No_Name 1182 and then The_Package.Name = Name; 1183 Current := The_Package.Next; 1184 end loop; 1185 1186 return Current; 1187 end Value_Of; 1188 1189 function Value_Of 1190 (Variable_Name : Name_Id; 1191 In_Variables : Variable_Id; 1192 Shared : Shared_Project_Tree_Data_Access) return Variable_Value 1193 is 1194 Current : Variable_Id; 1195 The_Variable : Variable; 1196 1197 begin 1198 Current := In_Variables; 1199 while Current /= No_Variable loop 1200 The_Variable := Shared.Variable_Elements.Table (Current); 1201 1202 if Variable_Name = The_Variable.Name then 1203 return The_Variable.Value; 1204 else 1205 Current := The_Variable.Next; 1206 end if; 1207 end loop; 1208 1209 return Nil_Variable_Value; 1210 end Value_Of; 1211 1212 ---------------------------- 1213 -- Write_Source_Info_File -- 1214 ---------------------------- 1215 1216 procedure Write_Source_Info_File (Tree : Project_Tree_Ref) is 1217 Iter : Source_Iterator := For_Each_Source (Tree); 1218 Source : Prj.Source_Id; 1219 File : Text_File; 1220 1221 begin 1222 if Opt.Verbose_Mode then 1223 Write_Line ("Writing new source info file " & 1224 Tree.Source_Info_File_Name.all); 1225 end if; 1226 1227 Create (File, Tree.Source_Info_File_Name.all); 1228 1229 if not Is_Valid (File) then 1230 Write_Line ("warning: unable to create source info file """ & 1231 Tree.Source_Info_File_Name.all & '"'); 1232 return; 1233 end if; 1234 1235 loop 1236 Source := Element (Iter); 1237 exit when Source = No_Source; 1238 1239 if not Source.Locally_Removed and then 1240 Source.Replaced_By = No_Source 1241 then 1242 -- Project name 1243 1244 Put_Line (File, Get_Name_String (Source.Project.Name)); 1245 1246 -- Language name 1247 1248 Put_Line (File, Get_Name_String (Source.Language.Name)); 1249 1250 -- Kind 1251 1252 Put_Line (File, Source.Kind'Img); 1253 1254 -- Display path name 1255 1256 Put_Line (File, Get_Name_String (Source.Path.Display_Name)); 1257 1258 -- Optional lines: 1259 1260 -- Path name (P=) 1261 1262 if Source.Path.Name /= Source.Path.Display_Name then 1263 Put (File, "P="); 1264 Put_Line (File, Get_Name_String (Source.Path.Name)); 1265 end if; 1266 1267 -- Unit name (U=) 1268 1269 if Source.Unit /= No_Unit_Index then 1270 Put (File, "U="); 1271 Put_Line (File, Get_Name_String (Source.Unit.Name)); 1272 end if; 1273 1274 -- Multi-source index (I=) 1275 1276 if Source.Index /= 0 then 1277 Put (File, "I="); 1278 Put_Line (File, Source.Index'Img); 1279 end if; 1280 1281 -- Naming exception ("N=T"); 1282 1283 if Source.Naming_Exception = Yes then 1284 Put_Line (File, "N=Y"); 1285 1286 elsif Source.Naming_Exception = Inherited then 1287 Put_Line (File, "N=I"); 1288 end if; 1289 1290 -- Empty line to indicate end of info on this source 1291 1292 Put_Line (File, ""); 1293 end if; 1294 1295 Next (Iter); 1296 end loop; 1297 1298 Close (File); 1299 end Write_Source_Info_File; 1300 1301 --------------- 1302 -- Write_Str -- 1303 --------------- 1304 1305 procedure Write_Str 1306 (S : String; 1307 Max_Length : Positive; 1308 Separator : Character) 1309 is 1310 First : Positive := S'First; 1311 Last : Natural := S'Last; 1312 1313 begin 1314 -- Nothing to do for empty strings 1315 1316 if S'Length > 0 then 1317 1318 -- Start on a new line if current line is already longer than 1319 -- Max_Length. 1320 1321 if Positive (Column) >= Max_Length then 1322 Write_Eol; 1323 end if; 1324 1325 -- If length of remainder is longer than Max_Length, we need to 1326 -- cut the remainder in several lines. 1327 1328 while Positive (Column) + S'Last - First > Max_Length loop 1329 1330 -- Try the maximum length possible 1331 1332 Last := First + Max_Length - Positive (Column); 1333 1334 -- Look for last Separator in the line 1335 1336 while Last >= First and then S (Last) /= Separator loop 1337 Last := Last - 1; 1338 end loop; 1339 1340 -- If we do not find a separator, we output the maximum length 1341 -- possible. 1342 1343 if Last < First then 1344 Last := First + Max_Length - Positive (Column); 1345 end if; 1346 1347 Write_Line (S (First .. Last)); 1348 1349 -- Set the beginning of the new remainder 1350 1351 First := Last + 1; 1352 end loop; 1353 1354 -- What is left goes to the buffer, without EOL 1355 1356 Write_Str (S (First .. S'Last)); 1357 end if; 1358 end Write_Str; 1359end Prj.Util; 1360