1------------------------------------------------------------------------------ 2-- -- 3-- GNATTEST COMPONENTS -- 4-- -- 5-- G N A T T E S T . S T U B . S O U R C E _ T A B L E -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2011-2016, AdaCore -- 10-- -- 11-- GNATTEST is free software; you can redistribute it and/or modify it -- 12-- under terms of the GNU General Public License as published by the Free -- 13-- Software Foundation; either version 2, or (at your option) any later -- 14-- version. GNATTEST is distributed in the hope that it will be useful, -- 15-- but WITHOUT ANY WARRANTY; without even the implied warranty of -- 16-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General -- 17-- Public License for more details. You should have received a copy of the -- 18-- GNU General Public License distributed with GNAT; see file COPYING. If -- 19-- not, write to the Free Software Foundation, 51 Franklin Street, Fifth -- 20-- Floor, Boston, MA 02110-1301, USA., -- 21-- -- 22-- GNATTEST is maintained by AdaCore (http://www.adacore.com). -- 23-- -- 24------------------------------------------------------------------------------ 25 26pragma Ada_2005; 27 28with Ada.Containers.Indefinite_Ordered_Maps; 29 30with GNAT.OS_Lib; use GNAT.OS_Lib; 31with GNAT.Directory_Operations; use GNAT.Directory_Operations; 32 33with GNATtest.Options; use GNATtest.Options; 34 35with GNATCOLL.Projects; use GNATCOLL.Projects; 36with GNATCOLL.VFS; use GNATCOLL.VFS; 37with GNATCOLL.Traces; use GNATCOLL.Traces; 38 39with ASIS_UL.Output; use ASIS_UL.Output; 40with ASIS_UL.Options; use ASIS_UL.Options; 41 42with Ada.Characters.Handling; use Ada.Characters.Handling; 43 44package body GNATtest.Skeleton.Source_Table is 45 46 Me : constant Trace_Handle := Create ("Skeletons.Sources", Default => Off); 47 48 ----------------------- 49 -- Source File table -- 50 ----------------------- 51 52 Sources_Left : Natural := 0; 53 Total_Sources : Natural := 0; 54 55 type SF_Record; 56 57 type SF_Record is record 58 59 Full_Source_Name : String_Access; 60 -- This field stores the source name with full directory information 61 -- in absolute form 62 63 Suffixless_Name : String_Access; 64 -- The source name without directory information and suffix (if any) 65 -- is used to create the names of the tree file and ALI files 66 67 Test_Destination : String_Access; 68 -- The path to the corresponding test unit location. 69 70 Stub_Destination : String_Access; 71 -- The path to the corresponding stub unit location. 72 73 Status : SF_Status; 74 -- Status of the given source. Initially is set to Waiting, then is 75 -- changed according to the results of the metrics computation 76 77 Corresponding_Body : String_Access := null; 78 -- Set in Stub Mode for package specs. 79 80 Stub_Data_Base_Spec : String_Access; 81 Stub_Data_Base_Body : String_Access; 82 -- Different projects in the hierarchy may have different naming 83 -- schemes, but we won't have the access to this info once ASIS context 84 -- is generated, so we need to calculate those names beforehand. 85 86 Stub_Created : Boolean := False; 87 88 Project_Name : String_Access; 89 -- Name of corresponding project. Only relevant for bodies. 90 end record; 91 92 package Source_File_Table is new 93 Ada.Containers.Indefinite_Ordered_Maps (String, SF_Record); 94 95 Current_Source : String_Access := null; 96 97 use String_Set; 98 99 use Source_File_Table; 100 101 package Source_File_Locations renames String_Set; 102 103 SF_Table : Source_File_Table.Map; 104 -- Source Table itself 105 106 SFL_Table : Source_File_Locations.Set; 107 -- A set of paths to source files. Used for creation of project file. 108 109 SF_Process_Iterator : Source_File_Table.Cursor; 110 SF_Access_Iterator : Source_File_Table.Cursor; 111 SFL_Iterator : Source_File_Locations.Cursor; 112 113 Short_Source_Name_String : String_Access; 114 Full_Source_Name_String : String_Access; 115 116 procedure Reset_Source_Process_Iterator; 117 -- Sets SF_Iterator to the begining of SF_Table. 118 119 type Project_Record is record 120 Path : String_Access; 121 Obj_Dir : String_Access; 122 Stub_Dir : String_Access; 123 Importing_List : List_Of_Strings.List; 124 Imported_List : List_Of_Strings.List; 125 Limited_Withed : String_Set.Set; 126 Is_Externally_Built : Boolean; 127 128 Needed_For_Extention : Boolean := False; 129 end record; 130 131 use List_Of_Strings; 132 133 package Project_File_Table is new 134 Ada.Containers.Indefinite_Ordered_Maps (String, Project_Record); 135 use Project_File_Table; 136 137 PF_Table : Project_File_Table.Map; 138 139 function Is_Body (Source_Name : String) return Boolean; 140 141 ----------------------------- 142 -- Add_Source_To_Process -- 143 ----------------------------- 144 145 procedure Add_Source_To_Process (Fname : String) is 146 First_Idx : Natural; 147 Last_Idx : Natural; 148 149 New_SF_Record : SF_Record; 150 begin 151 Trace (Me, "adding source: " & Fname); 152 153 if not Is_Regular_File (Fname) then 154 Report_Std ("gnattest: " & Fname & " not found"); 155 return; 156 end if; 157 158 -- Check if we already have a file with the same short name: 159 Short_Source_Name_String := new String'(Base_Name (Fname)); 160 Full_Source_Name_String := 161 new String'(Normalize_Pathname 162 (Fname, 163 Resolve_Links => False, 164 Case_Sensitive => False)); 165 166 -- Making the new SF_Record 167 New_SF_Record.Full_Source_Name := 168 new String'(Full_Source_Name_String.all); 169 170 First_Idx := Short_Source_Name_String'First; 171 Last_Idx := Short_Source_Name_String'Last; 172 173 for J in reverse First_Idx + 1 .. Last_Idx loop 174 175 if Short_Source_Name_String (J) = '.' then 176 Last_Idx := J - 1; 177 exit; 178 end if; 179 180 end loop; 181 182 New_SF_Record.Suffixless_Name := 183 new String'(Short_Source_Name_String.all (First_Idx .. Last_Idx)); 184 185 New_SF_Record.Status := Waiting; 186 187 if Stub_Mode_ON then 188 declare 189 Given_File : constant GNATCOLL.VFS.Virtual_File := 190 Create (+Fname); 191 Other_File : constant GNATCOLL.VFS.Virtual_File := 192 Source_Project_Tree.Other_File (Given_File); 193 F_Info : constant File_Info := 194 Source_Project_Tree.Info (Given_File); 195 P : Project_Type; 196 begin 197 if Given_File /= Other_File 198 and then Is_Regular_File (Other_File.Display_Full_Name) 199 then 200 New_SF_Record.Corresponding_Body := 201 new String'(Other_File.Display_Full_Name); 202 end if; 203 204 New_SF_Record.Stub_Data_Base_Spec := new String' 205 (+ 206 (File_From_Unit 207 (Project => F_Info.Project, 208 Unit_Name => 209 F_Info.Unit_Name & "." & Stub_Data_Unit_Name, 210 Part => Unit_Spec, 211 Language => F_Info.Language, 212 File_Must_Exist => False))); 213 214 New_SF_Record.Stub_Data_Base_Body := new String' 215 (+ 216 (File_From_Unit 217 (Project => F_Info.Project, 218 Unit_Name => 219 F_Info.Unit_Name & "." & Stub_Data_Unit_Name, 220 Part => Unit_Body, 221 Language => F_Info.Language, 222 File_Must_Exist => False))); 223 224 P := F_Info.Project; 225 loop 226 exit when Extending_Project (P) = No_Project; 227 P := Extending_Project (P); 228 end loop; 229 230 New_SF_Record.Project_Name := new String'(P.Name); 231 end; 232 233 end if; 234 235 Insert (SF_Table, Full_Source_Name_String.all, New_SF_Record); 236 237 Include 238 (SFL_Table, 239 Normalize_Pathname (Name => Dir_Name (Full_Source_Name_String.all), 240 Resolve_Links => False, 241 Case_Sensitive => False)); 242 243 Sources_Left := Sources_Left + 1; 244 Total_Sources := Total_Sources + 1; 245 246 Free (Short_Source_Name_String); 247 Free (Full_Source_Name_String); 248 249 end Add_Source_To_Process; 250 251 ------------------------- 252 -- Add_Body_To_Process -- 253 ------------------------- 254 255 procedure Add_Body_To_Process (Fname : String; Pname : String) is 256 First_Idx : Natural; 257 Last_Idx : Natural; 258 259 New_SF_Record : SF_Record; 260 begin 261 Trace (Me, "adding " & Fname & " from project " & Pname); 262 -- Check if we already have a file with the same short name: 263 Short_Source_Name_String := new String'(Base_Name (Fname)); 264 Full_Source_Name_String := 265 new String'(Normalize_Pathname 266 (Fname, 267 Resolve_Links => False, 268 Case_Sensitive => False)); 269 270 -- Making the new SF_Record 271 New_SF_Record.Full_Source_Name := 272 new String'(Full_Source_Name_String.all); 273 274 First_Idx := Short_Source_Name_String'First; 275 Last_Idx := Short_Source_Name_String'Last; 276 277 for J in reverse First_Idx + 1 .. Last_Idx loop 278 279 if Short_Source_Name_String (J) = '.' then 280 Last_Idx := J - 1; 281 exit; 282 end if; 283 284 end loop; 285 286 New_SF_Record.Suffixless_Name := 287 new String'(Short_Source_Name_String.all (First_Idx .. Last_Idx)); 288 289 New_SF_Record.Status := To_Stub_Body; 290 291 New_SF_Record.Project_Name := new String'(Pname); 292 293 Insert (SF_Table, Full_Source_Name_String.all, New_SF_Record); 294 295 Include 296 (SFL_Table, 297 Normalize_Pathname (Name => Dir_Name (Full_Source_Name_String.all), 298 Resolve_Links => False, 299 Case_Sensitive => False)); 300 301 Free (Short_Source_Name_String); 302 Free (Full_Source_Name_String); 303 end Add_Body_To_Process; 304 305 ------------------------ 306 -- Add_Body_Reference -- 307 ------------------------ 308 309 procedure Add_Body_Reference (Fname : String) is 310 First_Idx : Natural; 311 Last_Idx : Natural; 312 313 New_SF_Record : SF_Record; 314 begin 315 if not Is_Regular_File (Fname) then 316 Report_Std ("gnattest: " & Fname & " not found"); 317 return; 318 end if; 319 320 Short_Source_Name_String := new String'(Base_Name (Fname)); 321 Full_Source_Name_String := 322 new String'(Normalize_Pathname 323 (Fname, 324 Resolve_Links => False, 325 Case_Sensitive => False)); 326 327 -- Already present specs should not be overridden 328 if 329 SF_Table.Find 330 (Full_Source_Name_String.all) /= Source_File_Table.No_Element 331 then 332 return; 333 end if; 334 335 -- Making the new SF_Record 336 New_SF_Record.Full_Source_Name := 337 new String'(Full_Source_Name_String.all); 338 339 First_Idx := Short_Source_Name_String'First; 340 Last_Idx := Short_Source_Name_String'Last; 341 342 for J in reverse First_Idx + 1 .. Last_Idx loop 343 344 if Short_Source_Name_String (J) = '.' then 345 Last_Idx := J - 1; 346 exit; 347 end if; 348 349 end loop; 350 351 New_SF_Record.Suffixless_Name := 352 new String'(Short_Source_Name_String.all (First_Idx .. Last_Idx)); 353 354 New_SF_Record.Status := Body_Reference; 355 356 declare 357 Given_File : constant GNATCOLL.VFS.Virtual_File := 358 Create (+Fname); 359 Other_File : constant GNATCOLL.VFS.Virtual_File := 360 Source_Project_Tree.Other_File (Given_File); 361 F_Info : constant File_Info := 362 Source_Project_Tree.Info (Given_File); 363 P : Project_Type; 364 begin 365 if Given_File /= Other_File 366 and then Is_Regular_File (Other_File.Display_Full_Name) 367 then 368 New_SF_Record.Corresponding_Body := 369 new String'(Other_File.Display_Full_Name); 370 end if; 371 372 New_SF_Record.Stub_Data_Base_Spec := new String' 373 (+ 374 (File_From_Unit 375 (Project => F_Info.Project, 376 Unit_Name => 377 F_Info.Unit_Name & "." & Stub_Data_Unit_Name, 378 Part => Unit_Spec, 379 Language => F_Info.Language, 380 File_Must_Exist => False))); 381 382 New_SF_Record.Stub_Data_Base_Body := new String' 383 (+ 384 (File_From_Unit 385 (Project => F_Info.Project, 386 Unit_Name => 387 F_Info.Unit_Name & "." & Stub_Data_Unit_Name, 388 Part => Unit_Body, 389 Language => F_Info.Language, 390 File_Must_Exist => False))); 391 392 P := F_Info.Project; 393 loop 394 exit when Extending_Project (P) = No_Project; 395 P := Extending_Project (P); 396 end loop; 397 New_SF_Record.Project_Name := new String'(P.Name); 398 end; 399 400 Insert (SF_Table, Full_Source_Name_String.all, New_SF_Record); 401 402 Free (Short_Source_Name_String); 403 Free (Full_Source_Name_String); 404 end Add_Body_Reference; 405 406 ---------------- 407 -- Is_Empty -- 408 ---------------- 409 function SF_Table_Empty return Boolean is 410 Empty : constant Boolean := Is_Empty (SF_Table); 411 Cur : Source_File_Table.Cursor; 412 begin 413 if Empty then 414 return Empty; 415 else 416 Cur := SF_Table.First; 417 while Cur /= Source_File_Table.No_Element loop 418 if Element (Cur).Status /= To_Stub_Body then 419 return False; 420 end if; 421 422 Next (Cur); 423 end loop; 424 425 return True; 426 end if; 427 end SF_Table_Empty; 428 429 -------------------------------------- 430 -- Enforce_Custom_Project_Extention -- 431 -------------------------------------- 432 433 procedure Enforce_Custom_Project_Extention 434 (File_Name : String; 435 Subroot_Stub_Prj : String; 436 Current_Source_Infix : String) 437 is 438 Short_Name : constant String := Base_Name (File_Name); 439 440 Excluded_Sources : String_Set.Set := String_Set.Empty_Set; 441 Current_Proj_Present_Sources : String_Set.Set := String_Set.Empty_Set; 442 Processed_Projects : String_Set.Set := String_Set.Empty_Set; 443 444 SS_Cur : String_Set.Cursor; 445 Subroot_Prj_Name : constant String := 446 Get_Source_Project_Name (File_Name); 447 448 procedure Process_Project (Proj : String); 449 450 procedure Set_Present_Subset_For_Project (Proj : String); 451 452 procedure Process_Project (Proj : String) is 453 Cur, I_Cur : List_Of_Strings.Cursor; 454 E_Cur : String_Set.Cursor; 455 Arg_Proj : Project_Record; 456 457 Relative_P_Path, Relative_I_Path : String_Access; 458 begin 459 if Processed_Projects.Contains (Proj) then 460 return; 461 end if; 462 Processed_Projects.Include (Proj); 463 Arg_Proj := PF_Table.Element (Proj); 464 465 if Proj = Subroot_Prj_Name then 466 -- The root of the subtree is extended by the test driver project. 467 goto Process_Imported; 468 end if; 469 470 if Arg_Proj.Needed_For_Extention then 471 472 Relative_P_Path := new String' 473 (+Relative_Path 474 (Create (+Arg_Proj.Path.all), 475 Create (+Arg_Proj.Stub_Dir.all))); 476 477 declare 478 F : File_Array_Access; 479 begin 480 Append 481 (F, 482 GNATCOLL.VFS.Create 483 (+(Arg_Proj.Stub_Dir.all))); 484 Append 485 (F, 486 GNATCOLL.VFS.Create 487 (+(Arg_Proj.Stub_Dir.all 488 & Directory_Separator 489 & Unit_To_File_Name 490 (Stub_Project_Prefix & Current_Source_Infix & Proj)))); 491 Create_Dirs (F); 492 end; 493 494 Trace 495 (Me, 496 "Creating " 497 & Arg_Proj.Stub_Dir.all 498 & Directory_Separator 499 & Unit_To_File_Name 500 (Stub_Project_Prefix & Current_Source_Infix & Proj) 501 & ".gpr"); 502 Create 503 (Arg_Proj.Stub_Dir.all 504 & Directory_Separator 505 & Unit_To_File_Name 506 (Stub_Project_Prefix & Current_Source_Infix & Proj) 507 & ".gpr"); 508 509 I_Cur := Arg_Proj.Imported_List.First; 510 while I_Cur /= List_Of_Strings.No_Element loop 511 if 512 PF_Table.Element 513 (List_Of_Strings.Element (I_Cur)).Needed_For_Extention 514 then 515 declare 516 Imported_Sub_Project : constant String := 517 PF_Table.Element 518 (List_Of_Strings.Element (I_Cur)).Stub_Dir.all 519 & Directory_Separator 520 & To_Lower (Stub_Project_Prefix 521 & Current_Source_Infix 522 & List_Of_Strings.Element (I_Cur)) 523 & ".gpr"; 524 begin 525 if List_Of_Strings.Element (I_Cur) = Subroot_Prj_Name then 526 Relative_I_Path := new String' 527 (+Relative_Path (Create (+Subroot_Stub_Prj), 528 Create (+Arg_Proj.Stub_Dir.all))); 529 else 530 Relative_I_Path := new String' 531 (+Relative_Path (Create (+Imported_Sub_Project), 532 Create (+Arg_Proj.Stub_Dir.all))); 533 end if; 534 end; 535 if Arg_Proj.Limited_Withed.Contains 536 (List_Of_Strings.Element (I_Cur)) 537 then 538 S_Put 539 (0, 540 "limited with """ 541 & Relative_I_Path.all 542 & """;"); 543 else 544 S_Put 545 (0, 546 "with """ 547 & Relative_I_Path.all 548 & """;"); 549 end if; 550 Put_New_Line; 551 end if; 552 Next (I_Cur); 553 end loop; 554 555 S_Put 556 (0, 557 "project " 558 & Stub_Project_Prefix 559 & Current_Source_Infix 560 & Proj 561 & " extends """ 562 & Relative_P_Path.all 563 & """ is"); 564 Put_New_Line; 565 S_Put (3, "for Source_Dirs use (""."");"); 566 Put_New_Line; 567 568 Set_Present_Subset_For_Project (Proj); 569 E_Cur := Current_Proj_Present_Sources.First; 570 if E_Cur /= String_Set.No_Element then 571 S_Put (3, "for Source_Files use ("); 572 Put_New_Line; 573 else 574 S_Put (3, "for Source_Files use ();"); 575 Put_New_Line; 576 end if; 577 while E_Cur /= String_Set.No_Element loop 578 if not Excluded_Test_Data_Files.Contains 579 (Get_Source_Stub_Data_Spec (String_Set.Element (E_Cur))) 580 then 581 S_Put 582 (6, 583 """" 584 & Base_Name 585 (Get_Source_Stub_Data_Spec (String_Set.Element (E_Cur))) 586 & ""","); 587 Put_New_Line; 588 end if; 589 if not Excluded_Test_Data_Files.Contains 590 (Get_Source_Stub_Data_Body (String_Set.Element (E_Cur))) 591 then 592 S_Put 593 (6, 594 """" 595 & Base_Name 596 (Get_Source_Stub_Data_Body (String_Set.Element (E_Cur))) 597 & ""","); 598 Put_New_Line; 599 end if; 600 S_Put 601 (6, 602 """" 603 & Base_Name (Get_Source_Body (String_Set.Element (E_Cur))) 604 & """"); 605 Next (E_Cur); 606 if E_Cur = String_Set.No_Element then 607 S_Put (0, ");"); 608 else 609 S_Put (0, ","); 610 end if; 611 Put_New_Line; 612 end loop; 613 614 S_Put 615 (3, 616 "for Object_Dir use """ 617 & Unit_To_File_Name 618 (Stub_Project_Prefix & Current_Source_Infix & Proj) 619 & """;"); 620 Put_New_Line; 621 S_Put 622 (0, 623 "end " 624 & Stub_Project_Prefix 625 & Current_Source_Infix 626 & Proj 627 & ";"); 628 629 Close_File; 630 end if; 631 632 <<Process_Imported>> 633 634 Cur := Arg_Proj.Imported_List.First; 635 while Cur /= List_Of_Strings.No_Element loop 636 Process_Project (List_Of_Strings.Element (Cur)); 637 Next (Cur); 638 end loop; 639 end Process_Project; 640 641 procedure Set_Present_Subset_For_Project (Proj : String) is 642 Cur : Source_File_Table.Cursor := SF_Table.First; 643 begin 644 Current_Proj_Present_Sources.Clear; 645 646 while Cur /= Source_File_Table.No_Element loop 647 declare 648 Key : constant String := Source_File_Table.Key (Cur); 649 begin 650 if Source_File_Table.Element (Cur).Project_Name.all = Proj 651 and then not Is_Body (Key) 652 and then Source_Stubbed (Key) 653 and then not Excluded_Sources.Contains (Base_Name (Key)) 654 then 655 Current_Proj_Present_Sources.Include 656 (Source_File_Table.Key (Cur)); 657 end if; 658 end; 659 Next (Cur); 660 end loop; 661 end Set_Present_Subset_For_Project; 662 begin 663 Union (Excluded_Sources, Default_Stub_Exclusion_List); 664 if Stub_Exclusion_Lists.Contains (Short_Name) then 665 Union (Excluded_Sources, Stub_Exclusion_Lists.Element (Short_Name)); 666 end if; 667 668 if Excluded_Sources.Is_Empty then 669 Trace 670 (Me, 671 "No special extending project subtree needed for" & Short_Name); 672 return; 673 end if; 674 675 Trace 676 (Me, "Creating extending project subtree for source " & Short_Name); 677 678 if Verbose then 679 Trace (Me, "Current infix is " & Current_Source_Infix); 680 Trace (Me, "Root of subtree is " & Subroot_Prj_Name); 681 Trace (Me, "excluded sources are:"); 682 Increase_Indent (Me); 683 SS_Cur := Excluded_Sources.First; 684 while SS_Cur /= String_Set.No_Element loop 685 Trace (Me, String_Set.Element (SS_Cur)); 686 Next (SS_Cur); 687 end loop; 688 Decrease_Indent (Me); 689 end if; 690 691 Process_Project (Subroot_Prj_Name); 692 693 end Enforce_Custom_Project_Extention; 694 695 ------------------------------- 696 -- Enforce_Project_Extention -- 697 ------------------------------- 698 699 procedure Enforce_Project_Extention 700 (Prj_Name : String; 701 Subroot_Stub_Prj : String; 702 Current_Project_Infix : String) 703 is 704 705 Processed_Projects : String_Set.Set := String_Set.Empty_Set; 706 707 Current_Proj_Present_Sources : String_Set.Set := String_Set.Empty_Set; 708 709 procedure Process_Project (Proj : String); 710 procedure Set_Present_Subset_For_Project (Proj : String); 711 712 procedure Set_Present_Subset_For_Project (Proj : String) is 713 Cur : Source_File_Table.Cursor := SF_Table.First; 714 begin 715 Current_Proj_Present_Sources.Clear; 716 717 while Cur /= Source_File_Table.No_Element loop 718 declare 719 Key : constant String := Source_File_Table.Key (Cur); 720 begin 721 if Source_File_Table.Element (Cur).Project_Name.all = Proj 722 and then not Is_Body (Key) 723 and then Source_Stubbed (Key) 724 and then not 725 Default_Stub_Exclusion_List.Contains (Base_Name (Key)) 726 then 727 Current_Proj_Present_Sources.Include 728 (Source_File_Table.Key (Cur)); 729 end if; 730 end; 731 Next (Cur); 732 end loop; 733 end Set_Present_Subset_For_Project; 734 735 procedure Process_Project (Proj : String) is 736 Relative_P_Path, Relative_I_Path : String_Access; 737 Arg_Proj : Project_Record; 738 Cur, I_Cur : List_Of_Strings.Cursor; 739 E_Cur : String_Set.Cursor; 740 begin 741 if Processed_Projects.Contains (Proj) then 742 return; 743 end if; 744 Processed_Projects.Include (Proj); 745 746 Arg_Proj := PF_Table.Element (Proj); 747 748 if Proj = Prj_Name then 749 -- The root of the subtree is extended by the test driver project. 750 goto Process_Imported; 751 end if; 752 753 -- generating stuff 754 if Arg_Proj.Needed_For_Extention then 755 756 Relative_P_Path := new String' 757 (+Relative_Path 758 (Create (+Arg_Proj.Path.all), 759 Create (+Arg_Proj.Stub_Dir.all))); 760 761 declare 762 F : File_Array_Access; 763 begin 764 Append 765 (F, 766 GNATCOLL.VFS.Create 767 (+(Arg_Proj.Stub_Dir.all))); 768 Append 769 (F, 770 GNATCOLL.VFS.Create 771 (+(Arg_Proj.Stub_Dir.all 772 & Directory_Separator 773 & Unit_To_File_Name 774 (Stub_Project_Prefix & Current_Project_Infix & Proj)))); 775 Create_Dirs (F); 776 end; 777 778 Trace 779 (Me, 780 "Creating " 781 & Arg_Proj.Stub_Dir.all 782 & Directory_Separator 783 & Unit_To_File_Name 784 (Stub_Project_Prefix & Current_Project_Infix & Proj) 785 & ".gpr"); 786 Create 787 (Arg_Proj.Stub_Dir.all 788 & Directory_Separator 789 & Unit_To_File_Name 790 (Stub_Project_Prefix & Current_Project_Infix & Proj) 791 & ".gpr"); 792 793 I_Cur := Arg_Proj.Imported_List.First; 794 while I_Cur /= List_Of_Strings.No_Element loop 795 if 796 PF_Table.Element 797 (List_Of_Strings.Element (I_Cur)).Needed_For_Extention 798 then 799 declare 800 Imported_Sub_Project : constant String := 801 PF_Table.Element 802 (List_Of_Strings.Element (I_Cur)).Stub_Dir.all 803 & Directory_Separator 804 & To_Lower (Stub_Project_Prefix 805 & Current_Project_Infix 806 & List_Of_Strings.Element (I_Cur)) 807 & ".gpr"; 808 begin 809 if List_Of_Strings.Element (I_Cur) = Prj_Name then 810 Relative_I_Path := new String' 811 (+Relative_Path (Create (+Subroot_Stub_Prj), 812 Create (+Arg_Proj.Stub_Dir.all))); 813 else 814 Relative_I_Path := new String' 815 (+Relative_Path (Create (+Imported_Sub_Project), 816 Create (+Arg_Proj.Stub_Dir.all))); 817 end if; 818 end; 819 if Arg_Proj.Limited_Withed.Contains 820 (List_Of_Strings.Element (I_Cur)) 821 then 822 S_Put 823 (0, 824 "limited with """ 825 & Relative_I_Path.all 826 & """;"); 827 else 828 S_Put 829 (0, 830 "with """ 831 & Relative_I_Path.all 832 & """;"); 833 end if; 834 Put_New_Line; 835 end if; 836 Next (I_Cur); 837 end loop; 838 839 S_Put 840 (0, 841 "project " 842 & Stub_Project_Prefix 843 & Current_Project_Infix 844 & Proj 845 & " extends """ 846 & Relative_P_Path.all 847 & """ is"); 848 Put_New_Line; 849 S_Put (3, "for Source_Dirs use (""."");"); 850 Put_New_Line; 851 852 Set_Present_Subset_For_Project (Proj); 853 E_Cur := Current_Proj_Present_Sources.First; 854 if E_Cur /= String_Set.No_Element then 855 S_Put (3, "for Source_Files use ("); 856 Put_New_Line; 857 else 858 S_Put (3, "for Source_Files use ();"); 859 Put_New_Line; 860 end if; 861 while E_Cur /= String_Set.No_Element loop 862 if not Excluded_Test_Data_Files.Contains 863 (Get_Source_Stub_Data_Spec (String_Set.Element (E_Cur))) 864 then 865 S_Put 866 (6, 867 """" 868 & Base_Name 869 (Get_Source_Stub_Data_Spec (String_Set.Element (E_Cur))) 870 & ""","); 871 Put_New_Line; 872 end if; 873 if not Excluded_Test_Data_Files.Contains 874 (Get_Source_Stub_Data_Body (String_Set.Element (E_Cur))) 875 then 876 S_Put 877 (6, 878 """" 879 & Base_Name 880 (Get_Source_Stub_Data_Body (String_Set.Element (E_Cur))) 881 & ""","); 882 Put_New_Line; 883 end if; 884 S_Put 885 (6, 886 """" 887 & Base_Name (Get_Source_Body (String_Set.Element (E_Cur))) 888 & """"); 889 Next (E_Cur); 890 if E_Cur = String_Set.No_Element then 891 S_Put (0, ");"); 892 else 893 S_Put (0, ","); 894 end if; 895 Put_New_Line; 896 end loop; 897 898 S_Put 899 (3, 900 "for Object_Dir use """ 901 & Unit_To_File_Name 902 (Stub_Project_Prefix & Current_Project_Infix & Proj) 903 & """;"); 904 Put_New_Line; 905 S_Put 906 (0, 907 "end " 908 & Stub_Project_Prefix 909 & Current_Project_Infix 910 & Proj 911 & ";"); 912 913 Close_File; 914 end if; 915 916 <<Process_Imported>> 917 918 Cur := Arg_Proj.Imported_List.First; 919 while Cur /= List_Of_Strings.No_Element loop 920 Process_Project (List_Of_Strings.Element (Cur)); 921 Next (Cur); 922 end loop; 923 end Process_Project; 924 925 begin 926 927 Process_Project (Prj_Name); 928 929 end Enforce_Project_Extention; 930 931 --------------------------- 932 -- Get_Imported_Projects -- 933 --------------------------- 934 935 function Get_Imported_Projects (Project_Name : String) 936 return List_Of_Strings.List 937 is 938 begin 939 return Project_File_Table.Element 940 (PF_Table, Project_Name).Imported_List; 941 end Get_Imported_Projects; 942 943 ---------------------------- 944 -- Get_Importing_Projects -- 945 ---------------------------- 946 947 function Get_Importing_Projects (Project_Name : String) 948 return List_Of_Strings.List 949 is 950 begin 951 return Project_File_Table.Element 952 (PF_Table, Project_Name).Importing_List; 953 end Get_Importing_Projects; 954 955 ---------------------- 956 -- Get_Project_Path -- 957 ---------------------- 958 959 function Get_Project_Path (Project_Name : String) return String is 960 begin 961 return Project_File_Table.Element 962 (PF_Table, Project_Name).Path.all; 963 end Get_Project_Path; 964 965 -------------------------- 966 -- Get_Project_Stub_Dir -- 967 -------------------------- 968 969 function Get_Project_Stub_Dir (Project_Name : String) return String is 970 begin 971 return Project_File_Table.Element 972 (PF_Table, Project_Name).Stub_Dir.all; 973 end Get_Project_Stub_Dir; 974 975 --------------------- 976 -- Get_Source_Body -- 977 --------------------- 978 979 function Get_Source_Body (Source_Name : String) return String 980 is 981 SN : constant String := 982 Normalize_Pathname 983 (Name => Source_Name, 984 Resolve_Links => False, 985 Case_Sensitive => False); 986 SFR : SF_Record; 987 begin 988 if Source_Present (SN) then 989 SFR := Source_File_Table.Element (SF_Table, SN); 990 else 991 Report_Std 992 ("warning: " 993 & Source_Name 994 & " is not a source of argument project"); 995 Report_Std 996 (" cannot create stub"); 997 998 return ""; 999 end if; 1000 1001 if SFR.Corresponding_Body = null then 1002 return ""; 1003 else 1004 return SFR.Corresponding_Body.all; 1005 end if; 1006 end Get_Source_Body; 1007 1008 ----------------------------- 1009 -- Get_Source_Output_Dir -- 1010 ----------------------------- 1011 function Get_Source_Output_Dir (Source_Name : String) return String 1012 is 1013 SN : constant String := 1014 Normalize_Pathname 1015 (Name => Source_Name, 1016 Resolve_Links => False, 1017 Case_Sensitive => False); 1018 begin 1019 return Source_File_Table.Element 1020 (SF_Table, SN).Test_Destination.all; 1021 end Get_Source_Output_Dir; 1022 1023 ------------------------ 1024 -- Get_Source_Project -- 1025 ------------------------ 1026 1027 function Get_Source_Project_Name (Source_Name : String) return String 1028 is 1029 SN : constant String := 1030 Normalize_Pathname 1031 (Name => Source_Name, 1032 Resolve_Links => False, 1033 Case_Sensitive => False); 1034 begin 1035 return Source_File_Table.Element 1036 (SF_Table, SN).Project_Name.all; 1037 end Get_Source_Project_Name; 1038 1039 ------------------------- 1040 -- Get_Source_Stub_Dir -- 1041 ------------------------- 1042 1043 function Get_Source_Stub_Dir (Source_Name : String) return String 1044 is 1045 SN : constant String := 1046 Normalize_Pathname 1047 (Name => Source_Name, 1048 Resolve_Links => False, 1049 Case_Sensitive => False); 1050 begin 1051 return Source_File_Table.Element 1052 (SF_Table, SN).Stub_Destination.all; 1053 end Get_Source_Stub_Dir; 1054 1055 ------------------------------- 1056 -- Get_Source_Stub_Data_Body -- 1057 ------------------------------- 1058 1059 function Get_Source_Stub_Data_Body (Source_Name : String) return String 1060 is 1061 SN : constant String := 1062 Normalize_Pathname 1063 (Name => Source_Name, 1064 Resolve_Links => False, 1065 Case_Sensitive => False); 1066 begin 1067 return Source_File_Table.Element 1068 (SF_Table, SN).Stub_Data_Base_Body.all; 1069 end Get_Source_Stub_Data_Body; 1070 1071 ------------------------------- 1072 -- Get_Source_Stub_Data_Spec -- 1073 ------------------------------- 1074 1075 function Get_Source_Stub_Data_Spec (Source_Name : String) return String 1076 is 1077 SN : constant String := 1078 Normalize_Pathname 1079 (Name => Source_Name, 1080 Resolve_Links => False, 1081 Case_Sensitive => False); 1082 begin 1083 return Source_File_Table.Element 1084 (SF_Table, SN).Stub_Data_Base_Spec.all; 1085 end Get_Source_Stub_Data_Spec; 1086 1087 ------------------------- 1088 -- Get_Source_Status -- 1089 ------------------------- 1090 function Get_Source_Status (Source_Name : String) return SF_Status 1091 is 1092 SN : constant String := 1093 Normalize_Pathname 1094 (Name => Source_Name, 1095 Resolve_Links => False, 1096 Case_Sensitive => False); 1097 begin 1098 return Source_File_Table.Element 1099 (SF_Table, SN).Status; 1100 end Get_Source_Status; 1101 1102 ---------------------------------- 1103 -- Get_Source_Suffixless_Name -- 1104 ---------------------------------- 1105 function Get_Source_Suffixless_Name (Source_Name : String) return String 1106 is 1107 SN : constant String := 1108 Normalize_Pathname 1109 (Name => Source_Name, 1110 Resolve_Links => False, 1111 Case_Sensitive => False); 1112 begin 1113 return Source_File_Table.Element 1114 (SF_Table, SN).Suffixless_Name.all; 1115 end Get_Source_Suffixless_Name; 1116 1117 ------------------------------ 1118 -- Initialize_Project_Table -- 1119 ------------------------------ 1120 1121 procedure Initialize_Project_Table is 1122 Iter, Importing, Imported : Project_Iterator; 1123 P, P2 : Project_Type; 1124 1125 Attr : constant Attribute_Pkg_String := Build ("", "externally_built"); 1126 begin 1127 Trace (Me, "Initialize_Project_Table"); 1128 Increase_Indent (Me); 1129 Iter := Start (Source_Project_Tree.Root_Project); 1130 while Current (Iter) /= No_Project loop 1131 P := Current (Iter); 1132 Trace (Me, "processing " & P.Name); 1133 1134 if Extending_Project (P) /= No_Project then 1135 -- We do not want extended projects in the table. 1136 goto Next_Project; 1137 end if; 1138 1139 declare 1140 PR : Project_Record; 1141 begin 1142 if Has_Attribute (P, Attr) then 1143 if To_Lower (Attribute_Value (P, Attr)) = "true" then 1144 PR.Is_Externally_Built := True; 1145 -- Nothing should be done for sources of externally built 1146 -- projects, so no point in calculating obj dirs and so on. 1147 goto Add_Project; 1148 end if; 1149 end if; 1150 PR.Is_Externally_Built := False; 1151 1152 if P = Source_Project_Tree.Root_Project then 1153 PR.Needed_For_Extention := True; 1154 end if; 1155 1156 PR.Path := new String'(P.Project_Path.Display_Full_Name); 1157 PR.Obj_Dir := new String'(P.Object_Dir.Display_Full_Name); 1158 if Is_Absolute_Path (Stub_Dir_Name.all) then 1159 PR.Stub_Dir := new String' 1160 (Stub_Dir_Name.all 1161 & Directory_Separator 1162 & P.Name); 1163 else 1164 PR.Stub_Dir := new String' 1165 (P.Object_Dir.Display_Full_Name 1166 & Stub_Dir_Name.all 1167 & Directory_Separator 1168 & P.Name); 1169 end if; 1170 1171 Increase_Indent (Me, "imported projects:"); 1172 P2 := P; 1173 1174 while P2 /= No_Project loop 1175 Imported := 1176 P2.Start (Direct_Only => True, Include_Extended => False); 1177 1178 while Current (Imported) /= No_Project loop 1179 PR.Imported_List.Append (Current (Imported).Name); 1180 if Is_Limited_With (Imported) then 1181 PR.Limited_Withed.Include (Current (Imported).Name); 1182 end if; 1183 Trace (Me, Current (Imported).Name); 1184 Next (Imported); 1185 end loop; 1186 1187 P2 := Extended_Project (P2); 1188 end loop; 1189 Decrease_Indent (Me); 1190 1191 Importing := P.Find_All_Projects_Importing (Direct_Only => True); 1192 Increase_Indent (Me, "importing projects:"); 1193 while Current (Importing) /= No_Project loop 1194 PR.Importing_List.Append (Current (Importing).Name); 1195 Trace (Me, Current (Importing).Name); 1196 Next (Importing); 1197 end loop; 1198 Decrease_Indent (Me); 1199 1200 <<Add_Project>> 1201 1202 PF_Table.Include (P.Name, PR); 1203 end; 1204 1205 <<Next_Project>> 1206 1207 Next (Iter); 1208 end loop; 1209 Decrease_Indent (Me); 1210 end Initialize_Project_Table; 1211 1212 ------------- 1213 -- Is_Body -- 1214 ------------- 1215 1216 function Is_Body (Source_Name : String) return Boolean 1217 is 1218 SN : constant String := 1219 Normalize_Pathname 1220 (Name => Source_Name, 1221 Resolve_Links => False, 1222 Case_Sensitive => False); 1223 begin 1224 return Source_File_Table.Element 1225 (SF_Table, SN).Corresponding_Body = null; 1226 end Is_Body; 1227 1228 ---------------------------------------- 1229 -- Mark_Projects_With_Stubbed_Sources -- 1230 ---------------------------------------- 1231 1232 procedure Mark_Projects_With_Stubbed_Sources is 1233 S_Cur : Source_File_Table.Cursor := SF_Table.First; 1234 PR : Project_Record; 1235 1236 Processed_Projects : String_Set.Set; 1237 1238 P_Cur : Project_File_Table.Cursor; 1239 1240 procedure Process_Project (S : String); 1241 1242 procedure Process_Project (S : String) is 1243 Cur : List_Of_Strings.Cursor; 1244 Local_PR : Project_Record; 1245 begin 1246 Trace (Me, "Process_Project " & S); 1247 if Processed_Projects.Contains (S) then 1248 return; 1249 end if; 1250 1251 Processed_Projects.Include (S); 1252 1253 if PF_Table.Element (S).Is_Externally_Built then 1254 -- Nothing to do for those. 1255 return; 1256 end if; 1257 1258 Local_PR := PF_Table.Element (S); 1259 Local_PR.Needed_For_Extention := True; 1260 PF_Table.Replace (S, Local_PR); 1261 1262 Cur := Local_PR.Importing_List.First; 1263 while Cur /= List_Of_Strings.No_Element loop 1264 Process_Project (List_Of_Strings.Element (Cur)); 1265 Next (Cur); 1266 end loop; 1267 1268 end Process_Project; 1269 begin 1270 Trace (Me, "Mark_Projects_With_Stubbed_Sources"); 1271 Increase_Indent (Me); 1272 1273 -- First, mark all projects that have sources that have been stubbed. 1274 while S_Cur /= Source_File_Table.No_Element loop 1275 if Source_File_Table.Element (S_Cur).Stub_Created then 1276 PR := 1277 PF_Table.Element 1278 (Source_File_Table.Element (S_Cur).Project_Name.all); 1279 PR.Needed_For_Extention := True; 1280 1281 Trace 1282 (Me, 1283 Source_File_Table.Element (S_Cur).Project_Name.all 1284 & " has stubbed sources"); 1285 1286 PF_Table.Replace 1287 (Source_File_Table.Element (S_Cur).Project_Name.all, 1288 PR); 1289 end if; 1290 1291 Next (S_Cur); 1292 end loop; 1293 1294 -- Now we need to also mark all projects that are imported by any 1295 -- of already marked ones. 1296 1297 P_Cur := PF_Table.First; 1298 while P_Cur /= Project_File_Table.No_Element loop 1299 if 1300 not Processed_Projects.Contains (Project_File_Table.Key (P_Cur)) 1301 and then Project_File_Table.Element (P_Cur).Needed_For_Extention 1302 then 1303 Process_Project (Project_File_Table.Key (P_Cur)); 1304 end if; 1305 1306 Next (P_Cur); 1307 end loop; 1308 1309 Decrease_Indent (Me); 1310 end Mark_Projects_With_Stubbed_Sources; 1311 1312 ------------------------- 1313 -- Mark_Sourse_Stubbed -- 1314 ------------------------- 1315 1316 procedure Mark_Sourse_Stubbed (Source_Name : String) is 1317 SF_Rec : SF_Record; 1318 SN : constant String := 1319 Normalize_Pathname 1320 (Name => Source_Name, 1321 Resolve_Links => False, 1322 Case_Sensitive => False); 1323 begin 1324 SF_Rec := Source_File_Table.Element (SF_Table, SN); 1325 SF_Rec.Stub_Created := True; 1326 Replace (SF_Table, SN, SF_Rec); 1327 end Mark_Sourse_Stubbed; 1328 1329 --------------------------------- 1330 -- Next_Non_Processed_Source -- 1331 --------------------------------- 1332 function Next_Non_Processed_Source return String is 1333 Cur : Source_File_Table.Cursor := Source_File_Table.No_Element; 1334 begin 1335 Reset_Source_Process_Iterator; 1336 1337 loop 1338 if Cur = Source_File_Table.No_Element and then 1339 Source_File_Table.Element (SF_Process_Iterator).Status = Pending 1340 then 1341 Cur := SF_Process_Iterator; 1342 end if; 1343 if 1344 Source_File_Table.Element (SF_Process_Iterator).Status = Waiting 1345 then 1346 Free (Current_Source); 1347 Current_Source := new String'(Key (SF_Process_Iterator)); 1348 return Key (SF_Process_Iterator); 1349 end if; 1350 1351 Next (SF_Process_Iterator); 1352 exit when SF_Process_Iterator = Source_File_Table.No_Element; 1353 end loop; 1354 1355 if Cur /= Source_File_Table.No_Element then 1356 Free (Current_Source); 1357 Current_Source := new String'(Key (Cur)); 1358 return Key (Cur); 1359 end if; 1360 1361 Free (Current_Source); 1362 return ""; 1363 end Next_Non_Processed_Source; 1364 1365 ----------------------------- 1366 -- Get_Current_Source_Spec -- 1367 ----------------------------- 1368 1369 function Get_Current_Source_Spec return String is 1370 begin 1371 if Current_Source = null then 1372 return ""; 1373 else 1374 return Current_Source.all; 1375 end if; 1376 end Get_Current_Source_Spec; 1377 1378 ---------------------------- 1379 -- Next_Source_Location -- 1380 ---------------------------- 1381 function Next_Source_Location return String is 1382 Cur : Source_File_Locations.Cursor; 1383 begin 1384 if SFL_Iterator /= Source_File_Locations.No_Element then 1385 Cur := SFL_Iterator; 1386 Source_File_Locations.Next (SFL_Iterator); 1387 return Source_File_Locations.Element (Cur); 1388 else 1389 return ""; 1390 end if; 1391 end Next_Source_Location; 1392 1393 ------------------------ 1394 -- Next_Source_Name -- 1395 ------------------------ 1396 function Next_Source_Name return String is 1397 Cur : Source_File_Table.Cursor; 1398 begin 1399 if SF_Access_Iterator /= Source_File_Table.No_Element then 1400 Cur := SF_Access_Iterator; 1401 Source_File_Table.Next (SF_Access_Iterator); 1402 return Key (Cur); 1403 else 1404 return ""; 1405 end if; 1406 end Next_Source_Name; 1407 1408 ---------------------- 1409 -- Project_Extended -- 1410 ---------------------- 1411 1412 function Project_Extended (Project_Name : String) return Boolean is 1413 begin 1414 return Project_File_Table.Element 1415 (PF_Table, Project_Name).Needed_For_Extention; 1416 end Project_Extended; 1417 1418 ------------------- 1419 -- Report_Source -- 1420 ------------------- 1421 procedure Report_Source (S : String) is 1422 Im : constant String := Natural'Image (Sources_Left - 1); 1423 SN : constant String := 1424 Normalize_Pathname 1425 (Name => S, 1426 Resolve_Links => False, 1427 Case_Sensitive => False); 1428 begin 1429 Trace (Me, "reporting source: " & S); 1430 1431 if not Source_Present (SN) then 1432 return; 1433 end if; 1434 1435 if Progress_Indicator_Mode then 1436 declare 1437 Current : constant Integer := Total_Sources - Sources_Left + 1; 1438 Percent : String := 1439 Integer'Image ((Current * 100) / Total_Sources); 1440 begin 1441 Percent (1) := '('; 1442 Info 1443 ("completed" & Integer'Image (Current) & " out of" 1444 & Integer'Image (Total_Sources) & " " 1445 & Percent & "%)..."); 1446 end; 1447 end if; 1448 1449 begin 1450 Sources_Left := Sources_Left - 1; 1451 exception 1452 when Constraint_Error => 1453 Report_Err ("gnattest: inconsistent state of sources detected"); 1454 raise Fatal_Error; 1455 end; 1456 1457 if Verbose then 1458 Report_Std 1459 ("[" & Im (2 .. Im'Last) & "] " & Base_Name (SN)); 1460 end if; 1461 end Report_Source; 1462 1463 ------------------------------- 1464 -- Reset_Location_Iterator -- 1465 ------------------------------- 1466 procedure Reset_Location_Iterator is 1467 begin 1468 SFL_Iterator := First (SFL_Table); 1469 end Reset_Location_Iterator; 1470 1471 ----------------------------- 1472 -- Reset_Source_Iterator -- 1473 ----------------------------- 1474 procedure Reset_Source_Iterator is 1475 begin 1476 SF_Access_Iterator := First (SF_Table); 1477 end Reset_Source_Iterator; 1478 1479 ------------------------------------- 1480 -- Reset_Source_Process_Iterator -- 1481 ------------------------------------- 1482 procedure Reset_Source_Process_Iterator is 1483 begin 1484 SF_Process_Iterator := First (SF_Table); 1485 end Reset_Source_Process_Iterator; 1486 1487 ------------------ 1488 -- Set_Status -- 1489 ------------------ 1490 1491 procedure Set_Source_Status (Source_Name : String; 1492 New_Status : SF_Status) is 1493 SF_Rec : SF_Record; 1494 SN : constant String := 1495 Normalize_Pathname 1496 (Name => Source_Name, 1497 Resolve_Links => False, 1498 Case_Sensitive => False); 1499 begin 1500 SF_Rec := Source_File_Table.Element (SF_Table, SN); 1501 SF_Rec.Status := New_Status; 1502 Replace (SF_Table, SN, SF_Rec); 1503 end Set_Source_Status; 1504 1505 ------------------------- 1506 -- Set_Subdir_Output -- 1507 ------------------------- 1508 1509 procedure Set_Subdir_Output is 1510 SF_Rec : SF_Record; 1511 Tmp_Str : String_Access; 1512 SF_Rec_Key : String_Access; 1513 Cur : Source_File_Table.Cursor := SF_Table.First; 1514 begin 1515 1516 loop 1517 exit when Cur = Source_File_Table.No_Element; 1518 1519 SF_Rec := Source_File_Table.Element (Cur); 1520 SF_Rec_Key := new String'(Key (Cur)); 1521 1522 Tmp_Str := new String'(Dir_Name (SF_Rec.Full_Source_Name.all)); 1523 1524 SF_Rec.Test_Destination := 1525 new String'(Tmp_Str.all & 1526 Test_Subdir_Name.all & 1527 Directory_Separator); 1528 1529 Replace (SF_Table, SF_Rec_Key.all, SF_Rec); 1530 1531 Source_File_Table.Next (Cur); 1532 Free (SF_Rec_Key); 1533 Free (Tmp_Str); 1534 end loop; 1535 1536 end Set_Subdir_Output; 1537 1538 ------------------------- 1539 -- Set_Separate_Root -- 1540 ------------------------- 1541 procedure Set_Separate_Root (Max_Common_Root : String) is 1542 SF_Rec : SF_Record; 1543 Tmp_Str : String_Access; 1544 SF_Rec_Key : String_Access; 1545 Cur : Source_File_Table.Cursor := SF_Table.First; 1546 1547 Idx : Integer; 1548 begin 1549 1550 loop 1551 exit when Cur = Source_File_Table.No_Element; 1552 1553 SF_Rec := Source_File_Table.Element (Cur); 1554 SF_Rec_Key := new String'(Key (Cur)); 1555 Tmp_Str := new String'(Dir_Name (SF_Rec.Full_Source_Name.all)); 1556 1557 Idx := Max_Common_Root'Last + 1; 1558 1559 SF_Rec.Test_Destination := 1560 new String'(Separate_Root_Dir.all & 1561 Directory_Separator & 1562 Tmp_Str.all (Idx .. Tmp_Str.all'Last)); 1563 1564 Replace (SF_Table, SF_Rec_Key.all, SF_Rec); 1565 1566 Source_File_Table.Next (Cur); 1567 Free (SF_Rec_Key); 1568 Free (Tmp_Str); 1569 end loop; 1570 1571 end Set_Separate_Root; 1572 1573 ----------------------- 1574 -- Set_Direct_Output -- 1575 ----------------------- 1576 1577 procedure Set_Direct_Output is 1578 SF_Rec : SF_Record; 1579 Tmp_Str : String_Access; 1580 SF_Rec_Key : String_Access; 1581 Cur : Source_File_Table.Cursor := SF_Table.First; 1582 1583 Project : Project_Type; 1584 1585 TD_Name : constant Virtual_File := 1586 GNATCOLL.VFS.Create (+Test_Dir_Name.all); 1587 begin 1588 1589 loop 1590 exit when Cur = Source_File_Table.No_Element; 1591 1592 SF_Rec := Source_File_Table.Element (Cur); 1593 SF_Rec_Key := new String'(Key (Cur)); 1594 1595 if TD_Name.Is_Absolute_Path then 1596 SF_Rec.Test_Destination := new String'(Test_Dir_Name.all); 1597 else 1598 Project := GNATCOLL.Projects.Project (Info 1599 (Source_Project_Tree, 1600 GNATCOLL.VFS.Create (+SF_Rec.Full_Source_Name.all))); 1601 SF_Rec.Test_Destination := new String' 1602 (Project.Object_Dir.Display_Full_Name & Test_Dir_Name.all); 1603 end if; 1604 1605 Replace (SF_Table, SF_Rec_Key.all, SF_Rec); 1606 1607 Source_File_Table.Next (Cur); 1608 Free (SF_Rec_Key); 1609 Free (Tmp_Str); 1610 end loop; 1611 end Set_Direct_Output; 1612 1613 ---------------------------- 1614 -- Set_Direct_Stub_Output -- 1615 ---------------------------- 1616 1617 procedure Set_Direct_Stub_Output is 1618 SF_Rec : SF_Record; 1619 Tmp_Str : String_Access; 1620 SF_Rec_Key : String_Access; 1621 Cur : Source_File_Table.Cursor := SF_Table.First; 1622 1623 Project : Project_Type; 1624 1625 TD_Name : constant Virtual_File := 1626 GNATCOLL.VFS.Create (+Stub_Dir_Name.all); 1627 begin 1628 1629 loop 1630 exit when Cur = Source_File_Table.No_Element; 1631 1632 SF_Rec := Source_File_Table.Element (Cur); 1633 SF_Rec_Key := new String'(Key (Cur)); 1634 1635 Project := GNATCOLL.Projects.Project 1636 (Info (Source_Project_Tree, 1637 GNATCOLL.VFS.Create (+SF_Rec.Full_Source_Name.all))); 1638 1639 loop 1640 exit when Extending_Project (Project) = No_Project; 1641 Project := Extending_Project (Project); 1642 end loop; 1643 1644 -- Better use subdirs to separate stubs from different projects. 1645 if TD_Name.Is_Absolute_Path then 1646 SF_Rec.Stub_Destination := new String' 1647 (Stub_Dir_Name.all 1648 & Directory_Separator 1649 & Project.Name); 1650 else 1651 SF_Rec.Stub_Destination := new String' 1652 (Project.Object_Dir.Display_Full_Name 1653 & Stub_Dir_Name.all 1654 & Directory_Separator 1655 & Project.Name); 1656 end if; 1657 1658 Replace (SF_Table, SF_Rec_Key.all, SF_Rec); 1659 1660 Source_File_Table.Next (Cur); 1661 Free (SF_Rec_Key); 1662 Free (Tmp_Str); 1663 end loop; 1664 end Set_Direct_Stub_Output; 1665 1666 -------------------- 1667 -- Set_Output_Dir -- 1668 -------------------- 1669 1670 procedure Set_Output_Dir (Source_Name : String; Output_Dir : String) is 1671 SF_Rec : SF_Record; 1672 SN : constant String := 1673 Normalize_Pathname 1674 (Name => Source_Name, 1675 Resolve_Links => False, 1676 Case_Sensitive => False); 1677 begin 1678 SF_Rec := SF_Table.Element (SN); 1679 SF_Rec.Test_Destination := new String'(Output_Dir); 1680 Replace (SF_Table, SN, SF_Rec); 1681 end Set_Output_Dir; 1682 1683 --------------------------- 1684 -- Set_Parallel_Output -- 1685 --------------------------- 1686 1687 procedure Set_Parallel_Output is 1688 SF_Rec : SF_Record; 1689 Tmp_Str : String_Access; 1690 SF_Rec_Key : String_Access; 1691 Cur : Source_File_Table.Cursor := SF_Table.First; 1692 1693 Idx_F : Integer; 1694 begin 1695 1696 loop 1697 exit when Cur = Source_File_Table.No_Element; 1698 1699 SF_Rec := Source_File_Table.Element (Cur); 1700 SF_Rec_Key := new String'(Key (Cur)); 1701 1702 Tmp_Str := new String'(Dir_Name (SF_Rec.Full_Source_Name.all)); 1703 1704 Idx_F := Tmp_Str.all'First; 1705 for Idx_L in reverse Idx_F .. Tmp_Str.all'Last - 1 loop 1706 if Tmp_Str.all (Idx_L) = Directory_Separator then 1707 SF_Rec.Test_Destination := 1708 new String'(Tmp_Str.all (Idx_F .. Idx_L) & 1709 Test_Dir_Prefix.all & 1710 Tmp_Str.all (Idx_L + 1 .. Tmp_Str.all'Last - 1) & 1711 Test_Dir_Suffix.all); 1712 exit; 1713 end if; 1714 end loop; 1715 1716 Replace (SF_Table, SF_Rec_Key.all, SF_Rec); 1717 1718 Source_File_Table.Next (Cur); 1719 Free (SF_Rec_Key); 1720 Free (Tmp_Str); 1721 end loop; 1722 1723 end Set_Parallel_Output; 1724 1725 ---------------------- 1726 -- Source_Present -- 1727 ---------------------- 1728 function Source_Present (Source_Name : String) return Boolean is 1729 SN : constant String := 1730 Normalize_Pathname 1731 (Name => Source_Name, 1732 Resolve_Links => False, 1733 Case_Sensitive => False); 1734 begin 1735 return Contains (SF_Table, SN); 1736 end Source_Present; 1737 1738 -------------------- 1739 -- Source_Stubbed -- 1740 -------------------- 1741 1742 function Source_Stubbed (Source_Name : String) return Boolean is 1743 SN : constant String := 1744 Normalize_Pathname 1745 (Name => Source_Name, 1746 Resolve_Links => False, 1747 Case_Sensitive => False); 1748 begin 1749 return Source_File_Table.Element 1750 (SF_Table, SN).Stub_Created; 1751 end Source_Stubbed; 1752 1753end GNATtest.Skeleton.Source_Table; 1754