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