1------------------------------------------------------------------------------ 2-- -- 3-- ASIS UTILITY LIBRARY COMPONENTS -- 4-- -- 5-- A S I S _ U L . S O U R C E _ T A B L E -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2004-2016, AdaCore -- 10-- -- 11-- Asis Utility Library (ASIS UL) is free software; you can redistribute it -- 12-- and/or modify it under terms of the GNU General Public License as -- 13-- published by the Free Software Foundation; either version 3, or (at your -- 14-- option) any later version. ASIS UL is distributed in the hope that it -- 15-- will be useful, but WITHOUT ANY WARRANTY; without even the implied -- 16-- warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- 17-- GNU General Public License for more details. You should have received a -- 18-- copy of the GNU General Public License distributed with GNAT; see file -- 19-- COPYING3. If not, go to http://www.gnu.org/licenses for a complete copy -- 20-- of the license. -- 21-- -- 22-- ASIS UL is maintained by AdaCore (http://www.adacore.com). -- 23-- -- 24------------------------------------------------------------------------------ 25 26pragma Ada_2012; 27 28with Ada.Characters.Handling; use Ada.Characters.Handling; 29with Ada.Containers.Indefinite_Ordered_Sets; 30with Ada.Directories; 31with Ada.Strings; use Ada.Strings; 32with Ada.Strings.Fixed; use Ada.Strings.Fixed; 33with Ada.Text_IO; use Ada.Text_IO; 34 35with GNAT.Directory_Operations; use GNAT.Directory_Operations; 36 37with Asis.Compilation_Units; 38with Asis.Elements; 39with Asis.Extensions; 40with Asis.Extensions.Strings; use Asis.Extensions.Strings; 41 42with Table; 43 44with GNATCOLL.VFS; use GNATCOLL.VFS; 45 46with ASIS_UL.Common; use ASIS_UL.Common; 47with ASIS_UL.Compiler_Options; use ASIS_UL.Compiler_Options; 48with ASIS_UL.Debug; use ASIS_UL.Debug; 49with ASIS_UL.Environment; use ASIS_UL.Environment; 50with ASIS_UL.Misc; use ASIS_UL.Misc; 51with ASIS_UL.Options; use ASIS_UL.Options; 52with ASIS_UL.Output; use ASIS_UL.Output; 53with ASIS_UL.Tree_Creation; use ASIS_UL.Tree_Creation; 54 55package body ASIS_UL.Source_Table is 56 57 More_Then_One_Arg_File_Specified : Boolean := False; 58 Arg_File_Name : String_Access; 59 60 ----------------------------- 61 -- Temporary file storage -- 62 ----------------------------- 63 64 -- We use an ordered set for temporary file storage to ensure as much 65 -- determinism in the tool output as possible (in case if a tool prints out 66 -- the results and/or diagnoses on per-file basis). 67 68 function File_Name_Is_Less_Than (L, R : String) return Boolean; 69 -- Assuming that L and R are file names compares them as follows: 70 -- 71 -- * if L and/or R contains a directory separator, compares 72 -- lexicographicaly parts that follow the rightmost directory separator. 73 -- If these parts are equal, compares L and R lexicographicaly 74 -- 75 -- * otherwise compares L and R lexicographicaly 76 -- 77 -- Comparisons are case-sensitive. 78 79 package Temporary_File_Storages is new 80 Ada.Containers.Indefinite_Ordered_Sets 81 (Element_Type => String, 82 "<" => File_Name_Is_Less_Than); 83 use Temporary_File_Storages; 84 85 Temporary_File_Storage : Temporary_File_Storages.Set; 86 87 ----------------------- 88 -- Source File table -- 89 ----------------------- 90 91 type SF_Record is record 92 93 Source_Name : String_Loc; 94 -- If ASIS_UL.Common.Use_Project_File_Obsolete is set OFF, this field 95 -- stores the source name with full directory information in absolute 96 -- form, otherwise its value is the same as Short_Source_Name field. 97 98 Short_Source_Name : String_Loc; 99 -- The source name without directory information 100 101 Suffixless_Name : String_Loc; 102 -- The source name without directory information and suffix (if any) 103 -- is used to create the names of the tree file and ALI files 104 105 CU_Name : String_Loc; 106 -- The (full expanded) Ada name of a compilation unit contained in the 107 -- source, is set to Nil_String_Loc if the unit name is unknown at the 108 -- moment or if the source file does not contain a legal unit. 109 110 Could_Be_Body : Boolean; 111 -- This flag indicates that the source file could be a body. For now, 112 -- to decide that it could, we check that the suffix is '.adb' 113 114 Status : SF_Status; 115 -- Status of the given source. Initially is set to Waiting, then is 116 -- changed according to the results of the metrics computation 117 118 Hash_Link : SF_Id; 119 -- Link to next entry in files table for same hash code 120 121 Info : SF_Info; 122 -- An integer value associated with each source. The usage is up to a 123 -- client. 124 125 Switches : String_List_Access; 126 -- Used only if a project file is processed as a tool argument. Contains 127 -- the list of options to be passed to the compiler to create the tree. 128 129 Result_Dir : String_Access; 130 -- Used only if a project file is processed as a tool argument. Contains 131 -- the path to the directory the per-source results should be placed in. 132 end record; 133 134 package Source_File_Table is new Table.Table ( 135 Table_Component_Type => SF_Record, 136 Table_Index_Type => SF_Id, 137 Table_Low_Bound => First_SF_Id, 138 Table_Initial => 100, 139 Table_Increment => 100, 140 Table_Name => "Source file table"); 141 142 Source_Table : Source_File_Table.Table_Ptr renames Source_File_Table.Table; 143 144 Last_Arg_Source : SF_Id := No_SF_Id; 145 -- Used to store the Id of the last argument source 146 147 Next_Source : SF_Id := First_SF_Id; 148 -- Used in source file iterator 149 150 Short_Source_Name_String : String_Access; 151 Full_Source_Name_String : String_Access; 152 -- Two handlers for a file name (with no path information and with full 153 -- absolute path) used for the file before we decide that the file should 154 -- be stored into a file table. Also used in File_Find for storing the 155 -- short file name to be passed into Hash function. 156 157 New_SF_Record : constant SF_Record := 158 (Source_Name => Nil_String_Loc, 159 Short_Source_Name => Nil_String_Loc, 160 Suffixless_Name => Nil_String_Loc, 161 CU_Name => Nil_String_Loc, 162 Status => Waiting, 163 Hash_Link => No_SF_Id, 164 Could_Be_Body => False, 165 Switches => null, 166 Result_Dir => null, 167 Info => 0); 168 -- Used to set the initial attributes for the new source file 169 170 -- Hash function is the same as in Namet, the only difference is the way 171 -- it takes the argument to compute the hash value: 172 173 Hash_Num : constant Integer := 2**12; 174 -- Number of headers in the hash table. Current hash algorithm is closely 175 -- tailored to this choice, so it can only be changed if a corresponding 176 -- change is made to the hash algorithm. 177 178 Hash_Max : constant Integer := Hash_Num - 1; 179 -- Indexes in the hash header table run from 0 to Hash_Num - 1 180 181 subtype Hash_Index_Type is Integer range 0 .. Hash_Max; 182 -- Range of hash index values 183 184 Hash_Table : array (Hash_Index_Type) of SF_Id := (others => No_SF_Id); 185 -- The hash table is used to locate existing entries in the files table. 186 -- The entries point to the first names table entry whose hash value 187 -- matches the hash code. Then subsequent names table entries with the 188 -- same hash code value are linked through the Hash_Link fields. 189 190 function Hash (File_Name : String) return Hash_Index_Type; 191 -- Compute hash code for the file name. The argument should be a short 192 -- file name with no directory information 193 194 function Same_Name_File_Find (Short_SF_Name : String) return SF_Id; 195 -- Similar to File_Find, but looks for the file with the same short name. 196 197 procedure Source_Debug_Image (SF : SF_Id); 198 -- Prints out the debug image of a single source stored in the source file 199 -- table 200 201 procedure Source_Table_Debug; 202 -- Prints the source table 203 204 function Non_Case_Sensitive_File_Find 205 (SF_Name : String; 206 Use_Short_Name : Boolean := False) 207 return SF_Id; 208 -- Used as a part of the implementation of File_Find. Tries to locate the 209 -- argument in the source table when all the path/file names are converted 210 -- to lower case. 211 212 ---------------------------------------------------------------------- 213 -- Source file access/update routines not used outside this package -- 214 ---------------------------------------------------------------------- 215 216 procedure Set_Source_Name (SF : SF_Id; N : String); 217 procedure Set_Short_Source_Name (SF : SF_Id; N : String); 218 procedure Set_Suffixless_Name (SF : SF_Id; N : String); 219 220 ----------------------- 221 -- Add_Needed_Source -- 222 ----------------------- 223 224 function Add_Needed_Source (Fname : String) return SF_Id is 225 Old_SF : SF_Id; 226 Hash_Index : Hash_Index_Type; 227 First_Idx : Natural; 228 Last_Idx : Natural; 229 230 Result : SF_Id; 231 begin 232 pragma Assert (Is_Regular_File (Fname)); 233 234 Source_File_Table.Append (New_SF_Record); 235 Result := Source_File_Table.Last; 236 237 if Debug_Flag_S then 238 Info ("Adding needed source :>" & Fname & "<, ID=" & Result'Img); 239 end if; 240 241 Short_Source_Name_String := new String'(Base_Name (Fname)); 242 Hash_Index := Hash (To_Lower (Short_Source_Name_String.all)); 243 244 if Present (Hash_Table (Hash_Index)) then 245 246 Old_SF := Hash_Table (Hash_Index); 247 248 while Present (Source_Table (Old_SF).Hash_Link) loop 249 Old_SF := Source_Table (Old_SF).Hash_Link; 250 end loop; 251 252 Source_Table (Old_SF).Hash_Link := Result; 253 254 else 255 Hash_Table (Hash_Index) := Result; 256 end if; 257 258 if Use_Project_File_Obsolete then 259 Set_Source_Name (Result, Short_Source_Name_String.all); 260 else 261 Set_Source_Name 262 (Result, 263 Normalize_Pathname 264 (Fname, 265 Resolve_Links => False, 266 Case_Sensitive => True)); 267 end if; 268 269 Set_Short_Source_Name (Result, Short_Source_Name_String.all); 270 271 First_Idx := Short_Source_Name_String'First; 272 Last_Idx := Short_Source_Name_String'Last; 273 274 for J in reverse First_Idx + 1 .. Last_Idx loop 275 276 if Short_Source_Name_String (J) = '.' then 277 Last_Idx := J - 1; 278 exit; 279 end if; 280 281 end loop; 282 283 Set_Suffixless_Name 284 (Result, Short_Source_Name_String (First_Idx .. Last_Idx)); 285 286 if To_Lower (Short_Source_Name_String 287 (Last_Idx + 1 .. Short_Source_Name_String'Last)) = ".adb" 288 then 289 Source_Table (Result).Could_Be_Body := True; 290 end if; 291 292 Free (Short_Source_Name_String); 293 294 return Result; 295 296 end Add_Needed_Source; 297 298 --------------------------- 299 -- Add_Source_To_Process -- 300 --------------------------- 301 302 procedure Add_Source_To_Process 303 (Fname : String; 304 Arg_Project : Arg_Project_Type'Class; 305 Duplication_Report : Boolean := True) 306 is 307 Old_SF : SF_Id; 308 New_SF : SF_Id; 309 310 Hash_Index : Hash_Index_Type; 311 312 First_Idx : Natural; 313 Last_Idx : Natural; 314 315 Res : Virtual_File; 316 317 begin 318 Free (Full_Source_Name_String); 319 Free (Short_Source_Name_String); 320 321 if Debug_Flag_S then 322 Info ("Adding file to source table:>" & Fname & "<"); 323 end if; 324 325 if not Use_Project_File_Obsolete then 326 327 if Is_Regular_File (Fname) then 328 Short_Source_Name_String := new String'(Fname); 329 else 330 if Is_Specified (Arg_Project) then 331 Res := Create (Arg_Project, +Fname); 332 333 if Res = No_File then 334 Free (Short_Source_Name_String); 335 else 336 Short_Source_Name_String := 337 new String'(Res.Display_Full_Name); 338 end if; 339 else 340 if Source_Search_Path /= null then 341 Short_Source_Name_String := 342 Locate_Regular_File (File_Name => Fname, 343 Path => Source_Search_Path.all); 344 end if; 345 end if; 346 end if; 347 348 if Short_Source_Name_String = null then 349 Warning (Fname & " not found"); 350 return; 351 else 352 Full_Source_Name_String := new String' 353 (Normalize_Pathname 354 (Short_Source_Name_String.all, 355 Resolve_Links => False, 356 Case_Sensitive => True)); 357 358 Free (Short_Source_Name_String); 359 end if; 360 361 end if; 362 363 Short_Source_Name_String := new String'(Base_Name (Fname)); 364 Hash_Index := Hash (To_Lower (Short_Source_Name_String.all)); 365 366 if Use_Project_File_Obsolete then 367 Old_SF := File_Find (Short_Source_Name_String.all); 368 369 if Present (Old_SF) then 370 371 if Duplication_Report or else Debug_Flag_S then 372 Error (Short_Source_Name_String.all & " duplicated"); 373 end if; 374 375 return; 376 end if; 377 378 else 379 380 -- Check if we already have a file with the same short name: 381 382 if Present (Hash_Table (Hash_Index)) then 383 Old_SF := File_Find (Full_Source_Name_String.all); 384 385 if Present (Old_SF) then 386 -- This means that we have already stored exactly the same 387 -- file. 388 if Duplication_Report or else Debug_Flag_S then 389 Error (Short_Source_Name_String.all & " duplicated"); 390 end if; 391 392 return; 393 else 394 Old_SF := Same_Name_File_Find (Full_Source_Name_String.all); 395 396 if Present (Old_SF) then 397 Error ("more than one version of " 398 & Short_Source_Name_String.all & " processed"); 399 end if; 400 401 end if; 402 403 end if; 404 405 end if; 406 407 -- If we are here, we have to store the file in the table 408 409 Source_File_Table.Append (New_SF_Record); 410 Last_Arg_Source := Source_File_Table.Last; 411 New_SF := Last_Arg_Source; 412 413 if Debug_Flag_S then 414 Info ("new source file index:" & New_SF'Img); 415 end if; 416 417 if Present (Hash_Table (Hash_Index)) then 418 419 Old_SF := Hash_Table (Hash_Index); 420 421 while Present (Source_Table (Old_SF).Hash_Link) loop 422 Old_SF := Source_Table (Old_SF).Hash_Link; 423 end loop; 424 425 Source_Table (Old_SF).Hash_Link := New_SF; 426 427 else 428 Hash_Table (Hash_Index) := New_SF; 429 end if; 430 431 if Use_Project_File_Obsolete then 432 Set_Source_Name (New_SF, Short_Source_Name_String.all); 433 else 434 Set_Source_Name (New_SF, Full_Source_Name_String.all); 435 end if; 436 437 Set_Short_Source_Name (New_SF, Short_Source_Name_String.all); 438 439 First_Idx := Short_Source_Name_String'First; 440 Last_Idx := Short_Source_Name_String'Last; 441 442 for J in reverse First_Idx + 1 .. Last_Idx loop 443 444 if Short_Source_Name_String (J) = '.' then 445 Last_Idx := J - 1; 446 exit; 447 end if; 448 449 end loop; 450 451 Set_Suffixless_Name 452 (New_SF, Short_Source_Name_String (First_Idx .. Last_Idx)); 453 454 if To_Lower (Short_Source_Name_String 455 (Last_Idx + 1 .. Short_Source_Name_String'Last)) = ".adb" 456 then 457 Source_Table (New_SF).Could_Be_Body := True; 458 elsif Last_Idx - 1 >= Short_Source_Name_String'First 459 and then 460 To_Lower (Short_Source_Name_String 461 (Last_Idx - 1 .. Short_Source_Name_String'Last)) = ".2.ada" 462 then 463 Source_Table (New_SF).Could_Be_Body := True; 464 end if; 465 466 Free (Short_Source_Name_String); 467 Free (Full_Source_Name_String); 468 469 end Add_Source_To_Process; 470 471 ------------------------------ 472 -- Add_Compilation_Switches -- 473 ------------------------------ 474 475 procedure Add_Compilation_Switches 476 (SF : SF_Id; 477 Switches : String_List_Access) 478 is 479 begin 480 Source_Table (SF).Switches := Switches; 481 end Add_Compilation_Switches; 482 483 -------------------------- 484 -- Arg_Source_File_Name -- 485 -------------------------- 486 487 function Arg_Source_File_Name return String is 488 begin 489 if Arg_File_Name = null then 490 return ""; 491 else 492 return Arg_File_Name.all; 493 end if; 494 end Arg_Source_File_Name; 495 496 -------------------------- 497 -- Compilation_Switches -- 498 -------------------------- 499 500 function Compilation_Switches (SF : SF_Id) return String_List is 501 begin 502 if Source_Table (SF).Switches = null then 503 return (1 .. 0 => <>); 504 else 505 return Source_Table (SF).Switches.all; 506 end if; 507 end Compilation_Switches; 508 509 ----------------- 510 -- Create_Tree -- 511 ----------------- 512 513 procedure Create_Tree 514 (SF : SF_Id; 515 Success : out Boolean; 516 Compiler_Out : String := ""; 517 All_Warnings_Off : Boolean := True) 518 is 519 use Ada.Directories; 520 begin 521 if Use_Parallel_Tree_Creation then 522 Make_Dir (Image (Integer (SF))); 523 524 Asis.Extensions.Compile 525 (new String'(Source_Name (SF)), 526 Arg_List.all & Compilation_Switches (SF) & 527 new String'("-o") & 528 new String'(Image (Integer (SF)) & Directory_Separator & 529 Suffixless_Name (SF) & ".o"), 530 Success, 531 GCC => Gcc_To_Call, 532 Use_GPRBUILD => Use_Gnatmake_To_Compile, 533 Result_In_Current_Dir => Project_Support_Type = 534 Use_Tmp_Project_File, 535 Compiler_Out => Compiler_Out, 536 All_Warnings_Off => All_Warnings_Off, 537 Display_Call => Debug_Mode or else Debug_Flag_C); 538 else 539 Asis.Extensions.Compile 540 (new String'(Source_Name (SF)), 541 Arg_List.all & Compilation_Switches (SF), 542 Success, 543 GCC => Gcc_To_Call, 544 Use_GPRBUILD => Use_Gnatmake_To_Compile, 545 Result_In_Current_Dir => Project_Support_Type = 546 Use_Tmp_Project_File, 547 Compiler_Out => Compiler_Out, 548 All_Warnings_Off => All_Warnings_Off, 549 Display_Call => Debug_Mode or else Debug_Flag_C); 550 end if; 551 552 if not Success then 553 Set_Source_Status (SF, Not_A_Legal_Source); 554 Illegal_File_Detected := True; 555 556 if not Fully_Quiet_Mode then 557 Error ("cannot compile """ & Short_Source_Name (SF) & """"); 558 end if; 559 else 560 Set_Source_Status (SF, Tree_Is_Ready); 561 562 -- Move the tree file into the right place for the ASIS tool to find 563 -- it. See comments on Compiler_Output_Subdir for details. 564 565 if Compiler_Output_Subdir /= null then 566 declare 567 Tree : constant String := Suffixless_Name (SF) & ".adt"; 568 begin 569 Rename_File 570 (Old_Name => Compose (Compiler_Output_Subdir.all, Tree), 571 New_Name => Compose (Current_Directory, Tree), 572 Success => Success); 573 end; 574 end if; 575 end if; 576 577 end Create_Tree; 578 579 ------------- 580 -- CU_Name -- 581 ------------- 582 583 function CU_Name (SF : SF_Id) return String is 584 begin 585 return Get_String (Source_Table (SF).CU_Name); 586 end CU_Name; 587 588 --------------- 589 -- File_Find -- 590 --------------- 591 592 function File_Find (El : Asis.Element) return SF_Id is 593 Result : SF_Id := No_SF_Id; 594 begin 595 596 if not Asis.Elements.Is_Nil (El) then 597 598 declare 599 Full_Source_Name : constant String := Normalize_Pathname 600 (To_String (Asis.Compilation_Units.Text_Name 601 (Asis.Elements.Enclosing_Compilation_Unit (El))), 602 Case_Sensitive => True); 603 604 Short_Source_Name : constant String := 605 Base_Name (Full_Source_Name); 606 begin 607 if Use_Project_File_Obsolete then 608 Result := File_Find (Short_Source_Name); 609 else 610 Result := File_Find (Full_Source_Name); 611 end if; 612 end; 613 end if; 614 615 return Result; 616 end File_Find; 617 618 function File_Find 619 (SF_Name : String; 620 Use_Short_Name : Boolean := False; 621 Case_Sensitive : Boolean := File_Names_Case_Sensitive) 622 return SF_Id 623 is 624 Result : SF_Id := No_SF_Id; 625 Next_SF : SF_Id; 626 Base_SF_Name : constant String := Base_Name (SF_Name); 627 begin 628 Next_SF := Hash_Table (Hash (Base_Name (SF_Name))); 629 630 while Present (Next_SF) loop 631 632 if ((Use_Project_File_Obsolete or else Use_Short_Name) 633 and then 634 Base_SF_Name = Short_Source_Name (Next_SF)) 635 or else 636 SF_Name = Source_Name (Next_SF) 637 then 638 Result := Next_SF; 639 exit; 640 end if; 641 642 Next_SF := Source_Table (Next_SF).Hash_Link; 643 end loop; 644 645 if not Present (Result) and then not Case_Sensitive then 646 Result := Non_Case_Sensitive_File_Find (SF_Name, Use_Short_Name); 647 end if; 648 649 return Result; 650 end File_Find; 651 652 ---------------------------- 653 -- File_Name_Is_Less_Than -- 654 ---------------------------- 655 656 function File_Name_Is_Less_Than (L, R : String) return Boolean is 657 L_Last : constant Natural := L'Last; 658 R_Last : constant Natural := R'Last; 659 660 L_Dir_Separator : Natural := 661 Index (L, (1 => Directory_Separator), Backward); 662 663 R_Dir_Separator : Natural := 664 Index (R, (1 => Directory_Separator), Backward); 665 666 begin 667 if L_Dir_Separator = 0 and then 668 R_Dir_Separator = 0 669 then 670 return L < R; 671 end if; 672 673 if L_Dir_Separator = 0 then 674 L_Dir_Separator := L'First; 675 end if; 676 677 if R_Dir_Separator = 0 then 678 R_Dir_Separator := R'First; 679 end if; 680 681 if L (L_Dir_Separator .. L_Last) = 682 R (R_Dir_Separator .. R_Last) 683 then 684 return L < R; 685 else 686 return L (L_Dir_Separator .. L_Last) < R (R_Dir_Separator .. R_Last); 687 end if; 688 689 end File_Name_Is_Less_Than; 690 691 --------------------------- 692 -- Files_In_Temp_Storage -- 693 --------------------------- 694 695 function Files_In_Temp_Storage return Natural is 696 begin 697 return Natural (Length (Temporary_File_Storage)); 698 end Files_In_Temp_Storage; 699 700 -------------------------------- 701 -- First_File_In_Temp_Storage -- 702 -------------------------------- 703 704 function First_File_In_Temp_Storage return String is 705 begin 706 return Ada.Directories.Simple_Name 707 (Element (First (Temporary_File_Storage))); 708 end First_File_In_Temp_Storage; 709 710 -------------------------------- 711 -- Get_Compiler_Out_File_Name -- 712 -------------------------------- 713 714 function Get_Compiler_Out_File_Name (SF : SF_Id) return String is 715 begin 716 return "COMPILER_OUT_" & Image (Integer (SF)); 717 end Get_Compiler_Out_File_Name; 718 719 -------------------- 720 -- Get_Result_Dir -- 721 -------------------- 722 723 function Get_Result_Dir (SF : SF_Id) return String is 724 begin 725 return 726 (if Source_Table (SF).Result_Dir = null then 727 "" 728 else 729 Source_Table (SF).Result_Dir.all & Directory_Separator); 730 731 end Get_Result_Dir; 732 733 ---------- 734 -- Hash -- 735 ---------- 736 737 -- The code is taken from Namet with small modifications 738 739 function Hash (File_Name : String) return Hash_Index_Type is 740 subtype Int_0_12 is Integer range 0 .. 12; 741 -- Used to avoid when others on case jump below 742 743 Name_Len : constant Natural := File_Name'Length; 744 Name_Buffer : constant String (1 .. Name_Len) := To_Lower (File_Name); 745 -- This allows us to use from Namet without any change at all 746 747 Even_Name_Len : Integer; 748 -- Last even numbered position (used for >12 case) 749 750 begin 751 752 -- Special test for 12 (rather than counting on a when others for the 753 -- case statement below) avoids some Ada compilers converting the case 754 -- statement into successive jumps. 755 756 -- The case of a name longer than 12 characters is handled by taking 757 -- the first 6 odd numbered characters and the last 6 even numbered 758 -- characters 759 760 if Name_Len > 12 then 761 Even_Name_Len := (Name_Len) / 2 * 2; 762 763 return (((((((((((( 764 Character'Pos (Name_Buffer (01))) * 2 + 765 Character'Pos (Name_Buffer (Even_Name_Len - 10))) * 2 + 766 Character'Pos (Name_Buffer (03))) * 2 + 767 Character'Pos (Name_Buffer (Even_Name_Len - 08))) * 2 + 768 Character'Pos (Name_Buffer (05))) * 2 + 769 Character'Pos (Name_Buffer (Even_Name_Len - 06))) * 2 + 770 Character'Pos (Name_Buffer (07))) * 2 + 771 Character'Pos (Name_Buffer (Even_Name_Len - 04))) * 2 + 772 Character'Pos (Name_Buffer (09))) * 2 + 773 Character'Pos (Name_Buffer (Even_Name_Len - 02))) * 2 + 774 Character'Pos (Name_Buffer (11))) * 2 + 775 Character'Pos (Name_Buffer (Even_Name_Len))) mod Hash_Num; 776 end if; 777 778 -- For the cases of 1-12 characters, all characters participate in the 779 -- hash. The positioning is randomized, with the bias that characters 780 -- later on participate fully (i.e. are added towards the right side). 781 782 case Int_0_12 (Name_Len) is 783 784 when 0 => 785 return 0; 786 787 when 1 => 788 return 789 Character'Pos (Name_Buffer (1)); 790 791 when 2 => 792 return (( 793 Character'Pos (Name_Buffer (1))) * 64 + 794 Character'Pos (Name_Buffer (2))) mod Hash_Num; 795 796 when 3 => 797 return ((( 798 Character'Pos (Name_Buffer (1))) * 16 + 799 Character'Pos (Name_Buffer (3))) * 16 + 800 Character'Pos (Name_Buffer (2))) mod Hash_Num; 801 802 when 4 => 803 return (((( 804 Character'Pos (Name_Buffer (1))) * 8 + 805 Character'Pos (Name_Buffer (2))) * 8 + 806 Character'Pos (Name_Buffer (3))) * 8 + 807 Character'Pos (Name_Buffer (4))) mod Hash_Num; 808 809 when 5 => 810 return ((((( 811 Character'Pos (Name_Buffer (4))) * 8 + 812 Character'Pos (Name_Buffer (1))) * 4 + 813 Character'Pos (Name_Buffer (3))) * 4 + 814 Character'Pos (Name_Buffer (5))) * 8 + 815 Character'Pos (Name_Buffer (2))) mod Hash_Num; 816 817 when 6 => 818 return (((((( 819 Character'Pos (Name_Buffer (5))) * 4 + 820 Character'Pos (Name_Buffer (1))) * 4 + 821 Character'Pos (Name_Buffer (4))) * 4 + 822 Character'Pos (Name_Buffer (2))) * 4 + 823 Character'Pos (Name_Buffer (6))) * 4 + 824 Character'Pos (Name_Buffer (3))) mod Hash_Num; 825 826 when 7 => 827 return ((((((( 828 Character'Pos (Name_Buffer (4))) * 4 + 829 Character'Pos (Name_Buffer (3))) * 4 + 830 Character'Pos (Name_Buffer (1))) * 4 + 831 Character'Pos (Name_Buffer (2))) * 2 + 832 Character'Pos (Name_Buffer (5))) * 2 + 833 Character'Pos (Name_Buffer (7))) * 2 + 834 Character'Pos (Name_Buffer (6))) mod Hash_Num; 835 836 when 8 => 837 return (((((((( 838 Character'Pos (Name_Buffer (2))) * 4 + 839 Character'Pos (Name_Buffer (1))) * 4 + 840 Character'Pos (Name_Buffer (3))) * 2 + 841 Character'Pos (Name_Buffer (5))) * 2 + 842 Character'Pos (Name_Buffer (7))) * 2 + 843 Character'Pos (Name_Buffer (6))) * 2 + 844 Character'Pos (Name_Buffer (4))) * 2 + 845 Character'Pos (Name_Buffer (8))) mod Hash_Num; 846 847 when 9 => 848 return ((((((((( 849 Character'Pos (Name_Buffer (2))) * 4 + 850 Character'Pos (Name_Buffer (1))) * 4 + 851 Character'Pos (Name_Buffer (3))) * 4 + 852 Character'Pos (Name_Buffer (4))) * 2 + 853 Character'Pos (Name_Buffer (8))) * 2 + 854 Character'Pos (Name_Buffer (7))) * 2 + 855 Character'Pos (Name_Buffer (5))) * 2 + 856 Character'Pos (Name_Buffer (6))) * 2 + 857 Character'Pos (Name_Buffer (9))) mod Hash_Num; 858 859 when 10 => 860 return (((((((((( 861 Character'Pos (Name_Buffer (01))) * 2 + 862 Character'Pos (Name_Buffer (02))) * 2 + 863 Character'Pos (Name_Buffer (08))) * 2 + 864 Character'Pos (Name_Buffer (03))) * 2 + 865 Character'Pos (Name_Buffer (04))) * 2 + 866 Character'Pos (Name_Buffer (09))) * 2 + 867 Character'Pos (Name_Buffer (06))) * 2 + 868 Character'Pos (Name_Buffer (05))) * 2 + 869 Character'Pos (Name_Buffer (07))) * 2 + 870 Character'Pos (Name_Buffer (10))) mod Hash_Num; 871 872 when 11 => 873 return ((((((((((( 874 Character'Pos (Name_Buffer (05))) * 2 + 875 Character'Pos (Name_Buffer (01))) * 2 + 876 Character'Pos (Name_Buffer (06))) * 2 + 877 Character'Pos (Name_Buffer (09))) * 2 + 878 Character'Pos (Name_Buffer (07))) * 2 + 879 Character'Pos (Name_Buffer (03))) * 2 + 880 Character'Pos (Name_Buffer (08))) * 2 + 881 Character'Pos (Name_Buffer (02))) * 2 + 882 Character'Pos (Name_Buffer (10))) * 2 + 883 Character'Pos (Name_Buffer (04))) * 2 + 884 Character'Pos (Name_Buffer (11))) mod Hash_Num; 885 886 when 12 => 887 return (((((((((((( 888 Character'Pos (Name_Buffer (03))) * 2 + 889 Character'Pos (Name_Buffer (02))) * 2 + 890 Character'Pos (Name_Buffer (05))) * 2 + 891 Character'Pos (Name_Buffer (01))) * 2 + 892 Character'Pos (Name_Buffer (06))) * 2 + 893 Character'Pos (Name_Buffer (04))) * 2 + 894 Character'Pos (Name_Buffer (08))) * 2 + 895 Character'Pos (Name_Buffer (11))) * 2 + 896 Character'Pos (Name_Buffer (07))) * 2 + 897 Character'Pos (Name_Buffer (09))) * 2 + 898 Character'Pos (Name_Buffer (10))) * 2 + 899 Character'Pos (Name_Buffer (12))) mod Hash_Num; 900 901 end case; 902 end Hash; 903 904 ------------------------ 905 -- Is_Argument_Source -- 906 ------------------------ 907 908 function Is_Argument_Source (SF : SF_Id) return Boolean is 909 begin 910 return SF in First_SF_Id .. Last_Argument_Source; 911 end Is_Argument_Source; 912 913 --------------- 914 -- Is_A_Body -- 915 --------------- 916 917 function Is_A_Body (SF : SF_Id) return Boolean is 918 begin 919 return Source_Table (SF).Could_Be_Body; 920 end Is_A_Body; 921 922 ---------------------- 923 -- Is_Needed_Source -- 924 ---------------------- 925 926 function Is_Needed_Source (SF : SF_Id) return Boolean is 927 begin 928 return SF in Last_Argument_Source + 1 .. Source_File_Table.Last; 929 end Is_Needed_Source; 930 931 ----------------- 932 -- Last_Source -- 933 ----------------- 934 935 function Last_Source return SF_Id is 936 begin 937 return Source_File_Table.Last; 938 end Last_Source; 939 940 -------------------------- 941 -- Last_Argument_Source -- 942 -------------------------- 943 944 function Last_Argument_Source return SF_Id is 945 begin 946 return Last_Arg_Source; 947 end Last_Argument_Source; 948 949 ------------------------------- 950 -- Next_Non_Processed_Source -- 951 ------------------------------- 952 953 function Next_Non_Processed_Source 954 (Only_Bodies : Boolean := False; 955 Include_Needed_Sources : Boolean := False) 956 return SF_Id 957 is 958 Up_To : SF_Id := Last_Argument_Source; 959 New_Source_Found : Boolean := False; 960 Move_Next_Source : Boolean := True; 961 Result : SF_Id; 962 begin 963 964 if Include_Needed_Sources then 965 Up_To := Last_Source; 966 end if; 967 968 for J in Next_Source .. Up_To loop 969 970 if Source_Status (J) in 971 Waiting | 972 Tree_Is_Ready | 973 Not_A_Legal_Source_Needs_Listing_Processing 974 and then (if Only_Bodies then Is_A_Body (J)) 975 then 976 Result := J; 977 New_Source_Found := True; 978 exit; 979 end if; 980 981 end loop; 982 983 if not New_Source_Found then 984 Result := No_SF_Id; 985 else 986 for J in Next_Source + 1 .. Result - 1 loop 987 if Source_Status (J) in 988 Waiting | 989 Waiting_Subunit | 990 Preparing_Tree 991 then 992 Move_Next_Source := False; 993 exit; 994 end if; 995 end loop; 996 997 if Move_Next_Source then 998 Next_Source := Result; 999 end if; 1000 end if; 1001 1002 return Result; 1003 end Next_Non_Processed_Source; 1004 1005 ---------------------------------- 1006 -- Non_Case_Sensitive_File_Find -- 1007 ---------------------------------- 1008 1009 function Non_Case_Sensitive_File_Find 1010 (SF_Name : String; 1011 Use_Short_Name : Boolean := False) 1012 return SF_Id 1013 is 1014 Result : SF_Id := No_SF_Id; 1015 Next_SF : SF_Id; 1016 Base_SF_Name : constant String := To_Lower (Base_Name (SF_Name)); 1017 Arg_Name : constant String := To_Lower (SF_Name); 1018 begin 1019 Next_SF := Hash_Table (Hash (Base_Name (SF_Name))); 1020 1021 while Present (Next_SF) loop 1022 1023 if ((Use_Project_File_Obsolete or else Use_Short_Name) 1024 and then 1025 Base_SF_Name = To_Lower (Short_Source_Name (Next_SF))) 1026 or else 1027 Arg_Name = To_Lower (Source_Name (Next_SF)) 1028 then 1029 Result := Next_SF; 1030 exit; 1031 end if; 1032 1033 Next_SF := Source_Table (Next_SF).Hash_Link; 1034 end loop; 1035 1036 return Result; 1037 end Non_Case_Sensitive_File_Find; 1038 1039 ------------------- 1040 -- Output_Source -- 1041 ------------------- 1042 1043 procedure Output_Source (SF : SF_Id) is 1044 N : constant String := Natural'Image (Sources_Left); 1045 begin 1046 if not (ASIS_UL.Common.Multiple_File_Mode or else Verbose_Mode) 1047 or else Is_Needed_Source (SF) or else Mimic_gcc 1048 then 1049 return; 1050 end if; 1051 1052 if Progress_Indicator_Mode then 1053 declare 1054 Current : constant Integer := Total_Sources - Sources_Left + 1; 1055 Percent : String := 1056 Integer'Image ((Current * 100) / Total_Sources); 1057 begin 1058 Percent (1) := '('; 1059 Info ("completed" & Integer'Image (Current) & " out of" 1060 & Integer'Image (Total_Sources) & " " 1061 & Percent & "%)..."); 1062 end; 1063 end if; 1064 1065 if Verbose_Mode or else Debug_Mode or else Debug_Flag_S then 1066 Info_No_EOL ("[" & N (2 .. N'Last) & "] "); 1067 1068 if Debug_Flag_S then 1069 Info (Source_Name (SF)); 1070 else 1071 Info (Short_Source_Name (SF)); 1072 end if; 1073 1074 elsif not (Quiet_Mode or Progress_Indicator_Mode) then 1075 Info_No_EOL ("Units remaining:"); 1076 Info_No_EOL (N); 1077 Info_No_EOL (" "); 1078 Info_No_EOL ((1 => ASCII.CR)); 1079 end if; 1080 1081 Sources_Left := Sources_Left - 1; 1082 1083 end Output_Source; 1084 1085 ------------- 1086 -- Present -- 1087 ------------- 1088 1089 function Present (SF : SF_Id) return Boolean is 1090 begin 1091 return SF in First_SF_Id .. Source_File_Table.Last; 1092 end Present; 1093 1094 ------------------------- 1095 -- Read_Args_From_File -- 1096 ------------------------- 1097 1098 procedure Read_Args_From_File 1099 (Par_File_Name : String; 1100 Arg_Project : Arg_Project_Type'Class; 1101 Store_With_No_Check : Boolean := False) 1102 is 1103 Arg_File : File_Type; 1104 File_Name_Buffer : String (1 .. 16 * 1024); 1105 File_Name_Len : Natural := 0; 1106 Next_Ch : Character; 1107 End_Of_Line : Boolean; 1108 1109 function Get_File_Name return String; 1110 -- Reads from Par_File_Name the name of the next file (the file to read 1111 -- from should exist and be opened). Returns an empty string if there is 1112 -- no file names in Par_File_Name any more 1113 1114 function Get_File_Name return String is 1115 begin 1116 File_Name_Len := 0; 1117 1118 if not End_Of_File (Arg_File) then 1119 Get (Arg_File, Next_Ch); 1120 1121 while Is_White_Space (Next_Ch) 1122 or else 1123 Next_Ch = ASCII.LF 1124 or else 1125 Next_Ch = ASCII.CR 1126 loop 1127 exit when End_Of_File (Arg_File); 1128 Get (Arg_File, Next_Ch); 1129 end loop; 1130 1131 -- If we are here. Next_Ch is neither a white space nor 1132 -- end-of-line character. Two cases are possible, they require 1133 -- different processing: 1134 -- 1135 -- 1. Next_Ch = '"', this means that the file name is surrounded 1136 -- by quotation marks and it can contain spaces inside. 1137 -- 1138 -- 2. Next_Ch /= '"', this means that the file name is bounded by 1139 -- a white space or end-of-line character 1140 1141 if Next_Ch = '"' then 1142 1143 -- We do not generate any warning for badly formatted content 1144 -- of the file such as 1145 -- 1146 -- file_name_1 1147 -- "file name 2 1148 -- file_name_3 1149 -- 1150 -- (We do not check that quotation marks correctly go by pairs) 1151 1152 -- Skip leading '"' 1153 Get (Arg_File, Next_Ch); 1154 1155 while not (Next_Ch = '"' 1156 or else 1157 Next_Ch = ASCII.LF 1158 or else 1159 Next_Ch = ASCII.CR) 1160 loop 1161 File_Name_Len := File_Name_Len + 1; 1162 File_Name_Buffer (File_Name_Len) := Next_Ch; 1163 1164 Look_Ahead (Arg_File, Next_Ch, End_Of_Line); 1165 1166 exit when End_Of_Line or else End_Of_File (Arg_File); 1167 1168 Get (Arg_File, Next_Ch); 1169 end loop; 1170 1171 if Next_Ch = '"' 1172 and then 1173 not Ada.Text_IO.End_Of_Line (Arg_File) 1174 then 1175 -- skip trailing '"' 1176 Get (Arg_File, Next_Ch); 1177 end if; 1178 else 1179 while not (Is_White_Space (Next_Ch) 1180 or else 1181 Next_Ch = ASCII.LF 1182 or else 1183 Next_Ch = ASCII.CR) 1184 loop 1185 File_Name_Len := File_Name_Len + 1; 1186 File_Name_Buffer (File_Name_Len) := Next_Ch; 1187 1188 Look_Ahead (Arg_File, Next_Ch, End_Of_Line); 1189 1190 exit when End_Of_Line or else End_Of_File (Arg_File); 1191 1192 Get (Arg_File, Next_Ch); 1193 end loop; 1194 end if; 1195 1196 end if; 1197 1198 return File_Name_Buffer (1 .. File_Name_Len); 1199 end Get_File_Name; 1200 1201 -- Start of processing for Read_Args_From_File 1202 1203 begin 1204 ASIS_UL.Options.No_Argument_File_Specified := False; 1205 1206 if not Is_Regular_File (Par_File_Name) then 1207 Error (Par_File_Name & " does not exist"); 1208 return; 1209 end if; 1210 1211 Open (Arg_File, In_File, Par_File_Name); 1212 1213 loop 1214 declare 1215 Tmp_Str : constant String := Get_File_Name; 1216 begin 1217 exit when Tmp_Str = ""; 1218 1219 String_Utilities.String_Vectors.Append (Files_From_File, Tmp_Str); 1220 1221 if Store_With_No_Check then 1222 Store_Sources_To_Process (Tmp_Str); 1223 else 1224 Add_Source_To_Process (Tmp_Str, Arg_Project); 1225 end if; 1226 end; 1227 1228 end loop; 1229 1230 if not More_Then_One_Arg_File_Specified then 1231 1232 if Arg_File_Name /= null then 1233 -- We have already encountered one non-empty argument file 1234 Free (Arg_File_Name); 1235 More_Then_One_Arg_File_Specified := True; 1236 else 1237 Arg_File_Name := new String'(Par_File_Name); 1238 end if; 1239 1240 end if; 1241 1242 Close (Arg_File); 1243 exception 1244 when others => 1245 Error ("cannot read arguments from " & Par_File_Name); 1246 -- Exception info will be generated in main driver 1247 raise; 1248 end Read_Args_From_File; 1249 1250 -------------------------- 1251 -- Temp_Storage_Iterate -- 1252 -------------------------- 1253 1254 procedure Temp_Storage_Iterate 1255 (Action : not null access procedure (File_Name : String)) is 1256 C : Temporary_File_Storages.Cursor := First (Temporary_File_Storage); 1257 begin 1258 while C /= No_Element loop 1259 Action (Element (C)); 1260 C := Next (C); 1261 end loop; 1262 end Temp_Storage_Iterate; 1263 1264 --------------------------------- 1265 -- Read_Args_From_Temp_Storage -- 1266 --------------------------------- 1267 1268 procedure Read_Args_From_Temp_Storage 1269 (Duplication_Report : Boolean; 1270 Arg_Project : Arg_Project_Type'Class) 1271 is 1272 procedure Action (File_Name : String); 1273 procedure Action (File_Name : String) is 1274 begin 1275 Add_Source_To_Process 1276 (Fname => File_Name, 1277 Arg_Project => Arg_Project, 1278 Duplication_Report => Duplication_Report); 1279 end Action; 1280 begin 1281 Temp_Storage_Iterate (Action'Access); 1282 Clear (Temporary_File_Storage); 1283 end Read_Args_From_Temp_Storage; 1284 1285 --------------------------- 1286 -- Reset_Source_Iterator -- 1287 --------------------------- 1288 1289 procedure Reset_Source_Iterator is 1290 begin 1291 Next_Source := First_SF_Id; 1292 end Reset_Source_Iterator; 1293 1294 ------------------------- 1295 -- Same_Name_File_Find -- 1296 ------------------------- 1297 1298 function Same_Name_File_Find (Short_SF_Name : String) return SF_Id is 1299 Result : SF_Id := No_SF_Id; 1300 Next_SF : SF_Id; 1301 begin 1302 Next_SF := Hash_Table (Hash (Short_SF_Name)); 1303 1304 while Present (Next_SF) loop 1305 1306 if Short_SF_Name = Short_Source_Name (Next_SF) then 1307 Result := Next_SF; 1308 exit; 1309 end if; 1310 1311 Next_SF := Source_Table (Next_SF).Hash_Link; 1312 end loop; 1313 1314 return Result; 1315 end Same_Name_File_Find; 1316 1317 ----------------- 1318 -- Set_CU_Name -- 1319 ----------------- 1320 1321 procedure Set_CU_Name (SF : SF_Id; N : String) is 1322 begin 1323 Source_Table (SF).CU_Name := Enter_String (N); 1324 end Set_CU_Name; 1325 1326 -------------------- 1327 -- Set_Result_Dir -- 1328 -------------------- 1329 1330 procedure Set_Result_Dir 1331 (SF : SF_Id; 1332 Path : String) 1333 is 1334 begin 1335 Source_Table (SF).Result_Dir := new String'(Path); 1336 end Set_Result_Dir; 1337 1338 --------------------- 1339 -- Set_Source_Info -- 1340 --------------------- 1341 1342 procedure Set_Source_Info (SF : SF_Id; Info : SF_Info) is 1343 begin 1344 Source_Table (SF).Info := Info; 1345 end Set_Source_Info; 1346 1347 --------------------------- 1348 -- Set_Short_Source_Name -- 1349 --------------------------- 1350 1351 procedure Set_Short_Source_Name (SF : SF_Id; N : String) is 1352 begin 1353 Source_Table (SF).Short_Source_Name := Enter_String (N); 1354 end Set_Short_Source_Name; 1355 1356 --------------------- 1357 -- Set_Source_Name -- 1358 --------------------- 1359 1360 procedure Set_Source_Name (SF : SF_Id; N : String) is 1361 begin 1362 Source_Table (SF).Source_Name := Enter_String (N); 1363 end Set_Source_Name; 1364 1365 ----------------- 1366 -- Source_Info -- 1367 ----------------- 1368 1369 function Source_Info (SF : SF_Id) return SF_Info is 1370 begin 1371 return Source_Table (SF).Info; 1372 end Source_Info; 1373 1374 ----------------------- 1375 -- Set_Source_Status -- 1376 ----------------------- 1377 1378 procedure Set_Source_Status (SF : SF_Id; S : SF_Status) is 1379 begin 1380 Source_Table (SF).Status := S; 1381 1382 case S is 1383 when Not_A_Legal_Source => 1384 Illegal_Sources := Illegal_Sources + 1; 1385 when Error_Detected => 1386 Tool_Failures := Tool_Failures + 1; 1387 when Out_File_Problem => 1388 Out_File_Problems := Out_File_Problems + 1; 1389 when others => 1390 null; 1391 end case; 1392 1393 end Set_Source_Status; 1394 1395 ------------------------- 1396 -- Set_Suffixless_Name -- 1397 ------------------------- 1398 1399 procedure Set_Suffixless_Name (SF : SF_Id; N : String) is 1400 begin 1401 Source_Table (SF).Suffixless_Name := Enter_String (N); 1402 end Set_Suffixless_Name; 1403 1404 ----------------------- 1405 -- Short_Source_Name -- 1406 ----------------------- 1407 1408 function Short_Source_Name (SF : SF_Id) return String is 1409 begin 1410 return Get_String (Source_Table (SF).Short_Source_Name); 1411 end Short_Source_Name; 1412 1413 --------------------- 1414 -- Source_Clean_Up -- 1415 --------------------- 1416 1417 procedure Source_Clean_Up 1418 (SF : SF_Id; 1419 Keep_ALI_Files : Boolean := False) 1420 is 1421 Success : Boolean; 1422 begin 1423 Context_Clean_Up; 1424 1425 if Use_Parallel_Tree_Creation then 1426 Remove_Dir (Dir_Name => Image (Integer (SF)), Recursive => True); 1427 else 1428 Delete_File (Suffixless_Name (SF) & ".adt", Success); 1429 1430 if not Keep_ALI_Files then 1431 Delete_File (Suffixless_Name (SF) & ".ali", Success); 1432 end if; 1433 end if; 1434 end Source_Clean_Up; 1435 1436 ----------------- 1437 -- Source_Name -- 1438 ----------------- 1439 1440 function Source_Name (SF : SF_Id) return String is 1441 begin 1442 return Get_String (Source_Table (SF).Source_Name); 1443 end Source_Name; 1444 1445 ------------------- 1446 -- Source_Status -- 1447 ------------------- 1448 1449 function Source_Status (SF : SF_Id) return SF_Status is 1450 begin 1451 return Source_Table (SF).Status; 1452 end Source_Status; 1453 1454 ------------------------ 1455 -- Source_Debug_Image -- 1456 ------------------------ 1457 1458 procedure Source_Debug_Image (SF : SF_Id) is 1459 Ident_String : constant String := " "; 1460 Tmp : constant String_List := Compilation_Switches (SF); 1461 begin 1462 Info_No_EOL ("SF =" & SF'Img); 1463 if SF > Last_Source then 1464 Info_No_EOL (" ( > Last_Source =" & Last_Source'Img & ")"); 1465 end if; 1466 Info (""); 1467 1468 Info_No_EOL (Ident_String); 1469 Info ("Source_Name = >" & Source_Name (SF) & "<"); 1470 1471 Info_No_EOL (Ident_String); 1472 Info ("Short_Source_Name = >" & Short_Source_Name (SF) & "<"); 1473 1474 Info_No_EOL (Ident_String); 1475 Info ("Source_Status = " & Source_Status (SF)'Img); 1476 1477 Info_No_EOL (Ident_String); 1478 Info ("Contained Ada CU = >" & CU_Name (SF) & "<"); 1479 1480 Info_No_EOL (Ident_String); 1481 Info ("Hash_Link =" & 1482 Source_File_Table.Table (SF).Hash_Link'Img); 1483 1484 Info_No_EOL (Ident_String); 1485 Info_No_EOL ("Switches ="); 1486 1487 for J in Tmp'Range loop 1488 Info_No_EOL (Tmp (J).all & ' '); 1489 end loop; 1490 1491 Info (""); 1492 1493 if Source_File_Table.Table (SF).Info /= 0 then 1494 Info_No_EOL (Ident_String); 1495 Info ("Info =" & 1496 Source_File_Table.Table (SF).Info'Img); 1497 end if; 1498 1499 end Source_Debug_Image; 1500 1501 ------------------------ 1502 -- Source_Table_Debug -- 1503 ------------------------ 1504 1505 procedure Source_Table_Debug is 1506 begin 1507 Info ("-= SOURCE TABLE DEBUG IMAGE =-"); 1508 1509 if Last_Argument_Source < First_SF_Id then 1510 Info (" No source stored in source table"); 1511 return; 1512 end if; 1513 1514 Info (""); 1515 Info ("-= Argument sources =-"); 1516 1517 for J in First_SF_Id .. Last_Argument_Source loop 1518 Source_Debug_Image (J); 1519 end loop; 1520 1521 Info (""); 1522 1523 if Last_Source = Last_Argument_Source then 1524 Info (" No needed source added in source table"); 1525 return; 1526 end if; 1527 1528 Info ("-= Needed sources =-"); 1529 for J in Last_Argument_Source + 1 .. Last_Source loop 1530 Source_Debug_Image (J); 1531 end loop; 1532 end Source_Table_Debug; 1533 1534 ------------------------------ 1535 -- Source_Table_Debug_Image -- 1536 ------------------------------ 1537 1538 procedure Source_Table_Debug_Image is 1539 begin 1540 if Debug_Flag_S or else ASIS_UL.Options.Debug_Mode then 1541 Source_Table_Debug; 1542 end if; 1543 end Source_Table_Debug_Image; 1544 1545 ------------------------------ 1546 -- Store_Sources_To_Process -- 1547 ------------------------------ 1548 1549 procedure Store_Sources_To_Process 1550 (Fname : String; 1551 Store : Boolean := True) 1552 is 1553 begin 1554 ASIS_UL.Options.No_Argument_File_Specified := False; 1555 1556 if Store then 1557 Include (Temporary_File_Storage, Fname); 1558 1559 if Debug_Flag_S then 1560 Info ("Storing argument file:>" & Fname & "<"); 1561 end if; 1562 end if; 1563 end Store_Sources_To_Process; 1564 1565 --------------------- 1566 -- Suffixless_Name -- 1567 --------------------- 1568 1569 function Suffixless_Name (SF : SF_Id) return String is 1570 begin 1571 return Get_String (Source_Table (SF).Suffixless_Name); 1572 end Suffixless_Name; 1573 1574end ASIS_UL.Source_Table; 1575