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-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 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.Locally_Removed 471 and then (Project.Standalone_Library = No 472 or else Sid.Declared_In_Interfaces) 473 then 474 Action (Sid); 475 476 -- Check ALI for dependencies on body and sep 477 478 ALI := 479 Load_ALI 480 (Get_Name_String (Get_Object_Directory (Sid.Project, True)) 481 & Get_Name_String (Sid.Dep_Name)); 482 483 if ALI /= No_ALI_Id then 484 First_Unit := ALIs.Table (ALI).First_Unit; 485 Second_Unit := No_Unit_Id; 486 Body_Needed := True; 487 488 -- If there is both a spec and a body, check if both needed 489 490 if Units.Table (First_Unit).Utype = Is_Body then 491 Second_Unit := ALIs.Table (ALI).Last_Unit; 492 493 -- If the body is not needed, then reset First_Unit 494 495 if not Units.Table (Second_Unit).Body_Needed_For_SAL then 496 Body_Needed := False; 497 end if; 498 499 elsif Units.Table (First_Unit).Utype = Is_Spec_Only then 500 Body_Needed := False; 501 end if; 502 503 -- Handle all the separates, if any 504 505 if Body_Needed then 506 if Other_Part (Sid) /= null then 507 Deps.Include (Get_Name_String (Other_Part (Sid).File)); 508 end if; 509 510 for Dep in ALIs.Table (ALI).First_Sdep .. 511 ALIs.Table (ALI).Last_Sdep 512 loop 513 if Sdep.Table (Dep).Subunit_Name /= No_Name then 514 Deps.Include 515 (Get_Name_String (Sdep.Table (Dep).Sfile)); 516 end if; 517 end loop; 518 end if; 519 end if; 520 end if; 521 522 Next (Iter); 523 end loop; 524 525 -- Now handle the bodies and separates if needed 526 527 if Deps.Length /= 0 then 528 Iter := For_Each_Source (Tree, Project); 529 530 loop 531 Sid := Element (Iter); 532 exit when Sid = No_Source; 533 534 if Sid.Kind /= Spec 535 and then Deps.Contains (Get_Name_String (Sid.File)) 536 then 537 Action (Sid); 538 end if; 539 540 Next (Iter); 541 end loop; 542 end if; 543 end For_Interface_Sources; 544 545 -------------- 546 -- Get_Line -- 547 -------------- 548 549 procedure Get_Line 550 (File : Text_File; 551 Line : out String; 552 Last : out Natural) 553 is 554 C : Character; 555 556 procedure Advance; 557 558 ------------- 559 -- Advance -- 560 ------------- 561 562 procedure Advance is 563 begin 564 if File.Cursor = File.Buffer_Len then 565 File.Buffer_Len := 566 Read 567 (FD => File.FD, 568 A => File.Buffer'Address, 569 N => File.Buffer'Length); 570 571 if File.Buffer_Len = 0 then 572 File.End_Of_File_Reached := True; 573 return; 574 else 575 File.Cursor := 1; 576 end if; 577 578 else 579 File.Cursor := File.Cursor + 1; 580 end if; 581 end Advance; 582 583 -- Start of processing for Get_Line 584 585 begin 586 if File = null then 587 Prj.Com.Fail ("Get_Line attempted on an invalid Text_File"); 588 589 elsif File.Out_File then 590 Prj.Com.Fail ("Get_Line attempted on an out file"); 591 end if; 592 593 Last := Line'First - 1; 594 595 if not File.End_Of_File_Reached then 596 loop 597 C := File.Buffer (File.Cursor); 598 exit when C = ASCII.CR or else C = ASCII.LF; 599 Last := Last + 1; 600 Line (Last) := C; 601 Advance; 602 603 if File.End_Of_File_Reached then 604 return; 605 end if; 606 607 exit when Last = Line'Last; 608 end loop; 609 610 if C = ASCII.CR or else C = ASCII.LF then 611 Advance; 612 613 if File.End_Of_File_Reached then 614 return; 615 end if; 616 end if; 617 618 if C = ASCII.CR 619 and then File.Buffer (File.Cursor) = ASCII.LF 620 then 621 Advance; 622 end if; 623 end if; 624 end Get_Line; 625 626 ---------------- 627 -- Initialize -- 628 ---------------- 629 630 procedure Initialize 631 (Iter : out Source_Info_Iterator; 632 For_Project : Name_Id) 633 is 634 Ind : constant Natural := Source_Info_Project_HTable.Get (For_Project); 635 begin 636 if Ind = 0 then 637 Iter := (No_Source_Info, 0); 638 else 639 Iter := Source_Info_Table.Table (Ind); 640 end if; 641 end Initialize; 642 643 -------------- 644 -- Is_Valid -- 645 -------------- 646 647 function Is_Valid (File : Text_File) return Boolean is 648 begin 649 return File /= null; 650 end Is_Valid; 651 652 ---------- 653 -- Next -- 654 ---------- 655 656 procedure Next (Iter : in out Source_Info_Iterator) is 657 begin 658 if Iter.Next = 0 then 659 Iter.Info := No_Source_Info; 660 661 else 662 Iter := Source_Info_Table.Table (Iter.Next); 663 end if; 664 end Next; 665 666 ---------- 667 -- Open -- 668 ---------- 669 670 procedure Open (File : out Text_File; Name : String) is 671 FD : File_Descriptor; 672 File_Name : String (1 .. Name'Length + 1); 673 674 begin 675 File_Name (1 .. Name'Length) := Name; 676 File_Name (File_Name'Last) := ASCII.NUL; 677 FD := Open_Read (Name => File_Name'Address, 678 Fmode => GNAT.OS_Lib.Text); 679 680 if FD = Invalid_FD then 681 File := null; 682 683 else 684 File := new Text_File_Data; 685 File.FD := FD; 686 File.Buffer_Len := 687 Read (FD => FD, 688 A => File.Buffer'Address, 689 N => File.Buffer'Length); 690 691 if File.Buffer_Len = 0 then 692 File.End_Of_File_Reached := True; 693 else 694 File.Cursor := 1; 695 end if; 696 end if; 697 end Open; 698 699 --------- 700 -- Put -- 701 --------- 702 703 procedure Put 704 (Into_List : in out Name_List_Index; 705 From_List : String_List_Id; 706 In_Tree : Project_Tree_Ref; 707 Lower_Case : Boolean := False) 708 is 709 Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared; 710 711 Current_Name : Name_List_Index; 712 List : String_List_Id; 713 Element : String_Element; 714 Last : Name_List_Index := 715 Name_List_Table.Last (Shared.Name_Lists); 716 Value : Name_Id; 717 718 begin 719 Current_Name := Into_List; 720 while Current_Name /= No_Name_List 721 and then Shared.Name_Lists.Table (Current_Name).Next /= No_Name_List 722 loop 723 Current_Name := Shared.Name_Lists.Table (Current_Name).Next; 724 end loop; 725 726 List := From_List; 727 while List /= Nil_String loop 728 Element := Shared.String_Elements.Table (List); 729 Value := Element.Value; 730 731 if Lower_Case then 732 Get_Name_String (Value); 733 To_Lower (Name_Buffer (1 .. Name_Len)); 734 Value := Name_Find; 735 end if; 736 737 Name_List_Table.Append 738 (Shared.Name_Lists, (Name => Value, Next => No_Name_List)); 739 740 Last := Last + 1; 741 742 if Current_Name = No_Name_List then 743 Into_List := Last; 744 else 745 Shared.Name_Lists.Table (Current_Name).Next := Last; 746 end if; 747 748 Current_Name := Last; 749 750 List := Element.Next; 751 end loop; 752 end Put; 753 754 procedure Put (File : Text_File; S : String) is 755 Len : Integer; 756 begin 757 if File = null then 758 Prj.Com.Fail ("Attempted to write on an invalid Text_File"); 759 760 elsif not File.Out_File then 761 Prj.Com.Fail ("Attempted to write an in Text_File"); 762 end if; 763 764 if File.Buffer_Len + S'Length > File.Buffer'Last then 765 -- Write buffer 766 Len := Write (File.FD, File.Buffer'Address, File.Buffer_Len); 767 768 if Len /= File.Buffer_Len then 769 Prj.Com.Fail ("Failed to write to an out Text_File"); 770 end if; 771 772 File.Buffer_Len := 0; 773 end if; 774 775 File.Buffer (File.Buffer_Len + 1 .. File.Buffer_Len + S'Length) := S; 776 File.Buffer_Len := File.Buffer_Len + S'Length; 777 end Put; 778 779 -------------- 780 -- Put_Line -- 781 -------------- 782 783 procedure Put_Line (File : Text_File; Line : String) is 784 L : String (1 .. Line'Length + 1); 785 begin 786 L (1 .. Line'Length) := Line; 787 L (L'Last) := ASCII.LF; 788 Put (File, L); 789 end Put_Line; 790 791 --------------------------- 792 -- Read_Source_Info_File -- 793 --------------------------- 794 795 procedure Read_Source_Info_File (Tree : Project_Tree_Ref) is 796 File : Text_File; 797 Info : Source_Info_Iterator; 798 Proj : Name_Id; 799 800 procedure Report_Error; 801 802 ------------------ 803 -- Report_Error -- 804 ------------------ 805 806 procedure Report_Error is 807 begin 808 Write_Line ("errors in source info file """ & 809 Tree.Source_Info_File_Name.all & '"'); 810 Tree.Source_Info_File_Exists := False; 811 end Report_Error; 812 813 begin 814 Source_Info_Project_HTable.Reset; 815 Source_Info_Table.Init; 816 817 if Tree.Source_Info_File_Name = null then 818 Tree.Source_Info_File_Exists := False; 819 return; 820 end if; 821 822 Open (File, Tree.Source_Info_File_Name.all); 823 824 if not Is_Valid (File) then 825 if Opt.Verbose_Mode then 826 Write_Line ("source info file " & Tree.Source_Info_File_Name.all & 827 " does not exist"); 828 end if; 829 830 Tree.Source_Info_File_Exists := False; 831 return; 832 end if; 833 834 Tree.Source_Info_File_Exists := True; 835 836 if Opt.Verbose_Mode then 837 Write_Line ("Reading source info file " & 838 Tree.Source_Info_File_Name.all); 839 end if; 840 841 Source_Loop : 842 while not End_Of_File (File) loop 843 Info := (new Source_Info_Data, 0); 844 Source_Info_Table.Increment_Last; 845 846 -- project name 847 Get_Line (File, Name_Buffer, Name_Len); 848 Proj := Name_Find; 849 Info.Info.Project := Proj; 850 Info.Next := Source_Info_Project_HTable.Get (Proj); 851 Source_Info_Project_HTable.Set (Proj, Source_Info_Table.Last); 852 853 if End_Of_File (File) then 854 Report_Error; 855 exit Source_Loop; 856 end if; 857 858 -- language name 859 Get_Line (File, Name_Buffer, Name_Len); 860 Info.Info.Language := Name_Find; 861 862 if End_Of_File (File) then 863 Report_Error; 864 exit Source_Loop; 865 end if; 866 867 -- kind 868 Get_Line (File, Name_Buffer, Name_Len); 869 Info.Info.Kind := Source_Kind'Value (Name_Buffer (1 .. Name_Len)); 870 871 if End_Of_File (File) then 872 Report_Error; 873 exit Source_Loop; 874 end if; 875 876 -- display path name 877 Get_Line (File, Name_Buffer, Name_Len); 878 Info.Info.Display_Path_Name := Name_Find; 879 Info.Info.Path_Name := Info.Info.Display_Path_Name; 880 881 if End_Of_File (File) then 882 Report_Error; 883 exit Source_Loop; 884 end if; 885 886 -- optional fields 887 Option_Loop : 888 loop 889 Get_Line (File, Name_Buffer, Name_Len); 890 exit Option_Loop when Name_Len = 0; 891 892 if Name_Len <= 2 then 893 Report_Error; 894 exit Source_Loop; 895 896 else 897 if Name_Buffer (1 .. 2) = "P=" then 898 Name_Buffer (1 .. Name_Len - 2) := 899 Name_Buffer (3 .. Name_Len); 900 Name_Len := Name_Len - 2; 901 Info.Info.Path_Name := Name_Find; 902 903 elsif Name_Buffer (1 .. 2) = "U=" then 904 Name_Buffer (1 .. Name_Len - 2) := 905 Name_Buffer (3 .. Name_Len); 906 Name_Len := Name_Len - 2; 907 Info.Info.Unit_Name := Name_Find; 908 909 elsif Name_Buffer (1 .. 2) = "I=" then 910 Info.Info.Index := Int'Value (Name_Buffer (3 .. Name_Len)); 911 912 elsif Name_Buffer (1 .. Name_Len) = "N=Y" then 913 Info.Info.Naming_Exception := Yes; 914 915 elsif Name_Buffer (1 .. Name_Len) = "N=I" then 916 Info.Info.Naming_Exception := Inherited; 917 918 else 919 Report_Error; 920 exit Source_Loop; 921 end if; 922 end if; 923 end loop Option_Loop; 924 925 Source_Info_Table.Table (Source_Info_Table.Last) := Info; 926 end loop Source_Loop; 927 928 Close (File); 929 930 exception 931 when others => 932 Close (File); 933 Report_Error; 934 end Read_Source_Info_File; 935 936 -------------------- 937 -- Source_Info_Of -- 938 -------------------- 939 940 function Source_Info_Of (Iter : Source_Info_Iterator) return Source_Info is 941 begin 942 return Iter.Info; 943 end Source_Info_Of; 944 945 -------------- 946 -- Value_Of -- 947 -------------- 948 949 function Value_Of 950 (Variable : Variable_Value; 951 Default : String) return String 952 is 953 begin 954 if Variable.Kind /= Single 955 or else Variable.Default 956 or else Variable.Value = No_Name 957 then 958 return Default; 959 else 960 return Get_Name_String (Variable.Value); 961 end if; 962 end Value_Of; 963 964 function Value_Of 965 (Index : Name_Id; 966 In_Array : Array_Element_Id; 967 Shared : Shared_Project_Tree_Data_Access) return Name_Id 968 is 969 970 Current : Array_Element_Id; 971 Element : Array_Element; 972 Real_Index : Name_Id := Index; 973 974 begin 975 Current := In_Array; 976 977 if Current = No_Array_Element then 978 return No_Name; 979 end if; 980 981 Element := Shared.Array_Elements.Table (Current); 982 983 if not Element.Index_Case_Sensitive then 984 Get_Name_String (Index); 985 To_Lower (Name_Buffer (1 .. Name_Len)); 986 Real_Index := Name_Find; 987 end if; 988 989 while Current /= No_Array_Element loop 990 Element := Shared.Array_Elements.Table (Current); 991 992 if Real_Index = Element.Index then 993 exit when Element.Value.Kind /= Single; 994 exit when Element.Value.Value = Empty_String; 995 return Element.Value.Value; 996 else 997 Current := Element.Next; 998 end if; 999 end loop; 1000 1001 return No_Name; 1002 end Value_Of; 1003 1004 function Value_Of 1005 (Index : Name_Id; 1006 Src_Index : Int := 0; 1007 In_Array : Array_Element_Id; 1008 Shared : Shared_Project_Tree_Data_Access; 1009 Force_Lower_Case_Index : Boolean := False; 1010 Allow_Wildcards : Boolean := False) return Variable_Value 1011 is 1012 Current : Array_Element_Id; 1013 Element : Array_Element; 1014 Real_Index_1 : Name_Id; 1015 Real_Index_2 : Name_Id; 1016 1017 begin 1018 Current := In_Array; 1019 1020 if Current = No_Array_Element then 1021 return Nil_Variable_Value; 1022 end if; 1023 1024 Element := Shared.Array_Elements.Table (Current); 1025 1026 Real_Index_1 := Index; 1027 1028 if not Element.Index_Case_Sensitive or else Force_Lower_Case_Index then 1029 if Index /= All_Other_Names then 1030 Get_Name_String (Index); 1031 To_Lower (Name_Buffer (1 .. Name_Len)); 1032 Real_Index_1 := Name_Find; 1033 end if; 1034 end if; 1035 1036 while Current /= No_Array_Element loop 1037 Element := Shared.Array_Elements.Table (Current); 1038 Real_Index_2 := Element.Index; 1039 1040 if not Element.Index_Case_Sensitive 1041 or else Force_Lower_Case_Index 1042 then 1043 if Element.Index /= All_Other_Names then 1044 Get_Name_String (Element.Index); 1045 To_Lower (Name_Buffer (1 .. Name_Len)); 1046 Real_Index_2 := Name_Find; 1047 end if; 1048 end if; 1049 1050 if Src_Index = Element.Src_Index and then 1051 (Real_Index_1 = Real_Index_2 or else 1052 (Real_Index_2 /= All_Other_Names and then 1053 Allow_Wildcards and then 1054 Match (Get_Name_String (Real_Index_1), 1055 Compile (Get_Name_String (Real_Index_2), 1056 Glob => True)))) 1057 then 1058 return Element.Value; 1059 else 1060 Current := Element.Next; 1061 end if; 1062 end loop; 1063 1064 return Nil_Variable_Value; 1065 end Value_Of; 1066 1067 function Value_Of 1068 (Name : Name_Id; 1069 Index : Int := 0; 1070 Attribute_Or_Array_Name : Name_Id; 1071 In_Package : Package_Id; 1072 Shared : Shared_Project_Tree_Data_Access; 1073 Force_Lower_Case_Index : Boolean := False; 1074 Allow_Wildcards : Boolean := False) return Variable_Value 1075 is 1076 The_Array : Array_Element_Id; 1077 The_Attribute : Variable_Value := Nil_Variable_Value; 1078 1079 begin 1080 if In_Package /= No_Package then 1081 1082 -- First, look if there is an array element that fits 1083 1084 The_Array := 1085 Value_Of 1086 (Name => Attribute_Or_Array_Name, 1087 In_Arrays => Shared.Packages.Table (In_Package).Decl.Arrays, 1088 Shared => Shared); 1089 The_Attribute := 1090 Value_Of 1091 (Index => Name, 1092 Src_Index => Index, 1093 In_Array => The_Array, 1094 Shared => Shared, 1095 Force_Lower_Case_Index => Force_Lower_Case_Index, 1096 Allow_Wildcards => Allow_Wildcards); 1097 1098 -- If there is no array element, look for a variable 1099 1100 if The_Attribute = Nil_Variable_Value then 1101 The_Attribute := 1102 Value_Of 1103 (Variable_Name => Attribute_Or_Array_Name, 1104 In_Variables => Shared.Packages.Table 1105 (In_Package).Decl.Attributes, 1106 Shared => Shared); 1107 end if; 1108 end if; 1109 1110 return The_Attribute; 1111 end Value_Of; 1112 1113 function Value_Of 1114 (Index : Name_Id; 1115 In_Array : Name_Id; 1116 In_Arrays : Array_Id; 1117 Shared : Shared_Project_Tree_Data_Access) return Name_Id 1118 is 1119 Current : Array_Id; 1120 The_Array : Array_Data; 1121 1122 begin 1123 Current := In_Arrays; 1124 while Current /= No_Array loop 1125 The_Array := Shared.Arrays.Table (Current); 1126 if The_Array.Name = In_Array then 1127 return Value_Of 1128 (Index, In_Array => The_Array.Value, Shared => Shared); 1129 else 1130 Current := The_Array.Next; 1131 end if; 1132 end loop; 1133 1134 return No_Name; 1135 end Value_Of; 1136 1137 function Value_Of 1138 (Name : Name_Id; 1139 In_Arrays : Array_Id; 1140 Shared : Shared_Project_Tree_Data_Access) return Array_Element_Id 1141 is 1142 Current : Array_Id; 1143 The_Array : Array_Data; 1144 1145 begin 1146 Current := In_Arrays; 1147 while Current /= No_Array loop 1148 The_Array := Shared.Arrays.Table (Current); 1149 1150 if The_Array.Name = Name then 1151 return The_Array.Value; 1152 else 1153 Current := The_Array.Next; 1154 end if; 1155 end loop; 1156 1157 return No_Array_Element; 1158 end Value_Of; 1159 1160 function Value_Of 1161 (Name : Name_Id; 1162 In_Packages : Package_Id; 1163 Shared : Shared_Project_Tree_Data_Access) return Package_Id 1164 is 1165 Current : Package_Id; 1166 The_Package : Package_Element; 1167 1168 begin 1169 Current := In_Packages; 1170 while Current /= No_Package loop 1171 The_Package := Shared.Packages.Table (Current); 1172 exit when The_Package.Name /= No_Name 1173 and then The_Package.Name = Name; 1174 Current := The_Package.Next; 1175 end loop; 1176 1177 return Current; 1178 end Value_Of; 1179 1180 function Value_Of 1181 (Variable_Name : Name_Id; 1182 In_Variables : Variable_Id; 1183 Shared : Shared_Project_Tree_Data_Access) return Variable_Value 1184 is 1185 Current : Variable_Id; 1186 The_Variable : Variable; 1187 1188 begin 1189 Current := In_Variables; 1190 while Current /= No_Variable loop 1191 The_Variable := Shared.Variable_Elements.Table (Current); 1192 1193 if Variable_Name = The_Variable.Name then 1194 return The_Variable.Value; 1195 else 1196 Current := The_Variable.Next; 1197 end if; 1198 end loop; 1199 1200 return Nil_Variable_Value; 1201 end Value_Of; 1202 1203 ---------------------------- 1204 -- Write_Source_Info_File -- 1205 ---------------------------- 1206 1207 procedure Write_Source_Info_File (Tree : Project_Tree_Ref) is 1208 Iter : Source_Iterator := For_Each_Source (Tree); 1209 Source : Prj.Source_Id; 1210 File : Text_File; 1211 1212 begin 1213 if Opt.Verbose_Mode then 1214 Write_Line ("Writing new source info file " & 1215 Tree.Source_Info_File_Name.all); 1216 end if; 1217 1218 Create (File, Tree.Source_Info_File_Name.all); 1219 1220 if not Is_Valid (File) then 1221 Write_Line ("warning: unable to create source info file """ & 1222 Tree.Source_Info_File_Name.all & '"'); 1223 return; 1224 end if; 1225 1226 loop 1227 Source := Element (Iter); 1228 exit when Source = No_Source; 1229 1230 if not Source.Locally_Removed and then 1231 Source.Replaced_By = No_Source 1232 then 1233 -- Project name 1234 1235 Put_Line (File, Get_Name_String (Source.Project.Name)); 1236 1237 -- Language name 1238 1239 Put_Line (File, Get_Name_String (Source.Language.Name)); 1240 1241 -- Kind 1242 1243 Put_Line (File, Source.Kind'Img); 1244 1245 -- Display path name 1246 1247 Put_Line (File, Get_Name_String (Source.Path.Display_Name)); 1248 1249 -- Optional lines: 1250 1251 -- Path name (P=) 1252 1253 if Source.Path.Name /= Source.Path.Display_Name then 1254 Put (File, "P="); 1255 Put_Line (File, Get_Name_String (Source.Path.Name)); 1256 end if; 1257 1258 -- Unit name (U=) 1259 1260 if Source.Unit /= No_Unit_Index then 1261 Put (File, "U="); 1262 Put_Line (File, Get_Name_String (Source.Unit.Name)); 1263 end if; 1264 1265 -- Multi-source index (I=) 1266 1267 if Source.Index /= 0 then 1268 Put (File, "I="); 1269 Put_Line (File, Source.Index'Img); 1270 end if; 1271 1272 -- Naming exception ("N=T"); 1273 1274 if Source.Naming_Exception = Yes then 1275 Put_Line (File, "N=Y"); 1276 1277 elsif Source.Naming_Exception = Inherited then 1278 Put_Line (File, "N=I"); 1279 end if; 1280 1281 -- Empty line to indicate end of info on this source 1282 1283 Put_Line (File, ""); 1284 end if; 1285 1286 Next (Iter); 1287 end loop; 1288 1289 Close (File); 1290 end Write_Source_Info_File; 1291 1292 --------------- 1293 -- Write_Str -- 1294 --------------- 1295 1296 procedure Write_Str 1297 (S : String; 1298 Max_Length : Positive; 1299 Separator : Character) 1300 is 1301 First : Positive := S'First; 1302 Last : Natural := S'Last; 1303 1304 begin 1305 -- Nothing to do for empty strings 1306 1307 if S'Length > 0 then 1308 1309 -- Start on a new line if current line is already longer than 1310 -- Max_Length. 1311 1312 if Positive (Column) >= Max_Length then 1313 Write_Eol; 1314 end if; 1315 1316 -- If length of remainder is longer than Max_Length, we need to 1317 -- cut the remainder in several lines. 1318 1319 while Positive (Column) + S'Last - First > Max_Length loop 1320 1321 -- Try the maximum length possible 1322 1323 Last := First + Max_Length - Positive (Column); 1324 1325 -- Look for last Separator in the line 1326 1327 while Last >= First and then S (Last) /= Separator loop 1328 Last := Last - 1; 1329 end loop; 1330 1331 -- If we do not find a separator, we output the maximum length 1332 -- possible. 1333 1334 if Last < First then 1335 Last := First + Max_Length - Positive (Column); 1336 end if; 1337 1338 Write_Line (S (First .. Last)); 1339 1340 -- Set the beginning of the new remainder 1341 1342 First := Last + 1; 1343 end loop; 1344 1345 -- What is left goes to the buffer, without EOL 1346 1347 Write_Str (S (First .. S'Last)); 1348 end if; 1349 end Write_Str; 1350end Prj.Util; 1351