1------------------------------------------------------------------------------ 2-- -- 3-- GNATTEST COMPONENTS -- 4-- -- 5-- G N A T T E S T . S K E L E T O N . G E N E R A T O R -- 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_2012; 27 28with Ada.Containers.Doubly_Linked_Lists; 29with Ada.Containers.Indefinite_Doubly_Linked_Lists; 30with Ada.Containers.Indefinite_Ordered_Maps; 31with Ada.Containers.Indefinite_Vectors; 32with Ada.Containers.Indefinite_Ordered_Sets; 33with Ada.Containers.Vectors; 34 35with GNAT.OS_Lib; use GNAT.OS_Lib; 36with GNAT.SHA1; 37 38with Ada.Text_IO; use Ada.Text_IO; 39with Ada.Characters.Handling; use Ada.Characters.Handling; 40with Ada.Strings; use Ada.Strings; 41with Ada.Strings.Fixed; use Ada.Strings.Fixed; 42 43with GNAT.Directory_Operations; use GNAT.Directory_Operations; 44 45with GNATCOLL.VFS; use GNATCOLL.VFS; 46with GNATCOLL.Traces; use GNATCOLL.Traces; 47 48with Asis; use Asis; 49with Asis.Ada_Environments; use Asis.Ada_Environments; 50with Asis.Clauses; use Asis.Clauses; 51with Asis.Compilation_Units; use Asis.Compilation_Units; 52with Asis.Declarations; use Asis.Declarations; 53with Asis.Definitions; use Asis.Definitions; 54with Asis.Elements; use Asis.Elements; 55with Asis.Expressions; use Asis.Expressions; 56with Asis.Extensions; use Asis.Extensions; 57with Asis.Errors; 58with Asis.Exceptions; use Asis.Exceptions; 59with Asis.Extensions.Flat_Kinds; use Asis.Extensions.Flat_Kinds; 60with Asis.Implementation; 61with Asis.Iterator; use Asis.Iterator; 62with Asis.Limited_Views; use Asis.Limited_Views; 63with Asis.Text; use Asis.Text; 64 65with ASIS_UL.Common; 66with ASIS_UL.Compiler_Options; use ASIS_UL.Compiler_Options; 67 68with GNATtest.Skeleton.Source_Table; use GNATtest.Skeleton.Source_Table; 69 70with GNATtest.Common; use GNATtest.Common; 71with GNATtest.Options; use GNATtest.Options; 72with GNATtest.Environment; use GNATtest.Environment; 73with GNATtest.Mapping; use GNATtest.Mapping; 74 75with GNATtest.Harness.Generator; 76with GNATtest.Stub.Generator; 77with Ada.Containers; 78 79package body GNATtest.Skeleton.Generator is 80 81 Me : constant Trace_Handle := 82 Create ("Skeletons", Default => Off); 83 Me_Direct_Callees : constant Trace_Handle := 84 Create ("Skeletons.Direct_Callees", Default => Off); 85 86 ------------------- 87 -- Minded Data -- 88 ------------------- 89 90 New_Tests_Counter : Natural := 0; 91 All_Tests_Counter : Natural := 0; 92 93 package Tests_Per_Unit is new 94 Ada.Containers.Indefinite_Ordered_Maps (String, Natural); 95 use Tests_Per_Unit; 96 97 Test_Info : Tests_Per_Unit.Map; 98 99 type Data_Kind_Type is 100 (Declaration_Data, 101 Instantiation); 102 103 type Base_Type_Info is tagged record 104 Main_Type_Elem : Asis.Element := Asis.Nil_Element; 105 Main_Type_Abstract : Boolean; 106 Main_Type_Text_Name : String_Access; 107 108 Has_Argument_Father : Boolean; 109 Argument_Father_Unit_Name : String_Access; 110 Argument_Father_Type_Name : String_Access; 111 Argument_Father_Nesting : String_Access; 112 113 Nesting : String_Access; 114 115 Type_Number : Positive; 116 117 No_Default_Discriminant : Boolean; 118 end record; 119 120 package Type_Info_Vect is new 121 Ada.Containers.Indefinite_Vectors (Positive, Base_Type_Info); 122 use Type_Info_Vect; 123 124 use String_Set; 125 126 type Test_Case_Mode is (Normal, Robustness); 127 128 type Test_Case_Info is record 129 Pre : Asis_Element_List.List; 130 Post : Asis_Element_List.List; 131 132 Elem : Asis.Element; 133 Name : String_Access; 134 Mode : Test_Case_Mode; 135 Req : Asis.Element; 136 Ens : Asis.Element; 137 138 Req_Image : String_Access; 139 Ens_Image : String_Access; 140 141 Params_To_Temp : String_Set.Set; 142 143 Req_Line : String_Access; 144 Ens_Line : String_Access; 145 146 TC_Hash : String_Access; 147 end record; 148 149 type Subp_Info is record 150 Subp_Declaration : Asis.Declaration; 151 Subp_Text_Name : String_Access; 152 Subp_Name_Image : String_Access; 153 Subp_Mangle_Name : String_Access; 154 Subp_Full_Hash : String_Access; 155 156 -- Those versions of hash are stored for compatibility reasons. 157 -- Transitions from older versions of hash should be performed 158 -- automatically. 159 160 Subp_Hash_V1 : String_Access; 161 -- Case-sensitive hash. 162 Subp_Hash_V2_1 : String_Access; 163 -- Non-controlling parameters with same root type as controlling ones 164 -- are replaced with root type before hashing. 165 166 Is_Abstract : Boolean; 167 Corresp_Type : Natural; 168 Nesting : String_Access; 169 170 Has_TC_Info : Boolean := False; 171 TC_Info : Test_Case_Info; 172 173 Is_Overloaded : Boolean; 174 end record; 175 176 package Subp_Data_List is new 177 Ada.Containers.Indefinite_Doubly_Linked_Lists (Subp_Info); 178 use Subp_Data_List; 179 180 type Package_Info is record 181 Name : String_Access; 182 Is_Generic : Boolean; 183 Data_Kind : Data_Kind_Type; 184 Element : Asis.Element; 185 186 -- only used for instantiations 187 Generic_Containing_Package : String_Access; 188 end record; 189 190 package Package_Info_List is new 191 Ada.Containers.Doubly_Linked_Lists (Package_Info); 192 use Package_Info_List; 193 194 -- Info on overloading subprograms 195 package Name_Frequency is new 196 Ada.Containers.Indefinite_Ordered_Maps (String, Natural); 197 use Name_Frequency; 198 199 use Asis_Element_List; 200 201 type Data_Holder (Data_Kind : Data_Kind_Type := Declaration_Data) is record 202 203 Unit : Asis.Compilation_Unit; 204 -- CU itself. 205 206 Unit_Full_Name : String_Access; 207 -- Fully expanded Ada name of the CU. 208 209 Unit_File_Name : String_Access; 210 -- Full name of the file, containing the CU. 211 212 case Data_Kind is 213 -- Indicates which data storing structures are used, determines the 214 -- way of suite generation. 215 216 when Declaration_Data => 217 218 Is_Generic : Boolean; 219 -- Indicates if given argument package declaration is generic. 220 221 Has_Simple_Case : Boolean := False; 222 -- Indicates if we have routines that are not primitives of any 223 -- tagged type. 224 225 Needs_Fixtures : Boolean := False; 226 -- Indicates if we need to unclude AUnit.Fixtures in the test 227 -- package. 228 229 Needs_Set_Up : Boolean := False; 230 -- Indicates if we need the Set_Up routine for at least one test 231 -- type; 232 233 Needs_Assertions : Boolean := False; 234 -- Indicates if we need to include AUnit.Assertions into the body 235 -- of the test package. 236 237 Subp_List : Subp_Data_List.List; 238 -- List of subprograms declared in the argument package 239 -- declaration. 240 241 Type_Data_List : Type_Info_Vect.Vector; 242 -- Stores info on tagged records in the argument package 243 -- declaration. 244 245 Package_Data_List : Package_Info_List.List; 246 -- Stores info of nested packages. 247 248 Units_To_Stub : Asis_Element_List.List; 249 -- List of direct dependancies of current unit. 250 251 Subp_Name_Frequency : Name_Frequency.Map; 252 253 when Instantiation => 254 255 Gen_Unit : Asis.Compilation_Unit; 256 -- Generic CU that is instatinated into the given one. 257 258 Gen_Unit_Full_Name : String_Access; 259 -- Fully expanded Ada name of the generic CU. 260 261 Gen_Unit_File_Name : String_Access; 262 -- Name of file containing the generic CU. 263 264 end case; 265 266 end record; 267 268 ---------------- 269 -- Suite Data -- 270 ---------------- 271 272 type Test_Type_Info_Wrapper is record 273 TT_Info : GNATtest.Harness.Generator.Test_Type_Info; 274 Test_Package : String_Access; 275 Original_Type : Asis.Element := Asis.Nil_Element; 276 end record; 277 278 package TT_Info is new 279 Ada.Containers.Indefinite_Vectors (Positive, Test_Type_Info_Wrapper); 280 use TT_Info; 281 282 type Test_Routine_Info_Wrapper is record 283 TR_Info : GNATtest.Harness.Generator.Test_Routine_Info; 284 Test_Package : String_Access; 285 Original_Type : Asis.Element := Asis.Nil_Element; 286 Original_Subp : Asis.Element := Asis.Nil_Element; 287 end record; 288 289 package TR_Info is new 290 Ada.Containers.Indefinite_Vectors (Positive, Test_Routine_Info_Wrapper); 291 use TR_Info; 292 293 type Test_Routine_Info_Enhanced_Wrapper is record 294 TR_Info : GNATtest.Harness.Generator.Test_Routine_Info_Enhanced; 295 Test_Package : String_Access; 296 Original_Type : Asis.Element := Asis.Nil_Element; 297 end record; 298 299 package TR_Info_Enhanced is new 300 Ada.Containers.Indefinite_Vectors (Positive, 301 Test_Routine_Info_Enhanced_Wrapper); 302 use TR_Info_Enhanced; 303 304 type Suites_Data_Type is record 305 Test_Types : TT_Info.Vector; 306 TR_List : TR_Info.Vector; 307 ITR_List : TR_Info_Enhanced.Vector; 308 LTR_List : TR_Info_Enhanced.Vector; 309 end record; 310 311 ------------------ 312 -- Test Mapping -- 313 ------------------ 314 315 use TC_Mapping_List; 316 use TR_Mapping_List; 317 use DT_Mapping_List; 318 use TP_Mapping_List; 319 use SP_Mapping; 320 321 procedure Add_TR 322 (TP_List : in out TP_Mapping_List.List; 323 TPtarg : String; 324 Test_F : String; 325 Test_T : String; 326 Subp : Subp_Info; 327 TR_Line : Natural := 1); 328 329 procedure Add_DT 330 (TP_List : in out TP_Mapping_List.List; 331 TPtarg : String; 332 Test_F : String; 333 Line : Natural; 334 Column : Natural); 335 336 -------------- 337 -- Geberics -- 338 -------------- 339 package Element_List is new 340 Ada.Containers.Doubly_Linked_Lists (Asis.Element, Is_Equal); 341 342 package Name_Set is new 343 Ada.Containers.Indefinite_Ordered_Maps (String, Positive); 344 345 use Element_List; 346 use List_Of_Strings; 347 use Name_Set; 348 349 type Generic_Tests is record 350 Gen_Unit_Full_Name : String_Access; 351 Tested_Type_Names : List_Of_Strings.List; 352 Has_Simple_Case : Boolean := False; 353 end record; 354 -- Stores names of all tested type names, that produce names of generic 355 -- test pachages, which should be instantiated 356 -- if we have an instantiation of the tested package. 357 358 package Generic_Tests_Storage is new 359 Ada.Containers.Indefinite_Doubly_Linked_Lists (Generic_Tests); 360 use Generic_Tests_Storage; 361 362 Gen_Tests_Storage : Generic_Tests_Storage.List; 363 -- List of data on all the generic tests created during the processing of 364 -- generic tested packages. 365 366 type Generic_Package is record 367 Name : String_Access; 368 Sloc : String_Access := null; 369 370 Has_Instantiation : Boolean := False; 371 end record; 372 373 package Generic_Package_Storage is new 374 Ada.Containers.Indefinite_Doubly_Linked_Lists (Generic_Package); 375 use Generic_Package_Storage; 376 377 Gen_Package_Storage : Generic_Package_Storage.List; 378 -- Used to detect processed generic packages that do not have 379 -- instantiations in the scope of argument sources and, therefore, won't be 380 -- included into final harness. 381 382 Last_Context_Name : String_Access; 383 -- Suffixless name of the last tree file created 384 385 ------------------------- 386 -- Inner Subprograms -- 387 ------------------------- 388 389 function Initialize_Context (Source_Name : String) return Boolean; 390 -- Creates a tree file and initializes the context. 391 392 procedure Create_Tree (Full_Source_Name : String; Success : out Boolean); 393 -- Tries to create the tree file for the given source file. The tree file 394 -- and the corresponding ALI file are placed into a temporary directory. 395 -- If the attempt is successful, Success is set ON, otherwise it is set 396 -- OFF. 397 398 procedure Process_Source (The_Unit : Asis.Compilation_Unit); 399 -- Processes given compilation unit, gathers information that is needed 400 -- for generating the testing unit and suite and generates them if the 401 -- source is appropriate (contains one or less tagged type declaration). 402 403 procedure Process_Stubs (List : Asis_Element_List.List); 404 -- If ther are any units to stub, closes the context, generates .adt files 405 -- for units to stub and passes compilation units to the Stub Generator. 406 407 procedure Gather_Data 408 (The_Unit : Asis.Compilation_Unit; 409 Data : out Data_Holder; 410 Suite_Data_List : out Suites_Data_Type; 411 Apropriate_Source : out Boolean); 412 -- Iterates through the given unit and gathers all the data needed for 413 -- generation of test package. All the iterations are done here. 414 -- Checks if given unit is of the right kind and if it is appropriate. 415 -- Marks unappropriate sources in the source table. 416 417 procedure Gather_Substitution_Data 418 (Suite_Data_List : in out Suites_Data_Type); 419 420 procedure Gather_Direct_Callees 421 (Decl : Asis.Declaration; Set : in out String_Set.Set); 422 423 procedure Source_Clean_Up; 424 -- Minimal clean-up needed for one source (deleting .ali & .adt) 425 426 function No_Inheritance_Through_Generics 427 (Inheritance_Root_Type : Asis.Element; 428 Inheritance_Final_Type : Asis.Element) 429 return Boolean; 430 -- Checks that all types between the root type and the final descendant 431 -- are declared in regular packages. 432 433 function Test_Types_Linked 434 (Inheritance_Root_Type : Asis.Element; 435 Inheritance_Final_Type : Asis.Element) 436 return Boolean; 437 -- Checks that there is no fully private types between the root type and 438 -- the final descendant, so that corresponding test types are members of 439 -- same hierarchy. 440 441 function Is_Declared_In_Regular_Package 442 (Elem : Asis.Element) 443 return Boolean; 444 -- Chechs that all enclosing elements for the given element are regular 445 -- package declarations. 446 447 function Is_Callable_Subprogram (Subp : Asis.Element) return Boolean; 448 -- Checks that given subprogram is not abstract nor null procedure. 449 450 function Is_Fully_Private 451 (Arg : Asis.Declaration) return Boolean; 452 -- Detects if Arg and it's incomplete declaration (if present) 453 -- are both in private part. 454 455 procedure Generate_Test_Package (Data : Data_Holder); 456 -- Generates test package spec and body. Completely regeneratable. 457 458 procedure Generate_Function_Wrapper 459 (Current_Subp : Subp_Info; Declaration_Only : Boolean := False); 460 -- Print a test-case specific wrapper for tested function. 461 462 procedure Generate_Procedure_Wrapper 463 (Current_Subp : Subp_Info; Declaration_Only : Boolean := False); 464 -- Print a test-case specific wrapper for tested function. 465 466 procedure Generate_Skeletons (Data : Data_Holder); 467 -- Generates skeletons for those routines that do not have tests already. 468 469 procedure Print_Comment_Declaration (Subp : Subp_Info; Span : Natural := 0); 470 -- Prints the file containing the tested subprogram as well as the line 471 -- coloumn numbers of the tested subprogram declaration. 472 473 procedure Print_Comment_Separate (Subp : Subp_Info; Span : Natural := 0); 474 -- Prints commented image of tested subprogram with given span. 475 476 function Corresponding_Generic_Package 477 (Package_Instance : Asis.Element) return Asis.Element; 478 -- Returns a corresponding generic package declaration for a 479 -- formal package. 480 481 procedure Generate_Test_Package_Instantiation (Data : Data_Holder); 482 -- Generates an instatiation of the corresponding generic test package 483 484 procedure Generate_Project_File; 485 -- Generates a project file that sets the value of Source_Dirs 486 -- with the directories whe generated tests are placed and includes 487 -- the argument project file. 488 489 function Format_Time (Time : OS_Time) return String; 490 -- Returns image of given time in 1901-01-01 00:00:00 format. 491 492 procedure Put_Wrapper_Rename (Span : Natural; Current_Subp : Subp_Info); 493 -- Puts subprogram renaming declaration, which renames generated wrapper 494 -- into original tested subprogram's name. 495 496 function Sanitize_TC_Name (TC_Name : String) return String; 497 -- Processes the name of the test case in such a way that it could be used 498 -- as a part of test routine name. the name is trimmed, then all sequences 499 -- of whitespace characters are replaced with an underscore, all other 500 -- illegal characters are omitted. 501 502 ------------------------ 503 -- Nesting processing -- 504 ------------------------ 505 506 function Nesting_Common_Prefix 507 (Nesting_1, Nesting_2 : String) return String; 508 -- Returns the common prefix of two nestings. 509 510 function Nesting_Difference 511 (Nesting_1, Nesting_2 : String) return String; 512 -- Returns difference in ending of two nestings without the first dot 513 -- of the deeper nesting. 514 515 procedure Generate_Nested_Hierarchy (Data : Data_Holder); 516 -- Create dummy child packages copying nested packages from tested package. 517 518 ----------------------- 519 -- Marker Processing -- 520 ----------------------- 521 522 package String_Vectors is new 523 Ada.Containers.Indefinite_Vectors (Natural, String); 524 525 type Markered_Data is record 526 Commented_Out : Boolean := False; 527 Short_Name_Used : Boolean := False; 528 Short_Name : String_Access := new String'(""); 529 TR_Text : String_Vectors.Vector; 530 Issue_Warning : Boolean := False; 531 end record; 532 533 type Unique_Hash is record 534 Version : String_Access; 535 Hash : String_Access; 536 TC_Hash : String_Access; 537 end record; 538 539 function "<" (L, R : Unique_Hash) return Boolean; 540 541 package Markered_Data_Maps is new 542 Ada.Containers.Indefinite_Ordered_Maps (Unique_Hash, Markered_Data); 543 use Markered_Data_Maps; 544 545 Markered_Data_Map : Markered_Data_Maps.Map; 546 547 procedure Put_Opening_Comment_Section 548 (Subp : Subp_Info; 549 Overloading_N : Natural; 550 Commented_Out : Boolean := False; 551 Use_Short_Name : Boolean := True; 552 Type_Name : String := ""); 553 554 procedure Put_Closing_Comment_Section 555 (Subp : Subp_Info; 556 Overloading_N : Natural; 557 Commented_Out : Boolean := False; 558 Use_Short_Name : Boolean := True); 559 560 procedure Get_Subprograms_From_Package (File : String); 561 562 procedure Get_Subprogram_From_Separate 563 (File : String; 564 UH : Unique_Hash; 565 Subp : Subp_Info); 566 567 function Uncomment_Line (S : String) return String; 568 -- Removes two dashes and two spaces from the beginning of the line. 569 -- Returns argument string if commenting prefix not found. 570 571 function Find_Same_Short_Name 572 (MD_Map : Markered_Data_Maps.Map; 573 Short_Name : String) return Markered_Data_Maps.Cursor; 574 -- Searches for the test with given short name 575 576 function "<" (L, R : Unique_Hash) return Boolean is 577 begin 578 if L.Version.all = R.Version.all then 579 if L.Hash.all = R.Hash.all then 580 return L.TC_Hash.all < R.TC_Hash.all; 581 else 582 return L.Hash.all < R.Hash.all; 583 end if; 584 else 585 return L.Version.all < R.Version.all; 586 end if; 587 end "<"; 588 589 --------------------------- 590 -- Nesting_Common_Prefix -- 591 --------------------------- 592 593 function Nesting_Common_Prefix 594 (Nesting_1, Nesting_2 : String) return String 595 is 596 L1, L2 : Integer; 597 Last_Dot : Integer; 598 begin 599 L1 := Nesting_1'First; 600 L2 := Nesting_2'First; 601 loop 602 603 if Nesting_1 (L1) = Nesting_2 (L2) then 604 605 if L1 = Nesting_1'Last then 606 return Nesting_1; 607 end if; 608 609 if L2 = Nesting_2'Last then 610 return Nesting_2; 611 end if; 612 613 if Nesting_1 (L1) = '.' then 614 Last_Dot := L1; 615 end if; 616 617 L1 := L1 + 1; 618 L2 := L2 + 1; 619 else 620 return Nesting_1 (Nesting_1'First .. Last_Dot - 1); 621 end if; 622 623 end loop; 624 625 end Nesting_Common_Prefix; 626 627 ------------------------ 628 -- Nesting_Difference -- 629 ------------------------ 630 631 function Nesting_Difference 632 (Nesting_1, Nesting_2 : String) return String 633 is 634 L : constant Integer := Integer'Min (Nesting_1'Length, Nesting_2'Length); 635 begin 636 637 if Nesting_1'Length > Nesting_2'Length then 638 return Nesting_1 (Nesting_1'First + L + 1 .. Nesting_1'Last); 639 else 640 return Nesting_2 (Nesting_2'First + L + 1 .. Nesting_2'Last); 641 end if; 642 643 end Nesting_Difference; 644 645 ------------------------------------- 646 -- Corresponding_Generic_Package -- 647 ------------------------------------- 648 function Corresponding_Generic_Package 649 (Package_Instance : Asis.Element) return Asis.Element 650 is 651 Name : constant Asis.Element := First_Name (Package_Instance); 652 begin 653 return 654 Unit_Declaration (Library_Unit_Declaration (Defining_Name_Image 655 (Corresponding_Generic_Element (Name)), The_Context)); 656 end Corresponding_Generic_Package; 657 658 ----------------- 659 -- Create_Tree -- 660 ----------------- 661 662 procedure Create_Tree (Full_Source_Name : String; Success : out Boolean) is 663 begin 664 Trace (Me, "Creating tree for " & Full_Source_Name); 665 Compile 666 (new String'(Full_Source_Name), 667 Arg_List.all, 668 Success, 669 GCC => ASIS_UL.Common.Gcc_To_Call); 670 end Create_Tree; 671 672 -------------------------- 673 -- Find_Same_Short_Name -- 674 -------------------------- 675 676 function Find_Same_Short_Name 677 (MD_Map : Markered_Data_Maps.Map; 678 Short_Name : String) return Markered_Data_Maps.Cursor 679 is 680 Cur : Markered_Data_Maps.Cursor := MD_Map.First; 681 MD : Markered_Data; 682 begin 683 loop 684 exit when Cur = Markered_Data_Maps.No_Element; 685 686 MD := Markered_Data_Maps.Element (Cur); 687 if 688 MD.Short_Name_Used 689 and then MD.Short_Name.all = Short_Name 690 -- it's too dangerous to use autocorrect with test cases, since 691 -- there is no way to tell, if this is a modified test case name, 692 -- a whole new testcase or just another test case for same subp 693 and then Markered_Data_Maps.Key (Cur).TC_Hash.all = "" 694 then 695 exit; 696 end if; 697 698 Markered_Data_Maps.Next (Cur); 699 end loop; 700 return Cur; 701 end Find_Same_Short_Name; 702 703 ----------------- 704 -- Format_Time -- 705 ----------------- 706 707 function Format_Time (Time : OS_Time) return String is 708 709 function Prefix_With_Zero (S : String) return String; 710 711 function Prefix_With_Zero (S : String) return String is 712 S_Trimmed : constant String := Trim (S, Both); 713 begin 714 if S_Trimmed'Length = 1 then 715 return "0" & S_Trimmed; 716 else 717 return S_Trimmed; 718 end if; 719 end Prefix_With_Zero; 720 begin 721 return 722 Trim (Integer'Image (GM_Year (Time)), Both) & "-" & 723 Prefix_With_Zero (Integer'Image (GM_Month (Time))) & "-" & 724 Prefix_With_Zero (Integer'Image (GM_Day (Time))) & " " & 725 Prefix_With_Zero (Integer'Image (GM_Hour (Time))) & ":" & 726 Prefix_With_Zero (Integer'Image (GM_Minute (Time))) & ":" & 727 Prefix_With_Zero (Integer'Image (GM_Second (Time))); 728 end Format_Time; 729 730 ------------------- 731 -- Gather_Data -- 732 ------------------- 733 734 procedure Gather_Data 735 (The_Unit : Asis.Compilation_Unit; 736 Data : out Data_Holder; 737 Suite_Data_List : out Suites_Data_Type; 738 Apropriate_Source : out Boolean) 739 is separate; 740 741 --------------------------- 742 -- Gather_Direct_Callees -- 743 --------------------------- 744 745 procedure Gather_Direct_Callees 746 (Decl : Asis.Declaration; Set : in out String_Set.Set) 747 is 748 Control : Traverse_Control := Continue; 749 State : No_State := Not_Used; 750 751 procedure Pre_Operation 752 (Element : Asis.Element; 753 Control : in out Traverse_Control; 754 State : in out No_State); 755 756 procedure Get_Callees is new Traverse_Element 757 (Pre_Operation => Pre_Operation, 758 Post_Operation => No_Op, 759 State_Information => No_State); 760 761 procedure Pre_Operation 762 (Element : Asis.Element; 763 Control : in out Traverse_Control; 764 State : in out No_State) 765 is 766 pragma Unreferenced (Control, State); 767 Arg_Kind : constant Flat_Element_Kinds := Flat_Element_Kind (Element); 768 769 Decl : Asis.Element; 770 begin 771 772 case Arg_Kind is 773 774 when A_Procedure_Call_Statement => 775 Decl := Corresponding_Called_Entity_Unwound (Element); 776 777 when A_Function_Call => 778 Decl := Corresponding_Called_Function_Unwound (Element); 779 780 when others => 781 return; 782 end case; 783 784 -- Process simple cases for now. Dispatchings, renamings and parts of 785 -- instances are not yet supported. 786 787 if Is_Nil (Decl) then 788 return; 789 end if; 790 791 if Is_Part_Of_Instance (Decl) then 792 return; 793 end if; 794 795 case Flat_Element_Kind (Decl) is 796 when A_Function_Instantiation | 797 A_Procedure_Instantiation => 798 -- No way to stub a generic 799 return; 800 when A_Function_Body_Declaration | 801 A_Procedure_Body_Declaration | 802 A_Procedure_Body_Stub | 803 A_Function_Body_Stub => 804 -- No previous spec declaration, which means it is declared 805 -- in same body; no need to call a setter. 806 return; 807 when An_Ordinary_Type_Declaration => 808 -- A function renaming an enumeration type's literal 809 return; 810 when others => 811 null; 812 end case; 813 814 if Is_Part_Of_Implicit (Decl) then 815 if 816 Flat_Element_Kind (Decl) = A_Function_Declaration and then 817 (not Is_Nil (Corresponding_Equality_Operator (Decl))) 818 then 819 return; 820 end if; 821 Decl := Corresponding_Declaration (Decl); 822 end if; 823 824 case Flat_Element_Kind (Decl) is 825 when A_Null_Procedure_Declaration | 826 A_Formal_Procedure_Declaration | 827 A_Formal_Function_Declaration => 828 return; 829 when others => 830 null; 831 end case; 832 833 declare 834 Suffix : constant String := 835 "_" 836 & Substring_6 (Mangle_Hash_Full (Decl)) 837 & "_" 838 & Substring_6 (GNAT.SHA1.Digest (Get_Nesting (Decl))); 839 begin 840 Set.Include 841 (Get_Nesting (Decl) 842 & "." 843 & Stub_Data_Unit_Name 844 & "." 845 & Setter_Prefix 846 & To_String_First_Name (Decl) 847 & Suffix); 848 end; 849 850 end Pre_Operation; 851 begin 852 Trace 853 (Me_Direct_Callees, 854 "Gathering direct callees for " & To_String_First_Name (Decl)); 855 Increase_Indent; 856 Set.Clear; 857 858 if Flat_Element_Kind (Decl) = An_Expression_Function_Declaration then 859 -- Those do not have an actual bodyso we need to parse their return 860 -- statement. 861 Get_Callees (Result_Expression (Decl), Control, State); 862 else 863 if Is_Nil (Corresponding_Body (Decl)) then 864 return; 865 end if; 866 Get_Callees (Corresponding_Body (Decl), Control, State); 867 end if; 868 Trace 869 (Me_Direct_Callees, 870 "Direct callees gathered"); 871 Decrease_Indent; 872 end Gather_Direct_Callees; 873 874 ------------------------------ 875 -- Gather_Substitution_Data -- 876 ------------------------------ 877 878 procedure Gather_Substitution_Data 879 (Suite_Data_List : in out Suites_Data_Type) 880 is 881 TR : GNATtest.Harness.Generator.Test_Routine_Info; 882 TR_W : Test_Routine_Info_Wrapper; 883 LTR : GNATtest.Harness.Generator.Test_Routine_Info_Enhanced; 884 LTR_W : Test_Routine_Info_Enhanced_Wrapper; 885 886 Test_Type_Wrapper : Test_Type_Info_Wrapper; 887 888 Parent_Unit : Asis.Compilation_Unit; 889 Parent_Unit_File : String_Access; 890 891 Overridden_Subp : Asis.Element; 892 Owner_Decl : Asis.Element; 893 894 Depth : Natural; 895 begin 896 for 897 K in Suite_Data_List.TR_List.First_Index .. 898 Suite_Data_List.TR_List.Last_Index 899 loop 900 TR_W := Suite_Data_List.TR_List.Element (K); 901 TR := TR_W.TR_Info; 902 903 if Is_Overriding_Operation (TR_W.Original_Subp) then 904 905 Overridden_Subp := 906 Corresponding_Overridden_Operation (TR_W.Original_Subp); 907 908 if Is_Part_Of_Inherited (Overridden_Subp) then 909 Overridden_Subp := 910 Corresponding_Declaration (Overridden_Subp); 911 end if; 912 913 Parent_Unit := Enclosing_Compilation_Unit (Overridden_Subp); 914 915 Parent_Unit_File := new String' 916 (To_String (Text_Name (Parent_Unit))); 917 918 if Is_Dispatching_Operation (Overridden_Subp) then 919 -- In some cases it could be not dispatching 920 921 Owner_Decl := 922 Enclosing_Element (Primitive_Owner (Overridden_Subp)); 923 924 if 925 Source_Present (Parent_Unit_File.all) and then 926 Is_Callable_Subprogram (Overridden_Subp) and then 927 Test_Types_Linked (Owner_Decl, TR_W.Original_Type) and then 928 No_Inheritance_Through_Generics 929 (Owner_Decl, TR_W.Original_Type) 930 then 931 LTR.TR_Text_Name := new String'(TR.TR_Text_Name.all); 932 933 Depth := 934 GNATtest.Harness.Generator.Inheritance_Depth 935 (TR_W.Original_Type, Owner_Decl); 936 LTR.Inheritance_Depth := Depth; 937 938 for 939 L in Suite_Data_List.Test_Types.First_Index .. 940 Suite_Data_List.Test_Types.Last_Index 941 loop 942 943 Test_Type_Wrapper := 944 Suite_Data_List.Test_Types.Element (L); 945 946 if 947 Is_Equal 948 (Test_Type_Wrapper.Original_Type, TR_W.Original_Type) 949 then 950 951 if 952 Depth > 953 Test_Type_Wrapper.TT_Info.Max_Inheritance_Depth 954 then 955 Test_Type_Wrapper.TT_Info.Max_Inheritance_Depth := 956 Depth; 957 958 Suite_Data_List.Test_Types.Replace_Element 959 (L, Test_Type_Wrapper); 960 961 exit; 962 end if; 963 end if; 964 965 end loop; 966 967 LTR_W.TR_Info := LTR; 968 LTR_W.Original_Type := TR_W.Original_Type; 969 LTR_W.Test_Package := new String'(TR_W.Test_Package.all); 970 971 -- adding sloc info 972 LTR_W.TR_Info.Tested_Sloc := new String' 973 (Base_Name (Parent_Unit_File.all) 974 & ":" 975 & Trim 976 (Integer'Image (First_Line_Number (Overridden_Subp)), 977 Both) 978 & ":" 979 & Trim 980 (Integer'Image (First_Column_Number (Overridden_Subp)), 981 Both) 982 & ": overridden at " 983 & Base_Name 984 (To_String 985 (Text_Name 986 (Enclosing_Compilation_Unit 987 (TR_W.Original_Type)))) 988 & ":" 989 & Trim 990 (Integer'Image (First_Line_Number (TR_W.Original_Subp)), 991 Both) 992 & ":" 993 & Trim 994 (Integer'Image 995 (First_Column_Number (TR_W.Original_Subp)), 996 Both) 997 & ":"); 998 999 Suite_Data_List.LTR_List.Append (LTR_W); 1000 1001 end if; 1002 end if; 1003 end if; 1004 end loop; 1005 end Gather_Substitution_Data; 1006 1007 ------------------------------- 1008 -- Generate_Function_Wrapper -- 1009 ------------------------------- 1010 1011 procedure Generate_Function_Wrapper 1012 (Current_Subp : Subp_Info; Declaration_Only : Boolean := False) 1013 is 1014 Str_Set : String_Set.Set; 1015 Cur : String_Set.Cursor; 1016 begin 1017 S_Put (0, GT_Marker_Begin); 1018 New_Line_Count; 1019 S_Put 1020 (3, 1021 "function " & 1022 Wrapper_Prefix & 1023 Current_Subp.Subp_Mangle_Name.all); 1024 declare 1025 Params : constant 1026 Asis.Parameter_Specification_List := Parameter_Profile 1027 (Current_Subp.Subp_Declaration); 1028 Result : constant Asis.Element := 1029 Result_Profile (Current_Subp.Subp_Declaration); 1030 1031 Result_Image : constant String := 1032 Trim (To_String (Element_Image (Result)), Both); 1033 begin 1034 for I in Params'Range loop 1035 if I = Params'First then 1036 S_Put (0, " ("); 1037 end if; 1038 S_Put 1039 (0, 1040 Trim 1041 (To_String (Element_Image (Params (I))), 1042 Both)); 1043 if I = Params'Last then 1044 S_Put 1045 (0, 1046 ") "); 1047 else 1048 S_Put (0, "; "); 1049 end if; 1050 end loop; 1051 1052 S_Put (0, " return " & Result_Image); 1053 1054 if Declaration_Only then 1055 return; 1056 end if; 1057 1058 New_Line_Count; 1059 S_Put (3, "is"); 1060 New_Line_Count; 1061 1062 Str_Set := Current_Subp.TC_Info.Params_To_Temp; 1063 Cur := Str_Set.First; 1064 loop 1065 exit when Cur = String_Set.No_Element; 1066 1067 S_Put (6, String_Set.Element (Cur)); 1068 New_Line_Count; 1069 1070 String_Set.Next (Cur); 1071 end loop; 1072 1073 S_Put (3, "begin"); 1074 New_Line_Count; 1075 1076 if Current_Subp.TC_Info.Req_Image.all /= "" then 1077 S_Put (6, "begin"); 1078 New_Line_Count; 1079 S_Put (9, "pragma Assert"); 1080 New_Line_Count; 1081 S_Put 1082 (11, 1083 "(" & 1084 Current_Subp.TC_Info.Req_Image.all & 1085 ");"); 1086 New_Line_Count; 1087 S_Put (9, "exception"); 1088 New_Line_Count; 1089 S_Put (12, "when System.Assertions.Assert_Failure =>"); 1090 New_Line_Count; 1091 S_Put (15, "AUnit.Assertions.Assert"); 1092 New_Line_Count; 1093 S_Put (17, "(False,"); 1094 New_Line_Count; 1095 S_Put 1096 (18, 1097 """req_sloc(" 1098 & Current_Subp.TC_Info.Req_Line.all 1099 & "):" 1100 & Current_Subp.TC_Info.Name.all 1101 & " test requirement violated"");"); 1102 New_Line_Count; 1103 S_Put (6, "end;"); 1104 New_Line_Count; 1105 end if; 1106 1107 S_Put (6, "declare"); 1108 New_Line_Count; 1109 S_Put 1110 (9, 1111 Current_Subp.Subp_Mangle_Name.all & 1112 "_Result : constant " & 1113 Result_Image & 1114 " := GNATtest_Generated.GNATtest_Standard." & 1115 Current_Subp.Nesting.all & 1116 "." & 1117 Current_Subp.Subp_Name_Image.all); 1118 1119 if Params'Length = 0 then 1120 S_Put (0, ";"); 1121 else 1122 S_Put (1, "("); 1123 for I in Params'Range loop 1124 declare 1125 Name_List : constant Asis.Element_List := Names (Params (I)); 1126 begin 1127 for J in Name_List'Range loop 1128 S_Put 1129 (0, 1130 To_String (Defining_Name_Image (Name_List (J)))); 1131 if J /= Name_List'Last then 1132 S_Put (0, ", "); 1133 end if; 1134 end loop; 1135 end; 1136 1137 if I = Params'Last then 1138 S_Put (0, ");"); 1139 else 1140 S_Put (0, ", "); 1141 end if; 1142 end loop; 1143 end if; 1144 1145 New_Line_Count; 1146 1147 S_Put (6, "begin"); 1148 New_Line_Count; 1149 1150 if Current_Subp.TC_Info.Ens_Image.all /= "" then 1151 S_Put (9, "begin"); 1152 New_Line_Count; 1153 S_Put (12, "pragma Assert"); 1154 New_Line_Count; 1155 S_Put 1156 (14, 1157 "(" & 1158 Current_Subp.TC_Info.Ens_Image.all & 1159 ");"); 1160 New_Line_Count; 1161 S_Put (9, "exception"); 1162 New_Line_Count; 1163 S_Put (12, "when System.Assertions.Assert_Failure =>"); 1164 New_Line_Count; 1165 S_Put (15, "AUnit.Assertions.Assert"); 1166 New_Line_Count; 1167 S_Put (17, "(False,"); 1168 New_Line_Count; 1169 S_Put 1170 (18, 1171 """ens_sloc(" 1172 & Current_Subp.TC_Info.Ens_Line.all 1173 & "):" 1174 & Current_Subp.TC_Info.Name.all 1175 & " test commitment violated"");"); 1176 New_Line_Count; 1177 S_Put (9, "end;"); 1178 New_Line_Count; 1179 end if; 1180 1181 S_Put 1182 (9, 1183 "return " & 1184 Current_Subp.Subp_Mangle_Name.all & 1185 "_Result;"); 1186 New_Line_Count; 1187 1188 S_Put (6, "end;"); 1189 New_Line_Count; 1190 1191 S_Put 1192 (3, 1193 "end " & 1194 Wrapper_Prefix & 1195 Current_Subp.Subp_Mangle_Name.all & 1196 ";"); 1197 New_Line_Count; 1198 S_Put (0, GT_Marker_End); 1199 New_Line_Count; 1200 end; 1201 end Generate_Function_Wrapper; 1202 1203 ------------------------------- 1204 -- Generate_Nested_Hierarchy -- 1205 ------------------------------- 1206 1207 procedure Generate_Nested_Hierarchy (Data : Data_Holder) 1208 is 1209 Cur : Package_Info_List.Cursor := Data.Package_Data_List.First; 1210 Output_Dir : constant String := 1211 Get_Source_Output_Dir (Data.Unit_File_Name.all); 1212 begin 1213 loop 1214 exit when Cur = Package_Info_List.No_Element; 1215 1216 declare 1217 S : constant String := 1218 Package_Info_List.Element (Cur).Name.all; 1219 S_Pack : constant String := 1220 Data.Unit_Full_Name.all & "." & 1221 Test_Data_Unit_Name & "." & 1222 Test_Unit_Name & "." & 1223 Nesting_Difference (Data.Unit_Full_Name.all, S); 1224 begin 1225 if 1226 Data.Unit_Full_Name.all /= S 1227 then 1228 Create 1229 (Output_Dir & Directory_Separator & 1230 Unit_To_File_Name (S_Pack) & ".ads"); 1231 1232 S_Put (0, "package " & S_Pack & " is"); 1233 Put_New_Line; 1234 S_Put (0, "end " & S_Pack & ";"); 1235 Put_New_Line; 1236 1237 Close_File; 1238 end if; 1239 end; 1240 1241 Package_Info_List.Next (Cur); 1242 end loop; 1243 1244 if not Data.Has_Simple_Case then 1245 Create 1246 (Output_Dir & Directory_Separator & 1247 Unit_To_File_Name 1248 (Data.Unit_Full_Name.all & "." & 1249 Test_Data_Unit_Name & "." & 1250 Test_Unit_Name) & 1251 ".ads"); 1252 1253 S_Put 1254 (0, 1255 "package " & Data.Unit_Full_Name.all & 1256 "." & Test_Data_Unit_Name & "." & Test_Unit_Name & " is"); 1257 Put_New_Line; 1258 S_Put 1259 (0, 1260 "end " & Data.Unit_Full_Name.all & 1261 "." & Test_Data_Unit_Name & "." & Test_Unit_Name & ";"); 1262 Put_New_Line; 1263 1264 Close_File; 1265 1266 Excluded_Test_Package_Bodies.Include 1267 (Unit_To_File_Name 1268 (Data.Unit_Full_Name.all & "." 1269 & Test_Data_Unit_Name & "." 1270 & Test_Unit_Name) 1271 & ".adb"); 1272 1273 Create 1274 (Output_Dir & Directory_Separator & 1275 Unit_To_File_Name 1276 (Data.Unit_Full_Name.all & "." & 1277 Test_Data_Unit_Name) & 1278 ".ads"); 1279 1280 S_Put 1281 (0, 1282 "package " & Data.Unit_Full_Name.all & 1283 "." & Test_Data_Unit_Name & " is"); 1284 Put_New_Line; 1285 S_Put 1286 (0, 1287 "end " & Data.Unit_Full_Name.all & 1288 "." & Test_Data_Unit_Name & ";"); 1289 Put_New_Line; 1290 1291 Close_File; 1292 1293 Excluded_Test_Package_Bodies.Include 1294 (Unit_To_File_Name 1295 (Data.Unit_Full_Name.all & "." 1296 & Test_Data_Unit_Name) 1297 & ".adb"); 1298 end if; 1299 1300 end Generate_Nested_Hierarchy; 1301 1302 -------------------------------- 1303 -- Generate_Procedure_Wrapper -- 1304 -------------------------------- 1305 1306 procedure Generate_Procedure_Wrapper 1307 (Current_Subp : Subp_Info; Declaration_Only : Boolean := False) 1308 is 1309 Str_Set : String_Set.Set; 1310 Cur : String_Set.Cursor; 1311 begin 1312 S_Put (0, GT_Marker_Begin); 1313 New_Line_Count; 1314 S_Put 1315 (3, 1316 "procedure " & 1317 Wrapper_Prefix & 1318 Current_Subp.Subp_Mangle_Name.all); 1319 declare 1320 Params : constant 1321 Asis.Parameter_Specification_List := Parameter_Profile 1322 (Current_Subp.Subp_Declaration); 1323 begin 1324 for I in Params'Range loop 1325 if I = Params'First then 1326 S_Put (0, " ("); 1327 end if; 1328 S_Put 1329 (0, 1330 Trim 1331 (To_String (Element_Image (Params (I))), 1332 Both)); 1333 if I = Params'Last then 1334 S_Put 1335 (0, 1336 ") "); 1337 else 1338 S_Put (0, "; "); 1339 end if; 1340 end loop; 1341 1342 if Declaration_Only then 1343 return; 1344 end if; 1345 1346 New_Line_Count; 1347 S_Put (3, "is"); 1348 New_Line_Count; 1349 1350 Str_Set := Current_Subp.TC_Info.Params_To_Temp; 1351 Cur := Str_Set.First; 1352 loop 1353 exit when Cur = String_Set.No_Element; 1354 1355 S_Put (6, String_Set.Element (Cur)); 1356 New_Line_Count; 1357 1358 String_Set.Next (Cur); 1359 end loop; 1360 1361 S_Put (3, "begin"); 1362 New_Line_Count; 1363 1364 if Current_Subp.TC_Info.Req_Image.all /= "" then 1365 S_Put (6, "begin"); 1366 New_Line_Count; 1367 S_Put (9, "pragma Assert"); 1368 New_Line_Count; 1369 S_Put 1370 (11, 1371 "(" & 1372 Current_Subp.TC_Info.Req_Image.all & 1373 ");"); 1374 New_Line_Count; 1375 S_Put (6, "exception"); 1376 New_Line_Count; 1377 S_Put (9, "when System.Assertions.Assert_Failure =>"); 1378 New_Line_Count; 1379 S_Put (12, "AUnit.Assertions.Assert"); 1380 New_Line_Count; 1381 S_Put (14, "(False,"); 1382 New_Line_Count; 1383 S_Put 1384 (15, 1385 """req_sloc(" 1386 & Current_Subp.TC_Info.Req_Line.all 1387 & "):" 1388 & Current_Subp.TC_Info.Name.all 1389 & " test requirement violated"");"); 1390 New_Line_Count; 1391 S_Put (6, "end;"); 1392 New_Line_Count; 1393 end if; 1394 1395 S_Put 1396 (6, 1397 "GNATtest_Generated.GNATtest_Standard." & 1398 Current_Subp.Nesting.all & 1399 "." & 1400 Current_Subp.Subp_Text_Name.all); 1401 1402 if Params'Length = 0 then 1403 S_Put (0, ";"); 1404 else 1405 S_Put (1, "("); 1406 for I in Params'Range loop 1407 declare 1408 Name_List : constant Asis.Element_List := Names (Params (I)); 1409 begin 1410 for J in Name_List'Range loop 1411 S_Put 1412 (0, 1413 To_String (Defining_Name_Image (Name_List (J)))); 1414 if J /= Name_List'Last then 1415 S_Put (0, ", "); 1416 end if; 1417 end loop; 1418 end; 1419 if I = Params'Last then 1420 S_Put (0, ");"); 1421 else 1422 S_Put (0, ", "); 1423 end if; 1424 end loop; 1425 end if; 1426 1427 New_Line_Count; 1428 1429 if Current_Subp.TC_Info.Ens_Image.all /= "" then 1430 S_Put (6, "begin"); 1431 New_Line_Count; 1432 S_Put (9, "pragma Assert"); 1433 New_Line_Count; 1434 S_Put 1435 (11, 1436 "(" & 1437 Current_Subp.TC_Info.Ens_Image.all & 1438 ");"); 1439 New_Line_Count; 1440 New_Line_Count; 1441 S_Put (6, "exception"); 1442 New_Line_Count; 1443 S_Put (9, "when System.Assertions.Assert_Failure =>"); 1444 New_Line_Count; 1445 S_Put (12, "AUnit.Assertions.Assert"); 1446 New_Line_Count; 1447 S_Put (14, "(False,"); 1448 New_Line_Count; 1449 S_Put 1450 (15, 1451 """ens_sloc(" 1452 & Current_Subp.TC_Info.Ens_Line.all 1453 & "):" 1454 & Current_Subp.TC_Info.Name.all 1455 & " test commitment violated"");"); 1456 New_Line_Count; 1457 S_Put (6, "end;"); 1458 New_Line_Count; 1459 end if; 1460 1461 S_Put 1462 (3, 1463 "end " & 1464 Wrapper_Prefix & 1465 Current_Subp.Subp_Mangle_Name.all & 1466 ";"); 1467 New_Line_Count; 1468 S_Put (0, GT_Marker_End); 1469 New_Line_Count; 1470 end; 1471 end Generate_Procedure_Wrapper; 1472 1473 --------------------------- 1474 -- Generate_Project_File -- 1475 --------------------------- 1476 1477 procedure Generate_Project_File is 1478 Tmp_Str : String_Access; 1479 package Srcs is new 1480 Ada.Containers.Indefinite_Ordered_Sets (String); 1481 use Srcs; 1482 1483 Out_Dirs : Srcs.Set; 1484 Out_Dirs_Cur : Srcs.Cursor; 1485 1486 Output_Prj : String_Access; 1487 1488 Source_Prj_Name : String := 1489 Base_Name (Source_Prj.all, File_Extension (Source_Prj.all)); 1490 1491 begin 1492 for I in Source_Prj_Name'Range loop 1493 if Source_Prj_Name (I) = '-' then 1494 Source_Prj_Name (I) := '_'; 1495 end if; 1496 end loop; 1497 1498 Reset_Source_Iterator; 1499 loop 1500 Tmp_Str := new String'(Next_Source_Name); 1501 exit when Tmp_Str.all = ""; 1502 1503 if Is_Directory (Get_Source_Output_Dir (Tmp_Str.all)) then 1504 Include (Out_Dirs, Get_Source_Output_Dir (Tmp_Str.all)); 1505 end if; 1506 Free (Tmp_Str); 1507 end loop; 1508 1509 Output_Prj := 1510 new String'(Harness_Dir.all 1511 & Directory_Separator 1512 & Test_Prj_Prefix 1513 & Source_Prj_Name 1514 & ".gpr"); 1515 1516 Create (Output_Prj.all); 1517 1518 S_Put (0, "with ""aunit"";"); 1519 1520 Put_New_Line; 1521 S_Put (0, "with ""gnattest_common.gpr"";"); 1522 Put_New_Line; 1523 S_Put (0, "with """); 1524 S_Put 1525 (0, 1526 +Relative_Path 1527 (Create (+Source_Prj.all), 1528 Create (+Harness_Dir.all)) & 1529 """;"); 1530 Put_New_Line; 1531 S_Put 1532 (0, 1533 "project " 1534 & Test_Prj_Prefix 1535 & Base_Name (Source_Prj_Name) 1536 & " is"); 1537 Put_New_Line; 1538 Put_New_Line; 1539 1540 S_Put (3, "for Source_Dirs use"); 1541 Put_New_Line; 1542 1543 if Out_Dirs.Is_Empty then 1544 S_Put (5, "(""common"");"); 1545 1546 Put_New_Line; 1547 Put_New_Line; 1548 else 1549 Out_Dirs_Cur := Out_Dirs.First; 1550 S_Put (5, "("""); 1551 S_Put 1552 (0, 1553 +Relative_Path 1554 (Create (+Srcs.Element (Out_Dirs_Cur)), 1555 Create (+Harness_Dir.all)) & 1556 """"); 1557 loop 1558 Srcs.Next (Out_Dirs_Cur); 1559 exit when Out_Dirs_Cur = Srcs.No_Element; 1560 1561 S_Put (0, ","); 1562 Put_New_Line; 1563 S_Put (6, """"); 1564 S_Put 1565 (0, 1566 +Relative_Path 1567 (Create (+Srcs.Element (Out_Dirs_Cur)), 1568 Create (+Harness_Dir.all)) & 1569 """"); 1570 1571 end loop; 1572 S_Put (0, ","); 1573 Put_New_Line; 1574 S_Put (6, """common"");"); 1575 1576 Put_New_Line; 1577 Put_New_Line; 1578 end if; 1579 1580 S_Put (3, "package Compiler renames Gnattest_Common.Compiler;"); 1581 Put_New_Line; 1582 Put_New_Line; 1583 1584 if IDE_Package_Present then 1585 S_Put 1586 (3, 1587 "package Ide renames " & 1588 Base_Name (Source_Prj.all, File_Extension (Source_Prj.all)) & 1589 ".Ide;"); 1590 Put_New_Line; 1591 Put_New_Line; 1592 end if; 1593 1594 if Make_Package_Present then 1595 S_Put 1596 (3, 1597 "package Make renames " & 1598 Base_Name (Source_Prj.all, File_Extension (Source_Prj.all)) & 1599 ".Make;"); 1600 Put_New_Line; 1601 Put_New_Line; 1602 end if; 1603 1604 S_Put 1605 (0, 1606 "end " 1607 & Test_Prj_Prefix 1608 & Base_Name (Source_Prj_Name) 1609 & ";"); 1610 Close_File; 1611 1612 Tmp_Test_Prj := new String'(Normalize_Pathname 1613 (Name => Output_Prj.all, 1614 Case_Sensitive => False)); 1615 end Generate_Project_File; 1616 1617 ----------------------------- 1618 -- Generate_Test_Package -- 1619 ----------------------------- 1620 1621 procedure Generate_Test_Package (Data : Data_Holder) is 1622 1623 Output_Dir : constant String := 1624 Get_Source_Output_Dir (Data.Unit_File_Name.all); 1625 1626 Tmp_File_Name : constant String := 1627 "gnattest_tmp_test_package"; 1628 1629 Test_File_Name : String_Access; 1630 Data_Unit_Name : String_Access; 1631 Unit_Name : String_Access; 1632 Unit_Pref : String_Access; 1633 1634 Setters_Set : String_Set.Set; 1635 Set_Cur : String_Set.Cursor; 1636 1637 Subp_Cur : Subp_Data_List.Cursor; 1638 Pack_Cur : Package_Info_List.Cursor; 1639 1640 Current_Type : Base_Type_Info; 1641 -- The test type for which the primitives are 1642 -- put togather in the corresponding test package 1643 1644 Test_Unit_Suffix : String_Access; 1645 -- Generic or non-generic test package suffix or. 1646 1647 Actual_Test : Boolean; 1648 -- Indicates if current test package has at least one non-abstract test 1649 -- routine. In that case we need to include AUnit.Assertions. 1650 1651 Gen_Tests : Generic_Tests; 1652 -- Used to store all test type names in case of generic tested package. 1653 -- They are to be added at generic test storage. 1654 1655 Nesting_Add : String_Access; 1656 1657 UH : Unique_Hash; 1658 MD : Markered_Data; 1659 MD_Cur : Markered_Data_Maps.Cursor; 1660 1661 Subp_List : Subp_Data_List.List; 1662 Current_Subp : Subp_Info; 1663 Current_Pack : Package_Info; 1664 1665 TP_Map : TP_Mapping; 1666 TP_List : TP_Mapping_List.List; 1667 1668 Tear_Down_Line_Add : Natural := 0; 1669 1670 Short_Names_Used : String_Set.Set; 1671 1672 package Elements_Set is new 1673 Ada.Containers.Indefinite_Ordered_Sets (Asis.Element, "<", Is_Equal); 1674 use Elements_Set; 1675 1676 Shortnamed_Subps : Elements_Set.Set; 1677 1678 -- overlodaing number counting 1679 Name_Numbers : Name_Frequency.Map; 1680 package Elem_Number_Maps is new 1681 Ada.Containers.Indefinite_Ordered_Maps (Asis.Element, Natural); 1682 use Elem_Number_Maps; 1683 Elem_Numbers : Elem_Number_Maps.Map; 1684 1685 Test_Data_Package_Name : String_Access; 1686 1687 -- temporary storage for slocs of test routines 1688 type TR_SLOC_Buffer_Type is record 1689 TPtarg : String_Access; 1690 Test_F : String_Access; 1691 Test_T : String_Access; 1692 Subp : Subp_Info; 1693 TR_Line : Natural := 1; 1694 end record; 1695 1696 package TR_SLOC_Buffer_Lists is new 1697 Ada.Containers.Doubly_Linked_Lists (TR_SLOC_Buffer_Type); 1698 use TR_SLOC_Buffer_Lists; 1699 1700 TR_SLOC_Buffer : TR_SLOC_Buffer_Lists.List; 1701 1702 procedure Add_Buffered_TR_Slocs 1703 (TP_List : in out TP_Mapping_List.List; 1704 Common_Time : String); 1705 -- Pushes buffered test routine slocs into main mapping container. 1706 1707 function Is_Unimplemented_Test 1708 (TR_Text : String_Vectors.Vector) return Boolean; 1709 -- Searches for specific text pattern which indicates that given test 1710 -- skeleton was not modified by user after generation. 1711 1712 procedure Put_Test_Data_Header; 1713 1714 procedure Put_TP_Header (TD_Package_Name : String); 1715 1716 procedure Update_Generic_Packages (Instantiation : String); 1717 procedure Update_Generic_Packages (Gen_Pack : Generic_Package); 1718 1719 procedure Add_Buffered_TR_Slocs 1720 (TP_List : in out TP_Mapping_List.List; 1721 Common_Time : String) 1722 is 1723 Cur : TR_SLOC_Buffer_Lists.Cursor := TR_SLOC_Buffer.First; 1724 begin 1725 loop 1726 exit when Cur = TR_SLOC_Buffer_Lists.No_Element; 1727 1728 if TR_SLOC_Buffer_Lists.Element (Cur).Test_T /= null then 1729 Add_TR 1730 (TP_List, 1731 TR_SLOC_Buffer_Lists.Element (Cur).TPtarg.all, 1732 TR_SLOC_Buffer_Lists.Element (Cur).Test_F.all, 1733 "modified", 1734 TR_SLOC_Buffer_Lists.Element (Cur).Subp, 1735 TR_SLOC_Buffer_Lists.Element (Cur).TR_Line); 1736 else 1737 Add_TR 1738 (TP_List, 1739 TR_SLOC_Buffer_Lists.Element (Cur).TPtarg.all, 1740 TR_SLOC_Buffer_Lists.Element (Cur).Test_F.all, 1741 Common_Time, 1742 TR_SLOC_Buffer_Lists.Element (Cur).Subp, 1743 TR_SLOC_Buffer_Lists.Element (Cur).TR_Line); 1744 end if; 1745 TR_SLOC_Buffer_Lists.Next (Cur); 1746 end loop; 1747 1748 TR_SLOC_Buffer.Clear; 1749 1750 end Add_Buffered_TR_Slocs; 1751 1752 function Is_Unimplemented_Test 1753 (TR_Text : String_Vectors.Vector) return Boolean 1754 is 1755 Unimplemented_Line : constant String := 1756 """Test not implemented."""; 1757 begin 1758 1759 if TR_Text.Is_Empty then 1760 return True; 1761 end if; 1762 1763 for I in TR_Text.First_Index .. TR_Text.Last_Index loop 1764 if Index (TR_Text.Element (I), Unimplemented_Line) /= 0 then 1765 return True; 1766 end if; 1767 end loop; 1768 1769 return False; 1770 1771 end Is_Unimplemented_Test; 1772 1773 procedure Put_Test_Data_Header is 1774 begin 1775 S_Put 1776 (0, 1777 "-- This package is intended to set up and tear down " 1778 & " the test environment."); 1779 Put_New_Line; 1780 S_Put 1781 (0, 1782 "-- Once created by GNATtest, this package will " 1783 & "never be overwritten"); 1784 Put_New_Line; 1785 S_Put 1786 (0, 1787 "-- automatically. Contents of this package can be " 1788 & "modified in any way"); 1789 Put_New_Line; 1790 S_Put 1791 (0, 1792 "-- except for sections surrounded by a 'read only' marker."); 1793 Put_New_Line; 1794 Put_New_Line; 1795 end Put_Test_Data_Header; 1796 1797 procedure Put_TP_Header (TD_Package_Name : String) is 1798 begin 1799 S_Put 1800 (0, 1801 "-- This package has been generated automatically by GNATtest."); 1802 New_Line_Count; 1803 S_Put 1804 (0, 1805 "-- You are allowed to add your code to the bodies " 1806 & "of test routines."); 1807 New_Line_Count; 1808 S_Put 1809 (0, 1810 "-- Such changes will be kept during further regeneration " 1811 & "of this file."); 1812 New_Line_Count; 1813 S_Put 1814 (0, 1815 "-- All code placed outside of test routine bodies " 1816 & "will be lost. The"); 1817 New_Line_Count; 1818 S_Put 1819 (0, 1820 "-- code intended to set up and tear down the test " 1821 & "environment should be"); 1822 New_Line_Count; 1823 S_Put 1824 (0, 1825 "-- placed into " 1826 & TD_Package_Name & "."); 1827 New_Line_Count; 1828 New_Line_Count; 1829 end Put_TP_Header; 1830 1831 procedure Update_Generic_Packages (Gen_Pack : Generic_Package) is 1832 Cur : Generic_Package_Storage.Cursor := Gen_Package_Storage.First; 1833 GP : Generic_Package; 1834 begin 1835 while Cur /= Generic_Package_Storage.No_Element loop 1836 1837 GP := Generic_Package_Storage.Element (Cur); 1838 1839 if GP.Name.all = Gen_Pack.Name.all then 1840 if GP.Sloc /= null then 1841 -- Same package can be added several times. 1842 return; 1843 end if; 1844 GP.Sloc := Gen_Pack.Sloc; 1845 Gen_Package_Storage.Replace_Element (Cur, GP); 1846 return; 1847 end if; 1848 1849 Next (Cur); 1850 end loop; 1851 1852 Gen_Package_Storage.Append (Gen_Pack); 1853 end Update_Generic_Packages; 1854 1855 procedure Update_Generic_Packages (Instantiation : String) is 1856 Cur : Generic_Package_Storage.Cursor := Gen_Package_Storage.First; 1857 GP : Generic_Package; 1858 begin 1859 while Cur /= Generic_Package_Storage.No_Element loop 1860 1861 GP := Generic_Package_Storage.Element (Cur); 1862 1863 if GP.Name.all = Instantiation then 1864 if GP.Has_Instantiation then 1865 -- Same package can be instantiated multiple times. 1866 return; 1867 end if; 1868 GP.Has_Instantiation := True; 1869 Gen_Package_Storage.Replace_Element (Cur, GP); 1870 return; 1871 end if; 1872 1873 Next (Cur); 1874 end loop; 1875 1876 -- Instantiation is processed ahead of coresponding generic. 1877 -- Adding a template for it to later fill in the sloc. 1878 GP.Name := new String'(Instantiation); 1879 GP.Sloc := null; 1880 GP.Has_Instantiation := True; 1881 Gen_Package_Storage.Append (GP); 1882 end Update_Generic_Packages; 1883 1884 begin 1885 1886 if not Generate_Separates then 1887 Test_Info.Include (Data.Unit_File_Name.all, 0); 1888 end if; 1889 1890 if Data.Is_Generic then 1891 Test_Unit_Suffix := new String'(Gen_Test_Unit_Name_Suff); 1892 Gen_Tests.Gen_Unit_Full_Name := new String'(Data.Unit_Full_Name.all); 1893 else 1894 Test_Unit_Suffix := new String'(Test_Unit_Name_Suff); 1895 end if; 1896 1897 for I in 1898 Data.Type_Data_List.First_Index .. Data.Type_Data_List.Last_Index 1899 loop 1900 1901 Current_Type := Data.Type_Data_List.Element (I); 1902 1903 -- setting up current package 1904 Pack_Cur := Data.Package_Data_List.First; 1905 loop 1906 exit when Pack_Cur = Package_Info_List.No_Element; 1907 1908 Current_Pack := Package_Info_List.Element (Pack_Cur); 1909 1910 if Current_Type.Nesting.all = Current_Pack.Name.all then 1911 exit; 1912 end if; 1913 1914 Pack_Cur := Package_Info_List.Next (Pack_Cur); 1915 end loop; 1916 1917 Actual_Test := False; 1918 1919 if Data.Unit_Full_Name.all = Current_Type.Nesting.all then 1920 Unit_Pref := new String'(Data.Unit_Full_Name.all); 1921 else 1922 Unit_Pref := new String' 1923 (Data.Unit_Full_Name.all & "." & 1924 Test_Data_Unit_Name & "." & 1925 Test_Unit_Name & "." & 1926 Nesting_Difference 1927 (Data.Unit_Full_Name.all, 1928 Current_Type.Nesting.all)); 1929 end if; 1930 1931 Data_Unit_Name := new String' 1932 (Unit_Pref.all & "." & 1933 Current_Type.Main_Type_Text_Name.all & 1934 Test_Data_Unit_Name_Suff); 1935 1936 Test_File_Name := new String'(Unit_To_File_Name (Data_Unit_Name.all)); 1937 1938 -- saving test data package name for further reference 1939 Test_Data_Package_Name := new String'(Data_Unit_Name.all); 1940 1941 if not Is_Regular_File 1942 (Output_Dir & Directory_Separator & Test_File_Name.all & ".ads") 1943 then 1944 1945 Create 1946 (Output_Dir & Directory_Separator & Test_File_Name.all & ".ads"); 1947 1948 Put_Test_Data_Header; 1949 1950 if not Current_Type.Has_Argument_Father then 1951 if Current_Pack.Data_Kind = Instantiation then 1952 S_Put 1953 (0, 1954 "with " 1955 & Current_Pack.Generic_Containing_Package.all 1956 & "." 1957 & Current_Type.Main_Type_Text_Name.all 1958 & Test_Data_Unit_Name_Suff 1959 & ";"); 1960 Put_New_Line; 1961 S_Put 1962 (0, 1963 "with " 1964 & Current_Pack.Generic_Containing_Package.all 1965 & "." 1966 & Current_Type.Main_Type_Text_Name.all 1967 & Test_Data_Unit_Name_Suff 1968 & "." 1969 & Current_Type.Main_Type_Text_Name.all 1970 & Test_Unit_Name_Suff 1971 & ";"); 1972 end if; 1973 Put_New_Line; 1974 S_Put (0, "with AUnit.Test_Fixtures;"); 1975 else 1976 if 1977 Current_Type.Argument_Father_Unit_Name.all = 1978 Current_Type.Argument_Father_Nesting.all 1979 then 1980 S_Put 1981 (0, 1982 "with " & 1983 Current_Type.Argument_Father_Unit_Name.all & 1984 "." & 1985 Current_Type.Argument_Father_Type_Name.all & 1986 Test_Data_Unit_Name_Suff & 1987 "." & 1988 Current_Type.Argument_Father_Type_Name.all & 1989 Test_Unit_Suffix.all & 1990 ";"); 1991 else 1992 S_Put 1993 (0, 1994 "with " & 1995 Current_Type.Argument_Father_Unit_Name.all & 1996 "." & 1997 Test_Data_Unit_Name & 1998 "." & 1999 Test_Unit_Name & 2000 "." & 2001 Nesting_Difference 2002 (Current_Type.Argument_Father_Unit_Name.all, 2003 Current_Type.Argument_Father_Nesting.all) & 2004 "." & 2005 Current_Type.Argument_Father_Type_Name.all & 2006 Test_Data_Unit_Name_Suff & 2007 "." & 2008 Current_Type.Argument_Father_Type_Name.all & 2009 Test_Unit_Suffix.all & 2010 ";"); 2011 end if; 2012 end if; 2013 Put_New_Line; 2014 Put_New_Line; 2015 2016 S_Put (0, "with GNATtest_Generated;"); 2017 Put_New_Line; 2018 Put_New_Line; 2019 2020 if Current_Pack.Is_Generic then 2021 S_Put (0, "generic"); 2022 Put_New_Line; 2023 S_Put 2024 (3, 2025 "type GNATtest_Test_Type is new " 2026 & "AUnit.Test_Fixtures.Test_Fixture"); 2027 Put_New_Line; 2028 S_Put (5, "with private;"); 2029 Put_New_Line; 2030 end if; 2031 2032 S_Put (0, "package " & Data_Unit_Name.all & " is"); 2033 Put_New_Line; 2034 Put_New_Line; 2035 2036 if Current_Pack.Data_Kind = Declaration_Data then 2037 if Current_Type.Has_Argument_Father then 2038 -- Declaring test type extension from another test type. 2039 S_Put (0, GT_Marker_Begin); 2040 Put_New_Line; 2041 S_Put 2042 (3, 2043 "type Test_" & 2044 Current_Type.Main_Type_Text_Name.all); 2045 if Current_Type.Main_Type_Abstract then 2046 S_Put (0, " is abstract new"); 2047 else 2048 S_Put (0, " is new"); 2049 end if; 2050 Put_New_Line; 2051 2052 if 2053 Current_Type.Argument_Father_Unit_Name.all /= 2054 Current_Type.Argument_Father_Nesting.all 2055 then 2056 Nesting_Add := new String' 2057 (Test_Data_Unit_Name & "." & 2058 Test_Unit_Name & "." & 2059 Nesting_Difference 2060 (Current_Type.Argument_Father_Unit_Name.all, 2061 Current_Type.Argument_Father_Nesting.all) & 2062 "."); 2063 else 2064 Nesting_Add := new String'(""); 2065 end if; 2066 2067 S_Put 2068 (5, 2069 "GNATtest_Generated.GNATtest_Standard." & 2070 Current_Type.Argument_Father_Unit_Name.all & 2071 "." & 2072 Nesting_Add.all & 2073 Current_Type.Argument_Father_Type_Name.all & 2074 Test_Data_Unit_Name_Suff & 2075 "." & 2076 Current_Type.Argument_Father_Type_Name.all & 2077 Test_Unit_Suffix.all & 2078 ".Test_" & 2079 Current_Type.Argument_Father_Type_Name.all); 2080 Put_New_Line; 2081 S_Put (0, GT_Marker_End); 2082 Put_New_Line; 2083 S_Put (3, "with null record;"); 2084 2085 Free (Nesting_Add); 2086 2087 else 2088 -- Declaring access type to tested type. 2089 S_Put 2090 (3, 2091 "type " & 2092 Current_Type.Main_Type_Text_Name.all & 2093 "_Access is access all " & 2094 "GNATtest_Generated.GNATtest_Standard." & 2095 Current_Type.Nesting.all & 2096 "." & 2097 Current_Type.Main_Type_Text_Name.all & 2098 "'Class;"); 2099 Put_New_Line; 2100 Put_New_Line; 2101 2102 -- Declaring root test type. 2103 S_Put (0, GT_Marker_Begin); 2104 Put_New_Line; 2105 S_Put 2106 (3, 2107 "type Test_" & 2108 Current_Type.Main_Type_Text_Name.all & 2109 " is"); 2110 if Current_Type.Main_Type_Abstract then 2111 S_Put (0, " abstract"); 2112 end if; 2113 S_Put (0, " new AUnit.Test_Fixtures.Test_Fixture"); 2114 Put_New_Line; 2115 S_Put (0, GT_Marker_End); 2116 Put_New_Line; 2117 S_Put (3, "with record"); 2118 Put_New_Line; 2119 S_Put 2120 (6, 2121 "Fixture : " & 2122 Current_Type.Main_Type_Text_Name.all & 2123 "_Access;"); 2124 Put_New_Line; 2125 S_Put (3, "end record;"); 2126 end if; 2127 else 2128 S_Put (0, GT_Marker_Begin); 2129 Put_New_Line; 2130 S_Put 2131 (3, 2132 "type Test_" & 2133 Current_Type.Main_Type_Text_Name.all & 2134 " is"); 2135 S_Put (0, " new AUnit.Test_Fixtures.Test_Fixture"); 2136 Put_New_Line; 2137 S_Put (0, GT_Marker_End); 2138 Put_New_Line; 2139 S_Put (3, "with null record;"); 2140 end if; 2141 2142 Put_New_Line; 2143 Put_New_Line; 2144 2145 if not Current_Type.Main_Type_Abstract then 2146 S_Put 2147 (3, 2148 "procedure Set_Up (Gnattest_T : in out Test_" & 2149 Current_Type.Main_Type_Text_Name.all & 2150 ");"); 2151 Put_New_Line; 2152 S_Put 2153 (3, 2154 "procedure Tear_Down (Gnattest_T : in out Test_" & 2155 Current_Type.Main_Type_Text_Name.all & 2156 ");"); 2157 Put_New_Line; 2158 Put_New_Line; 2159 end if; 2160 2161 if Current_Pack.Data_Kind = Instantiation then 2162 S_Put (0, GT_Marker_Begin); 2163 Put_New_Line; 2164 S_Put 2165 (3, 2166 "package Gnattest_Data_Inst is new " 2167 & "GNATtest_Generated.GNATtest_Standard." 2168 & Current_Pack.Name.all 2169 & "." 2170 & Current_Type.Main_Type_Text_Name.all 2171 & Test_Data_Unit_Name_Suff 2172 & " (Test_" 2173 & Current_Type.Main_Type_Text_Name.all 2174 & ");"); 2175 Put_New_Line; 2176 S_Put 2177 (3, 2178 "package Gnattest_Tests_Inst is new Gnattest_Data_Inst." 2179 & Current_Type.Main_Type_Text_Name.all 2180 & Test_Unit_Name_Suff 2181 & ";"); 2182 Put_New_Line; 2183 Put_New_Line; 2184 S_Put 2185 (3, 2186 "type New_Test is new Gnattest_Tests_Inst.Test_" 2187 & Current_Type.Main_Type_Text_Name.all 2188 & " with null record;"); 2189 Put_New_Line; 2190 S_Put (0, GT_Marker_End); 2191 Put_New_Line; 2192 Put_New_Line; 2193 S_Put 2194 (3, 2195 "procedure User_Set_Up (Gnattest_T : in out New_Test);"); 2196 Put_New_Line; 2197 S_Put 2198 (3, 2199 "procedure User_Tear_Down " 2200 & "(Gnattest_T : in out New_Test);"); 2201 Put_New_Line; 2202 Put_New_Line; 2203 end if; 2204 2205 if Current_Pack.Is_Generic then 2206 S_Put 2207 (3, 2208 "procedure User_Set_Up (Gnattest_T : in out Test_" 2209 & Current_Type.Main_Type_Text_Name.all 2210 & ") is null;"); 2211 Put_New_Line; 2212 S_Put 2213 (3, 2214 "procedure User_Tear_Down (Gnattest_T : in out Test_" 2215 & Current_Type.Main_Type_Text_Name.all 2216 & ") is null;"); 2217 Put_New_Line; 2218 Put_New_Line; 2219 end if; 2220 2221 S_Put (0, "end " & Data_Unit_Name.all & ";"); 2222 2223 Close_File; 2224 2225 end if; 2226 2227 if not Current_Type.Main_Type_Abstract and then 2228 not Is_Regular_File 2229 (Output_Dir & Directory_Separator & Test_File_Name.all & ".adb") 2230 then 2231 2232 Create 2233 (Output_Dir & Directory_Separator & Test_File_Name.all & ".adb"); 2234 2235 Put_Test_Data_Header; 2236 2237 S_Put (0, "package body " & Data_Unit_Name.all & " is"); 2238 Put_New_Line; 2239 Put_New_Line; 2240 2241 if Current_Pack.Data_Kind = Declaration_Data then 2242 if Current_Type.No_Default_Discriminant then 2243 S_Put 2244 (3, 2245 "-- Local_" & 2246 Current_Type.Main_Type_Text_Name.all & 2247 " : aliased " & 2248 "GNATtest_Generated.GNATtest_Standard." & 2249 Current_Type.Nesting.all & 2250 "." & 2251 Current_Type.Main_Type_Text_Name.all & 2252 ";"); 2253 else 2254 S_Put 2255 (3, 2256 "Local_" & 2257 Current_Type.Main_Type_Text_Name.all & 2258 " : aliased " & 2259 "GNATtest_Generated.GNATtest_Standard." & 2260 Current_Type.Nesting.all & 2261 "." & 2262 Current_Type.Main_Type_Text_Name.all & 2263 ";"); 2264 end if; 2265 Put_New_Line; 2266 end if; 2267 2268 S_Put 2269 (3, 2270 "procedure Set_Up (Gnattest_T : in out Test_" & 2271 Current_Type.Main_Type_Text_Name.all & 2272 ") is"); 2273 Put_New_Line; 2274 2275 if Current_Pack.Data_Kind = Declaration_Data then 2276 if Current_Pack.Is_Generic then 2277 S_Put 2278 (6, 2279 "X : Test_" 2280 & Current_Type.Main_Type_Text_Name.all 2281 & "'Class renames Test_" 2282 & Current_Type.Main_Type_Text_Name.all 2283 & "'Class (Gnattest_T);"); 2284 Put_New_Line; 2285 end if; 2286 end if; 2287 2288 S_Put (3, "begin"); 2289 Put_New_Line; 2290 2291 if Current_Type.Has_Argument_Father then 2292 if 2293 Current_Type.Argument_Father_Unit_Name.all /= 2294 Current_Type.Argument_Father_Nesting.all 2295 then 2296 Nesting_Add := new String' 2297 (Test_Data_Unit_Name & "." & 2298 Test_Unit_Name & "." & 2299 Nesting_Difference 2300 (Current_Type.Argument_Father_Unit_Name.all, 2301 Current_Type.Argument_Father_Nesting.all) & 2302 "."); 2303 else 2304 Nesting_Add := new String'(""); 2305 end if; 2306 2307 S_Put 2308 (5, 2309 "GNATtest_Generated.GNATtest_Standard." & 2310 Current_Type.Argument_Father_Unit_Name.all & 2311 "." & 2312 Nesting_Add.all & 2313 Current_Type.Argument_Father_Type_Name.all & 2314 Test_Data_Unit_Name_Suff & 2315 "." & 2316 Current_Type.Argument_Father_Type_Name.all & 2317 Test_Unit_Suffix.all & 2318 ".Test_" & 2319 Current_Type.Argument_Father_Type_Name.all & 2320 "(Gnattest_T).Set_Up;"); 2321 Put_New_Line; 2322 2323 Free (Nesting_Add); 2324 end if; 2325 2326 if Current_Pack.Data_Kind = Declaration_Data then 2327 if Current_Type.No_Default_Discriminant then 2328 S_Put 2329 (6, "null;"); 2330 Put_New_Line; 2331 S_Put 2332 (6, "-- Gnattest_T.Fixture := Local_" & 2333 Current_Type.Main_Type_Text_Name.all & 2334 "'Access;"); 2335 Put_New_Line; 2336 else 2337 S_Put 2338 (6, "Gnattest_T.Fixture := Local_" & 2339 Current_Type.Main_Type_Text_Name.all & 2340 "'Access;"); 2341 Put_New_Line; 2342 2343 if Current_Pack.Data_Kind = Declaration_Data then 2344 if Current_Pack.Is_Generic then 2345 S_Put (6, "X.User_Set_Up;"); 2346 Put_New_Line; 2347 end if; 2348 end if; 2349 end if; 2350 2351 else 2352 S_Put 2353 (6, "null;"); 2354 Put_New_Line; 2355 end if; 2356 S_Put (3, "end Set_Up;"); 2357 Put_New_Line; 2358 Put_New_Line; 2359 2360 S_Put 2361 (3, 2362 "procedure Tear_Down (Gnattest_T : in out Test_" & 2363 Current_Type.Main_Type_Text_Name.all & 2364 ") is"); 2365 Put_New_Line; 2366 2367 if Current_Pack.Data_Kind = Declaration_Data then 2368 if Current_Pack.Is_Generic then 2369 S_Put 2370 (6, 2371 "X : Test_" 2372 & Current_Type.Main_Type_Text_Name.all 2373 & "'Class renames Test_" 2374 & Current_Type.Main_Type_Text_Name.all 2375 & "'Class (Gnattest_T);"); 2376 Put_New_Line; 2377 end if; 2378 end if; 2379 2380 S_Put (3, "begin"); 2381 Put_New_Line; 2382 2383 if Current_Type.Has_Argument_Father then 2384 if 2385 Current_Type.Argument_Father_Unit_Name.all /= 2386 Current_Type.Argument_Father_Nesting.all 2387 then 2388 Nesting_Add := new String' 2389 (Test_Data_Unit_Name & "." & 2390 Test_Unit_Name & "." & 2391 Nesting_Difference 2392 (Current_Type.Argument_Father_Unit_Name.all, 2393 Current_Type.Argument_Father_Nesting.all) & 2394 "."); 2395 else 2396 Nesting_Add := new String'(""); 2397 end if; 2398 2399 S_Put 2400 (5, 2401 "GNATtest_Generated.GNATtest_Standard." & 2402 Current_Type.Argument_Father_Unit_Name.all & 2403 "." & 2404 Nesting_Add.all & 2405 Current_Type.Argument_Father_Type_Name.all & 2406 Test_Data_Unit_Name_Suff & 2407 "." & 2408 Current_Type.Argument_Father_Type_Name.all & 2409 Test_Unit_Suffix.all & 2410 ".Test_" & 2411 Current_Type.Argument_Father_Type_Name.all & 2412 "(Gnattest_T).Tear_Down;"); 2413 2414 Free (Nesting_Add); 2415 else 2416 if Current_Pack.Data_Kind = Declaration_Data 2417 and then Current_Pack.Is_Generic 2418 then 2419 S_Put (6, "X.User_Set_Up;"); 2420 else 2421 S_Put 2422 (6, "null;"); 2423 end if; 2424 end if; 2425 2426 Put_New_Line; 2427 S_Put (3, "end Tear_Down;"); 2428 2429 Put_New_Line; 2430 Put_New_Line; 2431 2432 if Current_Pack.Data_Kind = Instantiation then 2433 S_Put 2434 (3, 2435 "procedure User_Set_Up " 2436 & "(Gnattest_T : in out New_Test) is"); 2437 Put_New_Line; 2438 S_Put (6, "pragma Unreferenced (Gnattest_T);"); 2439 Put_New_Line; 2440 S_Put (3, "begin"); 2441 Put_New_Line; 2442 S_Put (6, "null;"); 2443 Put_New_Line; 2444 S_Put (3, "end User_Set_Up;"); 2445 Put_New_Line; 2446 Put_New_Line; 2447 S_Put 2448 (3, 2449 "procedure User_Tear_Down " 2450 & "(Gnattest_T : in out New_Test) is"); 2451 Put_New_Line; 2452 S_Put (6, "pragma Unreferenced (Gnattest_T);"); 2453 Put_New_Line; 2454 S_Put (3, "begin"); 2455 Put_New_Line; 2456 S_Put (6, "null;"); 2457 Put_New_Line; 2458 S_Put (3, "end User_Tear_Down;"); 2459 Put_New_Line; 2460 Put_New_Line; 2461 end if; 2462 2463 S_Put (0, "end " & Data_Unit_Name.all & ";"); 2464 Close_File; 2465 2466 end if; 2467 2468 TP_Map.SetUp_Name := new String'(Test_File_Name.all & ".adb"); 2469 TP_Map.TearDown_Name := new String'(Test_File_Name.all & ".adb"); 2470 TP_Map.SetUp_Line := 4; 2471 TP_Map.SetUp_Column := 4; 2472 2473 Tear_Down_Line_Add := 0; 2474 if Current_Type.No_Default_Discriminant then 2475 Tear_Down_Line_Add := Tear_Down_Line_Add + 1; 2476 end if; 2477 if Current_Type.Has_Argument_Father then 2478 Tear_Down_Line_Add := Tear_Down_Line_Add + 1; 2479 end if; 2480 TP_Map.TearDown_Line := 8 + Tear_Down_Line_Add; 2481 TP_Map.TearDown_Column := 4; 2482 2483 Free (Test_File_Name); 2484 2485 Unit_Name := new 2486 String'(Unit_Pref.all & 2487 "." & 2488 Current_Type.Main_Type_Text_Name.all & 2489 Test_Data_Unit_Name_Suff & 2490 "." & 2491 Current_Type.Main_Type_Text_Name.all & 2492 Test_Unit_Name_Suff); 2493 2494 Free (Unit_Pref); 2495 2496 Test_File_Name := new String'(Unit_To_File_Name (Unit_Name.all)); 2497 2498 ---------------------------------- 2499 -- Creating test package spec -- 2500 ---------------------------------- 2501 2502 Create 2503 (Output_Dir & Directory_Separator & Test_File_Name.all & ".ads"); 2504 2505 Put_Harness_Header; 2506 S_Put (0, GT_Marker_Begin); 2507 Put_New_Line; 2508 2509 S_Put (0, "with GNATtest_Generated;"); 2510 Put_New_Line; 2511 if Stub_Mode_ON then 2512 S_Put (0, "with AUnit.Test_Caller;"); 2513 Put_New_Line; 2514 end if; 2515 Put_New_Line; 2516 2517 if Current_Pack.Is_Generic then 2518 S_Put (0, "generic"); 2519 Put_New_Line; 2520 2521 declare 2522 GP : Generic_Package; 2523 begin 2524 GP.Name := new String'(Current_Pack.Name.all); -- ??? 2525 GP.Sloc := new String' 2526 (Base_Name (Data.Unit_File_Name.all) 2527 & ":" 2528 & Trim 2529 (Integer'Image 2530 (First_Line_Number (Current_Pack.Element)), 2531 Both) 2532 & ":" 2533 & Trim 2534 (Integer'Image 2535 (First_Column_Number (Current_Pack.Element)), 2536 Both)); 2537 Update_Generic_Packages (GP); 2538 end; 2539 end if; 2540 2541 S_Put (0, "package " & Unit_Name.all & " is"); 2542 Put_New_Line; 2543 Put_New_Line; 2544 2545 if Current_Pack.Data_Kind = Declaration_Data then 2546 S_Put 2547 (3, 2548 "type Test_" & 2549 Current_Type.Main_Type_Text_Name.all); 2550 if Current_Type.Main_Type_Abstract then 2551 S_Put (0, " is abstract new"); 2552 else 2553 S_Put (0, " is new"); 2554 end if; 2555 Put_New_Line; 2556 2557 if Data.Unit_Full_Name.all = Current_Type.Nesting.all then 2558 S_Put 2559 (5, 2560 "GNATtest_Generated.GNATtest_Standard." & 2561 Data.Unit_Full_Name.all & 2562 "." & 2563 Current_Type.Main_Type_Text_Name.all & 2564 Test_Data_Unit_Name_Suff & 2565 ".Test_" & 2566 Current_Type.Main_Type_Text_Name.all & 2567 " with null record;"); 2568 else 2569 S_Put 2570 (5, 2571 "GNATtest_Generated.GNATtest_Standard." & 2572 Data.Unit_Full_Name.all & 2573 "." & 2574 Test_Data_Unit_Name & 2575 "." & 2576 Test_Unit_Name & 2577 "." & 2578 Nesting_Difference 2579 (Data.Unit_Full_Name.all, 2580 Current_Type.Nesting.all) & 2581 "." & 2582 Current_Type.Main_Type_Text_Name.all & 2583 Test_Data_Unit_Name_Suff & 2584 ".Test_" & 2585 Current_Type.Main_Type_Text_Name.all & 2586 " with null record;"); 2587 end if; 2588 2589 else 2590 S_Put 2591 (3, 2592 "type Test_" 2593 & Current_Type.Main_Type_Text_Name.all 2594 & " is new GNATtest_Generated.GNATtest_Standard." 2595 & Data_Unit_Name.all & ".New_Test with null record;"); 2596 2597 Update_Generic_Packages 2598 (Current_Pack.Generic_Containing_Package.all); 2599 end if; 2600 2601 Put_New_Line; 2602 Put_New_Line; 2603 2604 -- Adding test routine declarations. 2605 if Current_Pack.Data_Kind = Declaration_Data then 2606 Subp_Cur := Data.Subp_List.First; 2607 loop 2608 exit when Subp_Cur = Subp_Data_List.No_Element; 2609 2610 if 2611 Subp_Data_List.Element (Subp_Cur).Corresp_Type = 2612 Current_Type.Type_Number 2613 then 2614 2615 if not Subp_Data_List.Element (Subp_Cur).Is_Abstract then 2616 S_Put 2617 (3, 2618 "procedure " 2619 & Subp_Data_List.Element 2620 (Subp_Cur).Subp_Mangle_Name.all 2621 & " (Gnattest_T : in out Test_" 2622 & Current_Type.Main_Type_Text_Name.all 2623 & ");"); 2624 Actual_Test := True; 2625 end if; 2626 2627 Put_New_Line; 2628 Print_Comment_Declaration 2629 (Subp_Data_List.Element (Subp_Cur), 3); 2630 Put_New_Line; 2631 end if; 2632 2633 Subp_Data_List.Next (Subp_Cur); 2634 end loop; 2635 end if; 2636 2637 if Stub_Mode_ON then 2638 S_Put 2639 (3, 2640 "package Caller is new AUnit.Test_Caller (Test_" 2641 & Current_Type.Main_Type_Text_Name.all 2642 & ");"); 2643 Put_New_Line; 2644 Put_New_Line; 2645 end if; 2646 2647 S_Put (0, "end " & Unit_Name.all & ";"); 2648 Put_New_Line; 2649 S_Put (0, GT_Marker_End); 2650 Put_New_Line; 2651 Close_File; 2652 2653 if not Current_Type.Main_Type_Abstract then 2654 TP_Map.TP_Name := new String'(Test_File_Name.all & ".ads"); 2655 TP_List.Append (TP_Map); 2656 end if; 2657 2658 ---------------------------------- 2659 -- Creating test package body -- 2660 ---------------------------------- 2661 2662 if Actual_Test then 2663 2664 if Generate_Separates then 2665 Create 2666 (Output_Dir 2667 & Directory_Separator 2668 & Test_File_Name.all 2669 & ".adb"); 2670 Put_Harness_Header; 2671 else 2672 Get_Subprograms_From_Package 2673 (Output_Dir 2674 & Directory_Separator 2675 & Test_File_Name.all 2676 & ".adb"); 2677 Create (Tmp_File_Name); 2678 Put_TP_Header (Test_Data_Package_Name.all); 2679 2680 -- gathering transition data 2681 if Transition then 2682 Subp_Cur := Data.Subp_List.First; 2683 loop 2684 exit when Subp_Cur = Subp_Data_List.No_Element; 2685 2686 Current_Subp := Subp_Data_List.Element (Subp_Cur); 2687 2688 if 2689 Current_Subp.Corresp_Type = Current_Type.Type_Number 2690 and then not Current_Subp.Is_Abstract 2691 then 2692 UH.Version := new String'("1"); 2693 UH.Hash := new String' 2694 (Subp_Data_List.Element 2695 (Subp_Cur).Subp_Hash_V1.all); 2696 if 2697 Subp_Data_List.Element (Subp_Cur).Has_TC_Info 2698 then 2699 UH.TC_Hash := new String' 2700 (Subp_Data_List.Element 2701 (Subp_Cur).TC_Info.TC_Hash.all); 2702 else 2703 UH.TC_Hash := new String'(""); 2704 end if; 2705 2706 Current_Subp := Subp_Data_List.Element (Subp_Cur); 2707 2708 Get_Subprogram_From_Separate 2709 (Output_Dir 2710 & Directory_Separator 2711 & Unit_To_File_Name 2712 (Unit_Name.all 2713 & "." 2714 & Test_Routine_Prefix 2715 & Current_Subp.Subp_Text_Name.all 2716 & "_" 2717 & Current_Subp.Subp_Hash_V1 2718 (Current_Subp.Subp_Hash_V1'First .. 2719 Current_Subp.Subp_Hash_V1'First + 5) 2720 & (if Current_Subp.Has_TC_Info 2721 then "_" & Current_Subp.TC_Info.TC_Hash 2722 (Current_Subp.TC_Info.TC_Hash'First .. 2723 Current_Subp.TC_Info.TC_Hash'First + 5) 2724 else "")) 2725 & ".adb", 2726 UH, 2727 Current_Subp); 2728 end if; 2729 Subp_Data_List.Next (Subp_Cur); 2730 end loop; 2731 end if; 2732 2733 -- gathering used short names 2734 Subp_Cur := Data.Subp_List.First; 2735 loop 2736 exit when Subp_Cur = Subp_Data_List.No_Element; 2737 2738 Current_Subp := Subp_Data_List.Element (Subp_Cur); 2739 2740 if 2741 Current_Subp.Corresp_Type = Current_Type.Type_Number 2742 and then not Current_Subp.Is_Abstract 2743 then 2744 UH.Version := new String'(Hash_Version); 2745 UH.Hash := new String' 2746 (Current_Subp.Subp_Full_Hash.all); 2747 if 2748 Current_Subp.Has_TC_Info 2749 then 2750 UH.TC_Hash := new String' 2751 (Sanitize_TC_Name (Current_Subp.TC_Info.Name.all)); 2752 else 2753 UH.TC_Hash := new String'(""); 2754 end if; 2755 2756 MD_Cur := Find (Markered_Data_Map, UH); 2757 2758 if MD_Cur /= Markered_Data_Maps.No_Element then 2759 MD := Markered_Data_Maps.Element (MD_Cur); 2760 if MD.Short_Name_Used then 2761 Short_Names_Used.Include 2762 (To_Lower (MD.Short_Name.all)); 2763 Shortnamed_Subps.Include 2764 (Current_Subp.Subp_Declaration); 2765 2766 Name_Numbers.Include 2767 (To_Lower (Current_Subp.Subp_Text_Name.all), 1); 2768 Elem_Numbers.Include 2769 (Current_Subp.Subp_Declaration, 1); 2770 end if; 2771 end if; 2772 2773 end if; 2774 2775 Subp_Data_List.Next (Subp_Cur); 2776 end loop; 2777 2778 -- updating hash v.1 to hash v.2 where possible 2779 Subp_Cur := Data.Subp_List.First; 2780 loop 2781 exit when Subp_Cur = Subp_Data_List.No_Element; 2782 2783 Current_Subp := Subp_Data_List.Element (Subp_Cur); 2784 2785 if 2786 Current_Subp.Corresp_Type = Current_Type.Type_Number 2787 and then not Current_Subp.Is_Abstract 2788 then 2789 UH.Version := new String'("1"); 2790 UH.Hash := new String' 2791 (Current_Subp.Subp_Hash_V1.all); 2792 if 2793 Current_Subp.Has_TC_Info 2794 then 2795 UH.TC_Hash := new String' 2796 (Current_Subp.TC_Info.TC_Hash.all); 2797 else 2798 UH.TC_Hash := new String'(""); 2799 end if; 2800 2801 MD_Cur := Find (Markered_Data_Map, UH); 2802 2803 if MD_Cur /= Markered_Data_Maps.No_Element then 2804 MD := Markered_Data_Maps.Element (MD_Cur); 2805 2806 Markered_Data_Map.Delete (MD_Cur); 2807 Free (UH.Hash); 2808 UH.Hash := new String' 2809 (Current_Subp.Subp_Hash_V2_1.all); 2810 Free (UH.Version); 2811 UH.Version := new String'("2"); 2812 2813 Markered_Data_Map.Include (UH, MD); 2814 end if; 2815 2816 end if; 2817 2818 Subp_Data_List.Next (Subp_Cur); 2819 end loop; 2820 2821 -- updating hash v.2 to hash v.2.1 where possible 2822 Subp_Cur := Data.Subp_List.First; 2823 loop 2824 exit when Subp_Cur = Subp_Data_List.No_Element; 2825 2826 Current_Subp := Subp_Data_List.Element (Subp_Cur); 2827 2828 if 2829 Current_Subp.Corresp_Type = Current_Type.Type_Number 2830 and then not Current_Subp.Is_Abstract 2831 then 2832 UH.Version := new String'("2"); 2833 UH.Hash := new String' 2834 (Current_Subp.Subp_Hash_V2_1 .all); 2835 2836 if Current_Subp.Has_TC_Info then 2837 UH.TC_Hash := new String' 2838 (Current_Subp.TC_Info.TC_Hash.all); 2839 else 2840 UH.TC_Hash := new String'(""); 2841 end if; 2842 2843 MD_Cur := Find (Markered_Data_Map, UH); 2844 2845 if MD_Cur /= Markered_Data_Maps.No_Element then 2846 MD := Markered_Data_Maps.Element (MD_Cur); 2847 2848 Markered_Data_Map.Delete (MD_Cur); 2849 Free (UH.Version); 2850 UH.Version := new String'("2.1"); 2851 if UH.TC_Hash.all /= "" then 2852 Free (UH.TC_Hash); 2853 UH.TC_Hash := new String' 2854 (Sanitize_TC_Name 2855 (Current_Subp.TC_Info.Name.all)); 2856 end if; 2857 2858 Markered_Data_Map.Include (UH, MD); 2859 end if; 2860 2861 end if; 2862 2863 Subp_Data_List.Next (Subp_Cur); 2864 end loop; 2865 2866 -- updating hash v.2.1 to hash v.2.2 2867 -- and looking for new short names 2868 Subp_Cur := Data.Subp_List.First; 2869 loop 2870 exit when Subp_Cur = Subp_Data_List.No_Element; 2871 2872 Current_Subp := Subp_Data_List.Element (Subp_Cur); 2873 2874 if 2875 Current_Subp.Corresp_Type = Current_Type.Type_Number 2876 and then not Current_Subp.Is_Abstract 2877 then 2878 UH.Version := new String'("2.1"); 2879 UH.Hash := new String' 2880 (Current_Subp.Subp_Hash_V2_1 .all); 2881 2882 if Current_Subp.Has_TC_Info then 2883 UH.TC_Hash := new String' 2884 (Sanitize_TC_Name 2885 (Current_Subp.TC_Info.Name.all)); 2886 else 2887 UH.TC_Hash := new String'(""); 2888 end if; 2889 2890 MD_Cur := Find (Markered_Data_Map, UH); 2891 2892 if MD_Cur /= Markered_Data_Maps.No_Element then 2893 MD := Markered_Data_Maps.Element (MD_Cur); 2894 2895 if not 2896 Short_Names_Used.Contains (MD.Short_Name.all) 2897 or else Shortnamed_Subps.Contains 2898 (Current_Subp.Subp_Declaration) 2899 then 2900 Short_Names_Used.Include (MD.Short_Name.all); 2901 Shortnamed_Subps.Include 2902 (Current_Subp.Subp_Declaration); 2903 2904 Name_Numbers.Include 2905 (To_Lower (Current_Subp.Subp_Text_Name.all), 1); 2906 Elem_Numbers.Include 2907 (Current_Subp.Subp_Declaration, 1); 2908 2909 MD.Short_Name_Used := True; 2910 end if; 2911 2912 Markered_Data_Map.Delete (MD_Cur); 2913 Free (UH.Hash); 2914 UH.Hash := new String' 2915 (Current_Subp.Subp_Full_Hash.all); 2916 Free (UH.Version); 2917 UH.Version := new String'(Hash_Version); 2918 Markered_Data_Map.Include (UH, MD); 2919 end if; 2920 2921 end if; 2922 2923 Subp_Data_List.Next (Subp_Cur); 2924 end loop; 2925 2926 -- creating markered_data and deciding on new short names 2927 Subp_Cur := Data.Subp_List.First; 2928 loop 2929 exit when Subp_Cur = Subp_Data_List.No_Element; 2930 2931 Current_Subp := Subp_Data_List.Element (Subp_Cur); 2932 2933 if 2934 Current_Subp.Corresp_Type = Current_Type.Type_Number 2935 and then not Current_Subp.Is_Abstract 2936 then 2937 UH.Version := new String'(Hash_Version); 2938 UH.Hash := new String' 2939 (Current_Subp.Subp_Full_Hash.all); 2940 if Current_Subp.Has_TC_Info then 2941 UH.TC_Hash := new String' 2942 (Sanitize_TC_Name (Current_Subp.TC_Info.Name.all)); 2943 else 2944 UH.TC_Hash := new String'(""); 2945 end if; 2946 2947 MD_Cur := Find (Markered_Data_Map, UH); 2948 2949 if MD_Cur = Markered_Data_Maps.No_Element then 2950 2951 MD.Commented_Out := False; 2952 MD.Short_Name_Used := False; 2953 MD.Short_Name := new String' 2954 (To_Lower (Current_Subp.Subp_Text_Name.all)); 2955 MD.TR_Text.Clear; 2956 2957 if 2958 not Short_Names_Used.Contains 2959 (To_Lower (Current_Subp.Subp_Text_Name.all)) 2960 or else Shortnamed_Subps.Contains 2961 (Current_Subp.Subp_Declaration) 2962 then 2963 -- Short name is free, we can use it 2964 MD.Short_Name_Used := True; 2965 Short_Names_Used.Include 2966 (To_Lower (Current_Subp.Subp_Text_Name.all)); 2967 Shortnamed_Subps.Include 2968 (Current_Subp.Subp_Declaration); 2969 2970 Name_Numbers.Include 2971 (To_Lower (Current_Subp.Subp_Text_Name.all), 1); 2972 Elem_Numbers.Include 2973 (Current_Subp.Subp_Declaration, 1); 2974 2975 -- Looking for a dangling test with same short 2976 -- name but different hash. 2977 MD_Cur := Find_Same_Short_Name 2978 (Markered_Data_Map, 2979 Current_Subp.Subp_Text_Name.all); 2980 2981 if MD_Cur /= Markered_Data_Maps.No_Element then 2982 -- Using corresponding dangling test 2983 2984 MD.TR_Text.Clear; 2985 MD.TR_Text := 2986 Markered_Data_Maps.Element (MD_Cur).TR_Text; 2987 2988 -- also need to copy Commented_Out since 2989 -- the test can be dangling for a long time 2990 -- or just become dangling 2991 MD.Commented_Out := 2992 Markered_Data_Maps.Element 2993 (MD_Cur).Commented_Out; 2994 2995 Markered_Data_Map.Delete (MD_Cur); 2996 MD.Issue_Warning := True; 2997 end if; 2998 2999 end if; 3000 3001 Markered_Data_Map.Insert (UH, MD); 3002 3003 end if; 3004 3005 end if; 3006 3007 Subp_Data_List.Next (Subp_Cur); 3008 end loop; 3009 3010 -- setting overloading numbers; 3011 Subp_Cur := Data.Subp_List.First; 3012 loop 3013 exit when Subp_Cur = Subp_Data_List.No_Element; 3014 3015 Current_Subp := Subp_Data_List.Element (Subp_Cur); 3016 3017 if 3018 Current_Subp.Corresp_Type = Current_Type.Type_Number 3019 and then not Current_Subp.Is_Abstract 3020 then 3021 3022 if 3023 Name_Numbers.Find 3024 (To_Lower (Current_Subp.Subp_Text_Name.all)) = 3025 Name_Frequency.No_Element 3026 then 3027 3028 Name_Numbers.Include 3029 (To_Lower (Current_Subp.Subp_Text_Name.all), 1); 3030 Elem_Numbers.Include 3031 (Current_Subp.Subp_Declaration, 1); 3032 3033 else 3034 if 3035 Elem_Numbers.Find 3036 (Current_Subp.Subp_Declaration) = 3037 Elem_Number_Maps.No_Element 3038 then 3039 3040 declare 3041 X : constant Natural := 3042 Name_Numbers.Element 3043 (To_Lower 3044 (Current_Subp.Subp_Text_Name.all)); 3045 begin 3046 Name_Numbers.Replace 3047 (To_Lower (Current_Subp.Subp_Text_Name.all), 3048 X + 1); 3049 Elem_Numbers.Include 3050 (Current_Subp.Subp_Declaration, X + 1); 3051 end; 3052 3053 end if; 3054 end if; 3055 3056 end if; 3057 3058 Subp_Data_List.Next (Subp_Cur); 3059 end loop; 3060 Name_Numbers.Clear; 3061 3062 end if; 3063 3064 Reset_Line_Counter; 3065 3066 S_Put (0, "with AUnit.Assertions; use AUnit.Assertions;"); 3067 New_Line_Count; 3068 S_Put (0, "with System.Assertions;"); 3069 New_Line_Count; 3070 if Stub_Mode_ON then 3071 declare 3072 S_Cur : Asis_Element_List.Cursor := Data.Units_To_Stub.First; 3073 Tmp : String_Access; 3074 begin 3075 while S_Cur /= Asis_Element_List.No_Element loop 3076 Tmp := new String' 3077 (To_String 3078 (Text_Name 3079 (Enclosing_Compilation_Unit 3080 (Asis_Element_List.Element (S_Cur))))); 3081 3082 if 3083 Source_Stubbed (Tmp.all) and then 3084 not Excluded_Test_Data_Files.Contains 3085 (Base_Name (Get_Source_Stub_Data_Spec (Tmp.all))) 3086 then 3087 S_Put 3088 (0, 3089 "with " 3090 & To_String 3091 (Defining_Name_Image 3092 (First_Name 3093 (Asis_Element_List.Element (S_Cur)))) 3094 & "." 3095 & Stub_Data_Unit_Name 3096 & "; use " 3097 & To_String 3098 (Defining_Name_Image 3099 (First_Name 3100 (Asis_Element_List.Element (S_Cur)))) 3101 & "." 3102 & Stub_Data_Unit_Name 3103 & ";"); 3104 Put_New_Line; 3105 end if; 3106 3107 Free (Tmp); 3108 3109 Next (S_Cur); 3110 end loop; 3111 end; 3112 end if; 3113 New_Line_Count; 3114 3115 S_Put (0, "package body " & Unit_Name.all & " is"); 3116 New_Line_Count; 3117 New_Line_Count; 3118 3119 -- Adding test routine body stubs. 3120 Subp_Cur := Data.Subp_List.First; 3121 loop 3122 exit when Subp_Cur = Subp_Data_List.No_Element; 3123 3124 if 3125 Subp_Data_List.Element (Subp_Cur).Corresp_Type = 3126 Current_Type.Type_Number 3127 then 3128 if not Subp_Data_List.Element (Subp_Cur).Is_Abstract then 3129 3130 Current_Subp := Subp_Data_List.Element (Subp_Cur); 3131 3132 if Subp_Data_List.Element (Subp_Cur).Has_TC_Info then 3133 3134 case 3135 Declaration_Kind 3136 (Subp_Data_List.Element 3137 (Subp_Cur).Subp_Declaration) 3138 is 3139 3140 when A_Function_Declaration | 3141 An_Expression_Function_Declaration => 3142 Generate_Function_Wrapper 3143 (Subp_Data_List.Element (Subp_Cur)); 3144 3145 when A_Procedure_Declaration => 3146 Generate_Procedure_Wrapper 3147 (Subp_Data_List.Element (Subp_Cur)); 3148 3149 when others => 3150 null; 3151 3152 end case; 3153 3154 end if; 3155 3156 if Generate_Separates then 3157 S_Put 3158 (3, 3159 "procedure " & 3160 Subp_Data_List.Element 3161 (Subp_Cur).Subp_Mangle_Name.all & 3162 " (Gnattest_T : in out Test_" & 3163 Current_Type.Main_Type_Text_Name.all & 3164 ") is separate;"); 3165 3166 Put_New_Line; 3167 Print_Comment_Declaration 3168 (Subp_Data_List.Element (Subp_Cur), 3); 3169 Put_New_Line; 3170 3171 else 3172 3173 Test_Info.Replace 3174 (Data.Unit_File_Name.all, 3175 Test_Info.Element (Data.Unit_File_Name.all) + 1); 3176 3177 All_Tests_Counter := All_Tests_Counter + 1; 3178 3179 UH.Version := new String'(Hash_Version); 3180 UH.Hash := new String' 3181 (Subp_Data_List.Element 3182 (Subp_Cur).Subp_Full_Hash.all); 3183 if Subp_Data_List.Element (Subp_Cur).Has_TC_Info then 3184 UH.TC_Hash := new String' 3185 (Sanitize_TC_Name 3186 (Subp_Data_List.Element 3187 (Subp_Cur).TC_Info.Name.all)); 3188 else 3189 UH.TC_Hash := new String'(""); 3190 end if; 3191 3192 MD_Cur := Find (Markered_Data_Map, UH); 3193 MD := Markered_Data_Maps.Element (MD_Cur); 3194 3195 Put_Opening_Comment_Section 3196 (Subp_Data_List.Element (Subp_Cur), 3197 Elem_Numbers.Element 3198 (Current_Subp.Subp_Declaration), 3199 Use_Short_Name => MD.Short_Name_Used, 3200 Type_Name => Current_Type.Main_Type_Text_Name.all); 3201 3202 if Is_Unimplemented_Test (MD.TR_Text) then 3203 TR_SLOC_Buffer.Append 3204 ((new String'(Test_File_Name.all & ".ads"), 3205 new String'(Test_File_Name.all & ".adb"), 3206 null, 3207 Subp_Data_List.Element (Subp_Cur), 3208 New_Line_Counter)); 3209 else 3210 TR_SLOC_Buffer.Append 3211 ((new String'(Test_File_Name.all & ".ads"), 3212 new String'(Test_File_Name.all & ".adb"), 3213 new String'("modified"), 3214 Subp_Data_List.Element (Subp_Cur), 3215 New_Line_Counter)); 3216 end if; 3217 3218 if MD.TR_Text.Is_Empty then 3219 3220 if Stub_Mode_ON then 3221 Gather_Direct_Callees 3222 (Current_Subp.Subp_Declaration, 3223 Setters_Set); 3224 end if; 3225 3226 New_Tests_Counter := New_Tests_Counter + 1; 3227 New_Line_Count; 3228 S_Put (6, "pragma Unreferenced (Gnattest_T);"); 3229 New_Line_Count; 3230 New_Line_Count; 3231 S_Put (3, "begin"); 3232 New_Line_Count; 3233 New_Line_Count; 3234 if not Setters_Set.Is_Empty then 3235 Set_Cur := Setters_Set.First; 3236 while Set_Cur /= String_Set.No_Element loop 3237 S_Put 3238 (3, 3239 "-- " 3240 & String_Set.Element (Set_Cur) 3241 & "( );"); 3242 New_Line_Count; 3243 Next (Set_Cur); 3244 end loop; 3245 New_Line_Count; 3246 Setters_Set.Clear; 3247 end if; 3248 S_Put (6, "AUnit.Assertions.Assert"); 3249 New_Line_Count; 3250 S_Put 3251 (8, "(Gnattest_Generated.Default_Assert_Value,"); 3252 New_Line_Count; 3253 S_Put (9, """Test not implemented."");"); 3254 New_Line_Count; 3255 New_Line_Count; 3256 else 3257 3258 if MD.Issue_Warning then 3259 Report_Std 3260 (Base_Name (Data.Unit_File_Name.all) 3261 & ":" 3262 & Trim 3263 (Integer'Image (First_Line_Number 3264 (Current_Subp.Subp_Declaration)), 3265 Both) 3266 & ":" 3267 & Trim 3268 (Integer'Image (First_Column_Number 3269 (Current_Subp.Subp_Declaration)), 3270 Both) 3271 & ": warning: test for " 3272 & MD.Short_Name.all 3273 & " at " 3274 & Unit_Name.all 3275 & ":" 3276 & Trim 3277 (Integer'Image (New_Line_Counter), 3278 Both) 3279 & " might be out of date (" 3280 & MD.Short_Name.all 3281 & " has been changed)"); 3282 end if; 3283 3284 for I in 3285 MD.TR_Text.First_Index .. MD.TR_Text.Last_Index 3286 loop 3287 if MD.Commented_Out then 3288 S_Put 3289 (0, 3290 Uncomment_Line (MD.TR_Text.Element (I))); 3291 else 3292 S_Put (0, MD.TR_Text.Element (I)); 3293 end if; 3294 New_Line_Count; 3295 end loop; 3296 end if; 3297 3298 Markered_Data_Map.Delete (MD_Cur); 3299 3300 Put_Closing_Comment_Section 3301 (Subp_Data_List.Element (Subp_Cur), 3302 Elem_Numbers.Element 3303 (Current_Subp.Subp_Declaration), 3304 Use_Short_Name => MD.Short_Name_Used); 3305 New_Line_Count; 3306 3307 end if; 3308 3309 end if; 3310 end if; 3311 3312 Subp_Data_List.Next (Subp_Cur); 3313 end loop; 3314 3315 -- printing dangling tests 3316 3317 if not Markered_Data_Map.Is_Empty then 3318 Report_Std 3319 (" warning: " 3320 & Unit_Name.all 3321 & " has dangling test(s)"); 3322 end if; 3323 3324 MD_Cur := Markered_Data_Map.First; 3325 loop 3326 exit when MD_Cur = Markered_Data_Maps.No_Element; 3327 3328 MD := Markered_Data_Maps.Element (MD_Cur); 3329 3330 declare 3331 Stub : Subp_Info; 3332 begin 3333 3334 Stub.Subp_Full_Hash := new String' 3335 (Markered_Data_Maps.Key (MD_Cur).Hash.all); 3336 3337 Stub.Subp_Text_Name := new String' 3338 (Markered_Data_Maps.Element (MD_Cur).Short_Name.all); 3339 3340 Stub.Subp_Mangle_Name := new String' 3341 (Test_Routine_Prefix 3342 & Stub.Subp_Text_Name.all 3343 & "_" 3344 & Stub.Subp_Full_Hash 3345 (Stub.Subp_Full_Hash'First .. 3346 Stub.Subp_Full_Hash'First + 5)); 3347 3348 if Markered_Data_Maps.Key (MD_Cur).TC_Hash.all = "" then 3349 Stub.Has_TC_Info := False; 3350 else 3351 Stub.Has_TC_Info := True; 3352 Stub.TC_Info.TC_Hash := new String' 3353 (Markered_Data_Maps.Key (MD_Cur).TC_Hash.all); 3354 end if; 3355 3356 Put_Opening_Comment_Section 3357 (Stub, 0, True, False, 3358 Current_Type.Main_Type_Text_Name.all); 3359 3360 Add_DT 3361 (TP_List, 3362 Test_File_Name.all & ".ads", 3363 Test_File_Name.all & ".adb", 3364 New_Line_Counter, 3365 1); 3366 3367 for I in 3368 MD.TR_Text.First_Index .. MD.TR_Text.Last_Index 3369 loop 3370 if MD.Commented_Out then 3371 S_Put (0, MD.TR_Text.Element (I)); 3372 else 3373 S_Put (0, "-- " & MD.TR_Text.Element (I)); 3374 end if; 3375 New_Line_Count; 3376 end loop; 3377 3378 Put_Closing_Comment_Section 3379 (Stub, 3380 Elem_Numbers.Element 3381 (Current_Subp.Subp_Declaration), 3382 True, 3383 False); 3384 New_Line_Count; 3385 end; 3386 3387 Markered_Data_Maps.Next (MD_Cur); 3388 end loop; 3389 3390 S_Put (0, "end " & Unit_Name.all & ";"); 3391 3392 Close_File; 3393 3394 Add_Buffered_TR_Slocs 3395 (TP_List, 3396 Format_Time 3397 (File_Time_Stamp 3398 (Tmp_File_Name))); 3399 3400 if not Generate_Separates then 3401 declare 3402 Old_Package : constant String := 3403 Output_Dir & Directory_Separator 3404 & Test_File_Name.all & ".adb"; 3405 Success : Boolean; 3406 begin 3407 if Is_Regular_File (Old_Package) then 3408 Delete_File (Old_Package, Success); 3409 if not Success then 3410 Report_Err ("cannot delete " & Old_Package); 3411 raise Fatal_Error; 3412 end if; 3413 end if; 3414 Copy_File (Tmp_File_Name, Old_Package, Success); 3415 if not Success then 3416 Report_Err ("cannot copy tmp test package to " 3417 & Old_Package); 3418 raise Fatal_Error; 3419 end if; 3420 Delete_File (Tmp_File_Name, Success); 3421 if not Success then 3422 Report_Err ("cannot delete tmp test package"); 3423 raise Fatal_Error; 3424 end if; 3425 end; 3426 end if; 3427 3428 Markered_Data_Map.Clear; 3429 end if; 3430 3431 Short_Names_Used.Clear; 3432 Shortnamed_Subps.Clear; 3433 Elem_Numbers.Clear; 3434 3435 end loop; 3436 3437 -- Simple case 3438 3439 if Data.Has_Simple_Case then 3440 3441 Pack_Cur := Data.Package_Data_List.First; 3442 loop 3443 exit when Pack_Cur = Package_Info_List.No_Element; 3444 3445 Current_Pack := Package_Info_List.Element (Pack_Cur); 3446 3447 Subp_Cur := Data.Subp_List.First; 3448 loop 3449 exit when Subp_Cur = Subp_Data_List.No_Element; 3450 3451 Current_Subp := Subp_Data_List.Element (Subp_Cur); 3452 if Current_Subp.Nesting.all = Current_Pack.Name.all then 3453 Subp_List.Append (Current_Subp); 3454 end if; 3455 3456 Subp_Data_List.Next (Subp_Cur); 3457 end loop; 3458 3459 if Current_Pack.Name.all = Data.Unit_Full_Name.all then 3460 Data_Unit_Name := new String' 3461 (Current_Pack.Name.all & "." & Test_Data_Unit_Name); 3462 else 3463 Data_Unit_Name := new String' 3464 (Data.Unit_Full_Name.all & "." & 3465 Test_Data_Unit_Name & "." & 3466 Test_Unit_Name & "." & 3467 Nesting_Difference 3468 (Current_Pack.Name.all, 3469 Data.Unit_Full_Name.all) & 3470 "." & Test_Data_Unit_Name); 3471 end if; 3472 3473 Test_File_Name := new String' 3474 (Unit_To_File_Name (Data_Unit_Name.all)); 3475 3476 -- saving test data package name for further reference 3477 Test_Data_Package_Name := new String'(Data_Unit_Name.all); 3478 3479 -- Generating simple test data package spec 3480 if not Is_Regular_File 3481 (Output_Dir & Directory_Separator & Test_File_Name.all & ".ads") 3482 then 3483 Create 3484 (Output_Dir & Directory_Separator & 3485 Test_File_Name.all & ".ads"); 3486 3487 Put_Test_Data_Header; 3488 3489 if Current_Pack.Data_Kind = Instantiation then 3490 S_Put 3491 (0, 3492 "with " 3493 & Current_Pack.Generic_Containing_Package.all 3494 & "." 3495 & Test_Data_Unit_Name 3496 & ";"); 3497 Put_New_Line; 3498 S_Put 3499 (0, 3500 "with " 3501 & Current_Pack.Generic_Containing_Package.all 3502 & "." 3503 & Test_Data_Unit_Name 3504 & "." 3505 & Test_Unit_Name 3506 & ";"); 3507 else 3508 S_Put (0, "with AUnit.Test_Fixtures;"); 3509 end if; 3510 Put_New_Line; 3511 Put_New_Line; 3512 if Current_Pack.Is_Generic then 3513 S_Put (0, "generic"); 3514 Put_New_Line; 3515 S_Put 3516 (3, 3517 "type GNATtest_Test_Type is new " 3518 & "AUnit.Test_Fixtures.Test_Fixture"); 3519 Put_New_Line; 3520 S_Put (5, "with private;"); 3521 Put_New_Line; 3522 end if; 3523 S_Put (0, "package " & Data_Unit_Name.all & " is"); 3524 Put_New_Line; 3525 Put_New_Line; 3526 S_Put (0, GT_Marker_Begin); 3527 Put_New_Line; 3528 S_Put 3529 (3, 3530 "type Test is new AUnit.Test_Fixtures.Test_Fixture"); 3531 Put_New_Line; 3532 S_Put (0, GT_Marker_End); 3533 Put_New_Line; 3534 S_Put (3, "with null record;"); 3535 Put_New_Line; 3536 Put_New_Line; 3537 S_Put (3, "procedure Set_Up (Gnattest_T : in out Test);"); 3538 Put_New_Line; 3539 S_Put (3, "procedure Tear_Down (Gnattest_T : in out Test);"); 3540 Put_New_Line; 3541 Put_New_Line; 3542 3543 if Current_Pack.Data_Kind = Instantiation then 3544 S_Put (0, GT_Marker_Begin); 3545 Put_New_Line; 3546 S_Put 3547 (3, 3548 "package Gnattest_Data_Inst is new " 3549 & "GNATtest_Generated.GNATtest_Standard." 3550 & Current_Pack.Name.all 3551 & "." 3552 & Test_Data_Unit_Name 3553 & " (Test);"); 3554 Put_New_Line; 3555 S_Put 3556 (3, 3557 "package Gnattest_Tests_Inst is new Gnattest_Data_Inst." 3558 & Test_Unit_Name 3559 & ";"); 3560 Put_New_Line; 3561 Put_New_Line; 3562 S_Put 3563 (3, 3564 "type New_Test is new Gnattest_Tests_Inst.Test" 3565 & " with null record;"); 3566 Put_New_Line; 3567 S_Put (0, GT_Marker_End); 3568 Put_New_Line; 3569 Put_New_Line; 3570 S_Put 3571 (3, 3572 "procedure User_Set_Up (Gnattest_T : in out New_Test);"); 3573 Put_New_Line; 3574 S_Put 3575 (3, 3576 "procedure User_Tear_Down " 3577 & "(Gnattest_T : in out New_Test);"); 3578 Put_New_Line; 3579 Put_New_Line; 3580 end if; 3581 3582 if Current_Pack.Is_Generic then 3583 S_Put 3584 (3, 3585 "procedure User_Set_Up (Gnattest_T : in out Test)" 3586 & "is null;"); 3587 Put_New_Line; 3588 S_Put 3589 (3, 3590 "procedure User_Tear_Down (Gnattest_T : in out Test)" 3591 & "is null;"); 3592 Put_New_Line; 3593 Put_New_Line; 3594 end if; 3595 3596 S_Put (0, "end " & Data_Unit_Name.all & ";"); 3597 3598 Close_File; 3599 end if; 3600 3601 if not Is_Regular_File 3602 (Output_Dir & Directory_Separator & Test_File_Name.all & ".adb") 3603 then 3604 Create 3605 (Output_Dir & Directory_Separator & 3606 Test_File_Name.all & ".adb"); 3607 3608 Put_Test_Data_Header; 3609 3610 S_Put (0, "package body " & Data_Unit_Name.all & " is"); 3611 Put_New_Line; 3612 Put_New_Line; 3613 if Current_Pack.Data_Kind = Declaration_Data then 3614 S_Put (3, "procedure Set_Up (Gnattest_T : in out Test) is"); 3615 Put_New_Line; 3616 if Current_Pack.Is_Generic then 3617 S_Put 3618 (6, "X : Test'Class renames Test'Class (Gnattest_T);"); 3619 Put_New_Line; 3620 S_Put (3, "begin"); 3621 Put_New_Line; 3622 S_Put (6, "X.User_Set_Up;"); 3623 else 3624 S_Put (6, "pragma Unreferenced (Gnattest_T);"); 3625 Put_New_Line; 3626 S_Put (3, "begin"); 3627 Put_New_Line; 3628 S_Put (6, "null;"); 3629 end if; 3630 Put_New_Line; 3631 S_Put (3, "end Set_Up;"); 3632 Put_New_Line; 3633 Put_New_Line; 3634 S_Put 3635 (3, "procedure Tear_Down (Gnattest_T : in out Test) is"); 3636 Put_New_Line; 3637 if Current_Pack.Is_Generic then 3638 S_Put 3639 (6, "X : Test'Class renames Test'Class (Gnattest_T);"); 3640 Put_New_Line; 3641 S_Put (3, "begin"); 3642 Put_New_Line; 3643 S_Put (6, "X.User_Tear_Down;"); 3644 else 3645 S_Put (6, "pragma Unreferenced (Gnattest_T);"); 3646 Put_New_Line; 3647 S_Put (3, "begin"); 3648 Put_New_Line; 3649 S_Put (6, "null;"); 3650 end if; 3651 Put_New_Line; 3652 S_Put (3, "end Tear_Down;"); 3653 else 3654 S_Put 3655 (3, 3656 "procedure Set_Up " 3657 & "(Gnattest_T : in out Test) is"); 3658 Put_New_Line; 3659 S_Put (6, "pragma Unreferenced (Gnattest_T);"); 3660 Put_New_Line; 3661 S_Put (3, "begin"); 3662 Put_New_Line; 3663 S_Put (6, "null;"); 3664 Put_New_Line; 3665 S_Put (3, "end Set_Up;"); 3666 Put_New_Line; 3667 Put_New_Line; 3668 S_Put 3669 (3, 3670 "procedure Tear_Down " 3671 & "(Gnattest_T : in out Test) is"); 3672 Put_New_Line; 3673 S_Put (6, "pragma Unreferenced (Gnattest_T);"); 3674 Put_New_Line; 3675 S_Put (3, "begin"); 3676 Put_New_Line; 3677 S_Put (6, "null;"); 3678 Put_New_Line; 3679 S_Put (3, "end Tear_Down;"); 3680 Put_New_Line; 3681 Put_New_Line; 3682 S_Put 3683 (3, 3684 "procedure User_Set_Up " 3685 & "(Gnattest_T : in out New_Test) is"); 3686 Put_New_Line; 3687 S_Put (6, "pragma Unreferenced (Gnattest_T);"); 3688 Put_New_Line; 3689 S_Put (3, "begin"); 3690 Put_New_Line; 3691 S_Put (6, "null;"); 3692 Put_New_Line; 3693 S_Put (3, "end User_Set_Up;"); 3694 Put_New_Line; 3695 Put_New_Line; 3696 S_Put 3697 (3, 3698 "procedure User_Tear_Down " 3699 & "(Gnattest_T : in out New_Test) is"); 3700 Put_New_Line; 3701 S_Put (6, "pragma Unreferenced (Gnattest_T);"); 3702 Put_New_Line; 3703 S_Put (3, "begin"); 3704 Put_New_Line; 3705 S_Put (6, "null;"); 3706 Put_New_Line; 3707 S_Put (3, "end User_Tear_Down;"); 3708 end if; 3709 Put_New_Line; 3710 Put_New_Line; 3711 S_Put (0, "end " & Data_Unit_Name.all & ";"); 3712 3713 Close_File; 3714 end if; 3715 3716 TP_Map.SetUp_Name := new String'(Test_File_Name.all & ".adb"); 3717 TP_Map.TearDown_Name := new String'(Test_File_Name.all & ".adb"); 3718 TP_Map.SetUp_Line := 3; 3719 TP_Map.SetUp_Column := 4; 3720 TP_Map.TearDown_Line := 9; 3721 TP_Map.TearDown_Column := 4; 3722 3723 Free (Test_File_Name); 3724 3725 if Current_Pack.Name.all = Data.Unit_Full_Name.all then 3726 Unit_Name := new String' 3727 (Current_Pack.Name.all & "." & 3728 Test_Data_Unit_Name & "." & 3729 Test_Unit_Name); 3730 else 3731 Unit_Name := new String' 3732 (Data.Unit_Full_Name.all & "." & 3733 Test_Data_Unit_Name & "." & 3734 Test_Unit_Name & "." & 3735 Nesting_Difference 3736 (Current_Pack.Name.all, 3737 Data.Unit_Full_Name.all) & 3738 "." & Test_Data_Unit_Name & "." & Test_Unit_Name); 3739 end if; 3740 3741 Test_File_Name := new String'(Unit_To_File_Name (Unit_Name.all)); 3742 3743 Actual_Test := False; 3744 3745 -- Generating simple test package spec. 3746 Create 3747 (Output_Dir & Directory_Separator & Test_File_Name.all & ".ads"); 3748 3749 Put_Harness_Header; 3750 S_Put (0, GT_Marker_Begin); 3751 Put_New_Line; 3752 3753 S_Put (0, "with Gnattest_Generated;"); 3754 Put_New_Line; 3755 if Stub_Mode_ON then 3756 S_Put (0, "with AUnit.Test_Caller;"); 3757 Put_New_Line; 3758 end if; 3759 Put_New_Line; 3760 if Current_Pack.Is_Generic then 3761 S_Put (0, "generic"); 3762 Put_New_Line; 3763 3764 declare 3765 GP : Generic_Package; 3766 begin 3767 GP.Name := new String'(Current_Pack.Name.all); -- ??? 3768 GP.Sloc := new String' 3769 (Base_Name (Data.Unit_File_Name.all) 3770 & ":" 3771 & Trim 3772 (Integer'Image 3773 (First_Line_Number (Current_Pack.Element)), 3774 Both) 3775 & ":" 3776 & Trim 3777 (Integer'Image 3778 (First_Column_Number (Current_Pack.Element)), 3779 Both)); 3780 Update_Generic_Packages (GP); 3781 end; 3782 end if; 3783 3784 S_Put (0, "package " & Unit_Name.all & " is"); 3785 Put_New_Line; 3786 Put_New_Line; 3787 3788 -- Declaring simple test type. 3789 if Current_Pack.Data_Kind = Declaration_Data then 3790 S_Put 3791 (3, 3792 "type Test is new GNATtest_Generated.GNATtest_Standard." & 3793 Data_Unit_Name.all & ".Test"); 3794 3795 else 3796 S_Put 3797 (3, 3798 "type Test is new GNATtest_Generated.GNATtest_Standard." & 3799 Data_Unit_Name.all & ".New_Test"); 3800 3801 Update_Generic_Packages 3802 (Current_Pack.Generic_Containing_Package.all); 3803 end if; 3804 Put_New_Line; 3805 S_Put (3, "with null record;"); 3806 Put_New_Line; 3807 Put_New_Line; 3808 3809 -- Adding test routine declarations. 3810 3811 if Current_Pack.Data_Kind = Declaration_Data then 3812 Subp_Cur := Subp_List.First; 3813 loop 3814 exit when Subp_Cur = Subp_Data_List.No_Element; 3815 3816 if Subp_Data_List.Element (Subp_Cur).Corresp_Type = 0 then 3817 3818 S_Put 3819 (3, 3820 "procedure " 3821 & Subp_Data_List.Element 3822 (Subp_Cur).Subp_Mangle_Name.all 3823 & " (Gnattest_T : in out Test);"); 3824 3825 Put_New_Line; 3826 Print_Comment_Declaration 3827 (Subp_Data_List.Element (Subp_Cur), 3828 3); 3829 Put_New_Line; 3830 3831 Actual_Test := True; 3832 end if; 3833 3834 Subp_Data_List.Next (Subp_Cur); 3835 end loop; 3836 end if; 3837 3838 if Stub_Mode_ON then 3839 S_Put (3, "package Caller is new AUnit.Test_Caller (Test);"); 3840 Put_New_Line; 3841 Put_New_Line; 3842 end if; 3843 3844 S_Put (0, "end " & Unit_Name.all & ";"); 3845 3846 Put_New_Line; 3847 S_Put (0, GT_Marker_End); 3848 Put_New_Line; 3849 3850 Close_File; 3851 3852 TP_Map.TP_Name := new String'(Test_File_Name.all & ".ads"); 3853 TP_List.Append (TP_Map); 3854 3855 -- Generating simple test package body 3856 if Actual_Test then 3857 3858 if Generate_Separates then 3859 Create 3860 (Output_Dir 3861 & Directory_Separator 3862 & Test_File_Name.all 3863 & ".adb"); 3864 Put_Harness_Header; 3865 else 3866 Get_Subprograms_From_Package 3867 (Output_Dir 3868 & Directory_Separator 3869 & Test_File_Name.all 3870 & ".adb"); 3871 3872 -- updating hash v2 to v2.1 and change TC hash to TC names 3873 Subp_Cur := Subp_List.First; 3874 loop 3875 exit when Subp_Cur = Subp_Data_List.No_Element; 3876 3877 if Subp_Data_List.Element (Subp_Cur).Corresp_Type = 0 then 3878 UH.Version := new String'("2"); 3879 UH.Hash := new String' 3880 (Subp_Data_List.Element 3881 (Subp_Cur).Subp_Full_Hash.all); 3882 if 3883 Subp_Data_List.Element (Subp_Cur).Has_TC_Info 3884 then 3885 UH.TC_Hash := new String' 3886 (Subp_Data_List.Element 3887 (Subp_Cur).TC_Info.TC_Hash.all); 3888 else 3889 UH.TC_Hash := new String'(""); 3890 end if; 3891 3892 MD_Cur := Find (Markered_Data_Map, UH); 3893 3894 if MD_Cur /= Markered_Data_Maps.No_Element then 3895 MD := Markered_Data_Maps.Element (MD_Cur); 3896 3897 Free (UH.Version); 3898 UH.Version := new String'(Hash_Version); 3899 if UH.TC_Hash.all /= "" then 3900 Free (UH.TC_Hash); 3901 UH.TC_Hash := new String' 3902 (Sanitize_TC_Name 3903 (Subp_Data_List.Element 3904 (Subp_Cur).TC_Info.Name.all)); 3905 end if; 3906 end if; 3907 3908 end if; 3909 3910 Subp_Data_List.Next (Subp_Cur); 3911 end loop; 3912 3913 -- gathering transition data 3914 if Transition then 3915 Subp_Cur := Subp_List.First; 3916 loop 3917 exit when Subp_Cur = Subp_Data_List.No_Element; 3918 3919 if 3920 Subp_Data_List.Element (Subp_Cur).Corresp_Type = 0 3921 then 3922 UH.Version := new String'("1"); 3923 UH.Hash := new String' 3924 (Subp_Data_List.Element 3925 (Subp_Cur).Subp_Hash_V1.all); 3926 if 3927 Subp_Data_List.Element (Subp_Cur).Has_TC_Info 3928 then 3929 UH.TC_Hash := new String' 3930 (Subp_Data_List.Element 3931 (Subp_Cur).TC_Info.TC_Hash.all); 3932 else 3933 UH.TC_Hash := new String'(""); 3934 end if; 3935 3936 Current_Subp := Subp_Data_List.Element (Subp_Cur); 3937 3938 Get_Subprogram_From_Separate 3939 (Output_Dir 3940 & Directory_Separator 3941 & Unit_To_File_Name 3942 (Unit_Name.all 3943 & "." 3944 & Test_Routine_Prefix 3945 & Current_Subp.Subp_Text_Name.all 3946 & "_" 3947 & Current_Subp.Subp_Hash_V1 3948 (Current_Subp.Subp_Hash_V1'First .. 3949 Current_Subp.Subp_Hash_V1'First + 5) 3950 & (if Current_Subp.Has_TC_Info 3951 then "_" & Current_Subp.TC_Info.TC_Hash 3952 (Current_Subp.TC_Info.TC_Hash'First .. 3953 Current_Subp.TC_Info.TC_Hash'First + 5) 3954 else "")) 3955 & ".adb", 3956 UH, 3957 Current_Subp); 3958 end if; 3959 Subp_Data_List.Next (Subp_Cur); 3960 end loop; 3961 end if; 3962 3963 -- gathering used short names 3964 Subp_Cur := Subp_List.First; 3965 loop 3966 exit when Subp_Cur = Subp_Data_List.No_Element; 3967 3968 Current_Subp := Subp_Data_List.Element (Subp_Cur); 3969 3970 if Subp_Data_List.Element (Subp_Cur).Corresp_Type = 0 then 3971 UH.Version := new String'(Hash_Version); 3972 UH.Hash := new String' 3973 (Subp_Data_List.Element 3974 (Subp_Cur).Subp_Full_Hash.all); 3975 if 3976 Subp_Data_List.Element (Subp_Cur).Has_TC_Info 3977 then 3978 UH.TC_Hash := new String' 3979 (Sanitize_TC_Name 3980 (Subp_Data_List.Element 3981 (Subp_Cur).TC_Info.Name.all)); 3982 else 3983 UH.TC_Hash := new String'(""); 3984 end if; 3985 3986 MD_Cur := Find (Markered_Data_Map, UH); 3987 3988 if MD_Cur /= Markered_Data_Maps.No_Element then 3989 MD := Markered_Data_Maps.Element (MD_Cur); 3990 if MD.Short_Name_Used then 3991 Short_Names_Used.Include 3992 (To_Lower (MD.Short_Name.all)); 3993 Shortnamed_Subps.Include 3994 (Current_Subp.Subp_Declaration); 3995 3996 Name_Numbers.Include 3997 (To_Lower (Current_Subp.Subp_Text_Name.all), 3998 1); 3999 Elem_Numbers.Include 4000 (Current_Subp.Subp_Declaration, 1); 4001 end if; 4002 end if; 4003 4004 end if; 4005 4006 Subp_Data_List.Next (Subp_Cur); 4007 end loop; 4008 4009 -- updating short names from markered data with hash v.1 4010 -- to hash v.2.1 where possible 4011 Subp_Cur := Subp_List.First; 4012 loop 4013 exit when Subp_Cur = Subp_Data_List.No_Element; 4014 4015 Current_Subp := Subp_Data_List.Element (Subp_Cur); 4016 4017 if Subp_Data_List.Element (Subp_Cur).Corresp_Type = 0 then 4018 UH.Version := new String'("1"); 4019 UH.Hash := new String'(Current_Subp.Subp_Hash_V1.all); 4020 4021 if 4022 Current_Subp.Has_TC_Info 4023 then 4024 UH.TC_Hash := new String' 4025 (Current_Subp.TC_Info.TC_Hash.all); 4026 else 4027 UH.TC_Hash := new String'(""); 4028 end if; 4029 4030 MD_Cur := Find (Markered_Data_Map, UH); 4031 4032 if MD_Cur /= Markered_Data_Maps.No_Element then 4033 MD := Markered_Data_Maps.Element (MD_Cur); 4034 4035 Markered_Data_Map.Delete (MD_Cur); 4036 Free (UH.Hash); 4037 UH.Hash := new String' 4038 (Current_Subp.Subp_Hash_V2_1.all); 4039 Free (UH.Version); 4040 UH.Version := new String'(Hash_Version); 4041 if UH.TC_Hash.all /= "" then 4042 Free (UH.TC_Hash); 4043 UH.TC_Hash := new String' 4044 (Sanitize_TC_Name 4045 (Current_Subp.TC_Info.Name.all)); 4046 end if; 4047 Markered_Data_Map.Include (UH, MD); 4048 end if; 4049 4050 end if; 4051 4052 Subp_Data_List.Next (Subp_Cur); 4053 end loop; 4054 4055 -- updating short names from markered data with hash v.2.1 4056 -- to hash v.2.2 where possible and gnathering short names 4057 Subp_Cur := Subp_List.First; 4058 loop 4059 exit when Subp_Cur = Subp_Data_List.No_Element; 4060 4061 Current_Subp := Subp_Data_List.Element (Subp_Cur); 4062 4063 if Subp_Data_List.Element (Subp_Cur).Corresp_Type = 0 then 4064 UH.Version := new String'("2.1"); 4065 UH.Hash := new String' 4066 (Current_Subp.Subp_Hash_V2_1.all); 4067 4068 if 4069 Current_Subp.Has_TC_Info 4070 then 4071 UH.TC_Hash := new String' 4072 (Sanitize_TC_Name 4073 (Current_Subp.TC_Info.Name.all)); 4074 else 4075 UH.TC_Hash := new String'(""); 4076 end if; 4077 4078 MD_Cur := Find (Markered_Data_Map, UH); 4079 4080 if MD_Cur /= Markered_Data_Maps.No_Element then 4081 MD := Markered_Data_Maps.Element (MD_Cur); 4082 4083 if not 4084 Short_Names_Used.Contains (MD.Short_Name.all) 4085 or else Shortnamed_Subps.Contains 4086 (Current_Subp.Subp_Declaration) 4087 then 4088 Short_Names_Used.Include (MD.Short_Name.all); 4089 Shortnamed_Subps.Include 4090 (Current_Subp.Subp_Declaration); 4091 4092 Name_Numbers.Include 4093 (To_Lower (Current_Subp.Subp_Text_Name.all), 4094 1); 4095 Elem_Numbers.Include 4096 (Current_Subp.Subp_Declaration, 1); 4097 4098 MD.Short_Name_Used := True; 4099 end if; 4100 4101 Markered_Data_Map.Delete (MD_Cur); 4102 Free (UH.Hash); 4103 UH.Hash := new String' 4104 (Current_Subp.Subp_Full_Hash.all); 4105 Free (UH.Version); 4106 UH.Version := new String'(Hash_Version); 4107 4108 Markered_Data_Map.Include (UH, MD); 4109 end if; 4110 4111 end if; 4112 4113 Subp_Data_List.Next (Subp_Cur); 4114 end loop; 4115 4116 -- creating markered_data and deciding on new short names 4117 Subp_Cur := Subp_List.First; 4118 loop 4119 exit when Subp_Cur = Subp_Data_List.No_Element; 4120 4121 Current_Subp := Subp_Data_List.Element (Subp_Cur); 4122 4123 if Subp_Data_List.Element (Subp_Cur).Corresp_Type = 0 then 4124 UH.Version := new String'(Hash_Version); 4125 UH.Hash := new String' 4126 (Current_Subp.Subp_Full_Hash.all); 4127 if 4128 Subp_Data_List.Element (Subp_Cur).Has_TC_Info 4129 then 4130 UH.TC_Hash := new String' 4131 (Sanitize_TC_Name 4132 (Current_Subp.TC_Info.Name.all)); 4133 else 4134 UH.TC_Hash := new String'(""); 4135 end if; 4136 4137 MD_Cur := Find (Markered_Data_Map, UH); 4138 4139 if MD_Cur = Markered_Data_Maps.No_Element then 4140 4141 MD.Commented_Out := False; 4142 MD.Short_Name_Used := False; 4143 MD.Short_Name := new String' 4144 (To_Lower (Current_Subp.Subp_Text_Name.all)); 4145 MD.TR_Text.Clear; 4146 4147 if 4148 not Short_Names_Used.Contains 4149 (To_Lower (Current_Subp.Subp_Text_Name.all)) 4150 or else Shortnamed_Subps.Contains 4151 (Current_Subp.Subp_Declaration) 4152 then 4153 -- Short name is free, we can use it 4154 MD.Short_Name_Used := True; 4155 Short_Names_Used.Include 4156 (To_Lower (Current_Subp.Subp_Text_Name.all)); 4157 Shortnamed_Subps.Include 4158 (Current_Subp.Subp_Declaration); 4159 4160 Name_Numbers.Include 4161 (To_Lower (Current_Subp.Subp_Text_Name.all), 4162 1); 4163 Elem_Numbers.Include 4164 (Current_Subp.Subp_Declaration, 1); 4165 4166 -- Looking for a dangling test with same short 4167 -- name but different hash. 4168 MD_Cur := Find_Same_Short_Name 4169 (Markered_Data_Map, 4170 Current_Subp.Subp_Text_Name.all); 4171 4172 if MD_Cur /= Markered_Data_Maps.No_Element then 4173 -- Using corresponding dangling test 4174 4175 MD.TR_Text.Clear; 4176 MD.TR_Text := 4177 Markered_Data_Maps.Element (MD_Cur).TR_Text; 4178 4179 -- also need to copy Commented_Out since 4180 -- the test can be dangling for a long time 4181 -- or just become dangling 4182 MD.Commented_Out := 4183 Markered_Data_Maps.Element 4184 (MD_Cur).Commented_Out; 4185 4186 Markered_Data_Map.Delete (MD_Cur); 4187 MD.Issue_Warning := True; 4188 end if; 4189 4190 end if; 4191 4192 Markered_Data_Map.Insert (UH, MD); 4193 4194 end if; 4195 4196 end if; 4197 4198 Subp_Data_List.Next (Subp_Cur); 4199 end loop; 4200 4201 -- setting overloading numbers; 4202 Subp_Cur := Subp_List.First; 4203 loop 4204 exit when Subp_Cur = Subp_Data_List.No_Element; 4205 4206 Current_Subp := Subp_Data_List.Element (Subp_Cur); 4207 4208 if Subp_Data_List.Element (Subp_Cur).Corresp_Type = 0 then 4209 4210 if 4211 Name_Numbers.Find 4212 (To_Lower (Current_Subp.Subp_Text_Name.all)) = 4213 Name_Frequency.No_Element 4214 then 4215 4216 Name_Numbers.Include 4217 (To_Lower (Current_Subp.Subp_Text_Name.all), 1); 4218 Elem_Numbers.Include 4219 (Current_Subp.Subp_Declaration, 1); 4220 4221 else 4222 if 4223 Elem_Numbers.Find 4224 (Current_Subp.Subp_Declaration) = 4225 Elem_Number_Maps.No_Element 4226 then 4227 declare 4228 X : constant Natural := 4229 Name_Numbers.Element 4230 (To_Lower 4231 (Current_Subp.Subp_Text_Name.all)); 4232 begin 4233 Name_Numbers.Replace 4234 (To_Lower (Current_Subp.Subp_Text_Name.all), 4235 X + 1); 4236 Elem_Numbers.Include 4237 (Current_Subp.Subp_Declaration, X + 1); 4238 end; 4239 end if; 4240 end if; 4241 4242 end if; 4243 4244 Subp_Data_List.Next (Subp_Cur); 4245 end loop; 4246 Name_Numbers.Clear; 4247 4248 Create (Tmp_File_Name); 4249 Put_TP_Header (Test_Data_Package_Name.all); 4250 end if; 4251 4252 Reset_Line_Counter; 4253 4254 S_Put (0, "with AUnit.Assertions; use AUnit.Assertions;"); 4255 New_Line_Count; 4256 S_Put (0, "with System.Assertions;"); 4257 New_Line_Count; 4258 if Stub_Mode_ON then 4259 declare 4260 S_Cur : Asis_Element_List.Cursor := 4261 Data.Units_To_Stub.First; 4262 Tmp : String_Access; 4263 begin 4264 while S_Cur /= Asis_Element_List.No_Element loop 4265 Tmp := new String' 4266 (To_String 4267 (Text_Name 4268 (Enclosing_Compilation_Unit 4269 (Asis_Element_List.Element 4270 (S_Cur))))); 4271 4272 if 4273 Source_Stubbed (Tmp.all) and then 4274 not Excluded_Test_Data_Files.Contains 4275 (Base_Name (Get_Source_Stub_Data_Spec (Tmp.all))) 4276 then 4277 S_Put 4278 (0, 4279 "with " 4280 & To_String 4281 (Defining_Name_Image 4282 (First_Name 4283 (Asis_Element_List.Element (S_Cur)))) 4284 & "." 4285 & Stub_Data_Unit_Name 4286 & "; use " 4287 & To_String 4288 (Defining_Name_Image 4289 (First_Name 4290 (Asis_Element_List.Element (S_Cur)))) 4291 & "." 4292 & Stub_Data_Unit_Name 4293 & ";"); 4294 Put_New_Line; 4295 end if; 4296 4297 Free (Tmp); 4298 4299 Next (S_Cur); 4300 end loop; 4301 end; 4302 end if; 4303 New_Line_Count; 4304 4305 S_Put (0, "package body " & Unit_Name.all & " is"); 4306 New_Line_Count; 4307 New_Line_Count; 4308 4309 -- Adding test routine body stubs. 4310 Subp_Cur := Subp_List.First; 4311 loop 4312 exit when Subp_Cur = Subp_Data_List.No_Element; 4313 4314 if Subp_Data_List.Element (Subp_Cur).Corresp_Type = 0 then 4315 4316 Current_Subp := Subp_Data_List.Element (Subp_Cur); 4317 4318 if Subp_Data_List.Element (Subp_Cur).Has_TC_Info then 4319 4320 case 4321 Declaration_Kind 4322 (Subp_Data_List.Element 4323 (Subp_Cur).Subp_Declaration) 4324 is 4325 4326 when A_Function_Declaration | 4327 An_Expression_Function_Declaration => 4328 Generate_Function_Wrapper 4329 (Subp_Data_List.Element (Subp_Cur)); 4330 4331 when A_Procedure_Declaration => 4332 Generate_Procedure_Wrapper 4333 (Subp_Data_List.Element (Subp_Cur)); 4334 4335 when others => 4336 null; 4337 4338 end case; 4339 4340 end if; 4341 4342 if Generate_Separates then 4343 S_Put 4344 (3, 4345 "procedure " 4346 & Subp_Data_List.Element 4347 (Subp_Cur).Subp_Mangle_Name.all 4348 & " (Gnattest_T : in out Test) is separate;"); 4349 4350 Put_New_Line; 4351 Print_Comment_Declaration 4352 (Subp_Data_List.Element (Subp_Cur), 3); 4353 Put_New_Line; 4354 4355 else 4356 4357 Test_Info.Replace 4358 (Data.Unit_File_Name.all, 4359 Test_Info.Element (Data.Unit_File_Name.all) + 1); 4360 4361 All_Tests_Counter := All_Tests_Counter + 1; 4362 4363 UH.Version := new String'(Hash_Version); 4364 UH.Hash := new String' 4365 (Subp_Data_List.Element 4366 (Subp_Cur).Subp_Full_Hash.all); 4367 if Subp_Data_List.Element (Subp_Cur).Has_TC_Info then 4368 UH.TC_Hash := new String' 4369 (Sanitize_TC_Name 4370 (Subp_Data_List.Element 4371 (Subp_Cur).TC_Info.Name.all)); 4372 else 4373 UH.TC_Hash := new String'(""); 4374 end if; 4375 4376 MD_Cur := Find (Markered_Data_Map, UH); 4377 MD := Markered_Data_Maps.Element (MD_Cur); 4378 4379 Put_Opening_Comment_Section 4380 (Subp_Data_List.Element (Subp_Cur), 4381 Elem_Numbers.Element 4382 (Current_Subp.Subp_Declaration), 4383 Use_Short_Name => MD.Short_Name_Used); 4384 4385 if Is_Unimplemented_Test (MD.TR_Text) then 4386 TR_SLOC_Buffer.Append 4387 ((new String'(Test_File_Name.all & ".ads"), 4388 new String'(Test_File_Name.all & ".adb"), 4389 null, 4390 Subp_Data_List.Element (Subp_Cur), 4391 New_Line_Counter)); 4392 else 4393 TR_SLOC_Buffer.Append 4394 ((new String'(Test_File_Name.all & ".ads"), 4395 new String'(Test_File_Name.all & ".adb"), 4396 new String'("modified"), 4397 Subp_Data_List.Element (Subp_Cur), 4398 New_Line_Counter)); 4399 end if; 4400 4401 if MD.TR_Text.Is_Empty then 4402 4403 if Stub_Mode_ON then 4404 Gather_Direct_Callees 4405 (Current_Subp.Subp_Declaration, 4406 Setters_Set); 4407 end if; 4408 4409 New_Tests_Counter := New_Tests_Counter + 1; 4410 New_Line_Count; 4411 S_Put (6, "pragma Unreferenced (Gnattest_T);"); 4412 New_Line_Count; 4413 New_Line_Count; 4414 S_Put (3, "begin"); 4415 New_Line_Count; 4416 New_Line_Count; 4417 if not Setters_Set.Is_Empty then 4418 Set_Cur := Setters_Set.First; 4419 while Set_Cur /= String_Set.No_Element loop 4420 S_Put 4421 (3, 4422 "-- " 4423 & String_Set.Element (Set_Cur) 4424 & "( );"); 4425 New_Line_Count; 4426 Next (Set_Cur); 4427 end loop; 4428 New_Line_Count; 4429 Setters_Set.Clear; 4430 end if; 4431 S_Put (6, "AUnit.Assertions.Assert"); 4432 New_Line_Count; 4433 S_Put 4434 (8, "(Gnattest_Generated.Default_Assert_Value,"); 4435 New_Line_Count; 4436 S_Put (9, """Test not implemented."");"); 4437 New_Line_Count; 4438 New_Line_Count; 4439 else 4440 4441 if MD.Issue_Warning then 4442 Report_Std 4443 (Base_Name (Data.Unit_File_Name.all) 4444 & ":" 4445 & Trim 4446 (Integer'Image (First_Line_Number 4447 (Current_Subp.Subp_Declaration)), 4448 Both) 4449 & ":" 4450 & Trim 4451 (Integer'Image (First_Column_Number 4452 (Current_Subp.Subp_Declaration)), 4453 Both) 4454 & ": warning: test for " 4455 & MD.Short_Name.all 4456 & " at " 4457 & Unit_Name.all 4458 & ":" 4459 & Trim 4460 (Integer'Image (New_Line_Counter), 4461 Both) 4462 & " might be out of date (" 4463 & MD.Short_Name.all 4464 & " has been changed)"); 4465 end if; 4466 4467 for I in 4468 MD.TR_Text.First_Index .. MD.TR_Text.Last_Index 4469 loop 4470 if MD.Commented_Out then 4471 S_Put 4472 (0, 4473 Uncomment_Line (MD.TR_Text.Element (I))); 4474 else 4475 S_Put (0, MD.TR_Text.Element (I)); 4476 end if; 4477 New_Line_Count; 4478 end loop; 4479 end if; 4480 4481 Markered_Data_Map.Delete (MD_Cur); 4482 4483 Put_Closing_Comment_Section 4484 (Subp_Data_List.Element (Subp_Cur), 4485 Elem_Numbers.Element 4486 (Current_Subp.Subp_Declaration), 4487 Use_Short_Name => MD.Short_Name_Used); 4488 New_Line_Count; 4489 4490 end if; 4491 4492 end if; 4493 4494 Subp_Data_List.Next (Subp_Cur); 4495 end loop; 4496 4497 -- printing dangling tests 4498 4499 if not Markered_Data_Map.Is_Empty then 4500 Report_Std 4501 (" warning: " 4502 & Unit_Name.all 4503 & " has dangling test(s)"); 4504 end if; 4505 4506 MD_Cur := Markered_Data_Map.First; 4507 loop 4508 exit when MD_Cur = Markered_Data_Maps.No_Element; 4509 4510 MD := Markered_Data_Maps.Element (MD_Cur); 4511 4512 declare 4513 Stub : Subp_Info; 4514 begin 4515 4516 Stub.Subp_Full_Hash := new String' 4517 (Markered_Data_Maps.Key (MD_Cur).Hash.all); 4518 Stub.Subp_Text_Name := new String' 4519 (MD.Short_Name.all); 4520 4521 if Markered_Data_Maps.Key (MD_Cur).TC_Hash.all = "" then 4522 Stub.Has_TC_Info := False; 4523 4524 Stub.Subp_Mangle_Name := new String' 4525 (Test_Routine_Prefix 4526 & Markered_Data_Maps.Element (MD_Cur).Short_Name.all 4527 & "_" 4528 & Stub.Subp_Full_Hash 4529 (Stub.Subp_Full_Hash'First .. 4530 Stub.Subp_Full_Hash'First + 5)); 4531 4532 else 4533 Stub.Has_TC_Info := True; 4534 Stub.TC_Info.TC_Hash := new String' 4535 (Markered_Data_Maps.Key (MD_Cur).TC_Hash.all); 4536 4537 Stub.Subp_Mangle_Name := new String' 4538 (Test_Routine_Prefix 4539 & Markered_Data_Maps.Element (MD_Cur).Short_Name.all 4540 & "_" 4541 & Stub.Subp_Full_Hash 4542 (Stub.Subp_Full_Hash'First .. 4543 Stub.Subp_Full_Hash'First + 5) 4544 & "_" 4545 & Stub.TC_Info.TC_Hash.all); 4546 end if; 4547 4548 Put_Opening_Comment_Section 4549 (Stub, 0, True, MD.Short_Name_Used); 4550 4551 Add_DT 4552 (TP_List, 4553 Test_File_Name.all & ".ads", 4554 Test_File_Name.all & ".adb", 4555 New_Line_Counter, 4556 1); 4557 4558 for I in 4559 MD.TR_Text.First_Index .. MD.TR_Text.Last_Index 4560 loop 4561 if MD.Commented_Out then 4562 S_Put (0, MD.TR_Text.Element (I)); 4563 else 4564 S_Put (0, "-- " & MD.TR_Text.Element (I)); 4565 end if; 4566 New_Line_Count; 4567 end loop; 4568 4569 Put_Closing_Comment_Section 4570 (Stub, 0, True, MD.Short_Name_Used); 4571 New_Line_Count; 4572 end; 4573 4574 Markered_Data_Maps.Next (MD_Cur); 4575 end loop; 4576 4577 S_Put (0, "end " & Unit_Name.all & ";"); 4578 4579 Close_File; 4580 4581 Add_Buffered_TR_Slocs 4582 (TP_List, 4583 Format_Time 4584 (File_Time_Stamp 4585 (Tmp_File_Name))); 4586 4587 if not Generate_Separates then 4588 declare 4589 Old_Package : constant String := 4590 Output_Dir & Directory_Separator 4591 & Test_File_Name.all & ".adb"; 4592 Success : Boolean; 4593 begin 4594 if Is_Regular_File (Old_Package) then 4595 Delete_File (Old_Package, Success); 4596 if not Success then 4597 Report_Err ("cannot delete " & Old_Package); 4598 raise Fatal_Error; 4599 end if; 4600 end if; 4601 Copy_File (Tmp_File_Name, Old_Package, Success); 4602 if not Success then 4603 Report_Err ("cannot copy tmp test package to " 4604 & Old_Package); 4605 raise Fatal_Error; 4606 end if; 4607 Delete_File (Tmp_File_Name, Success); 4608 if not Success then 4609 Report_Err ("cannot delete tmp test package"); 4610 raise Fatal_Error; 4611 end if; 4612 end; 4613 end if; 4614 4615 Markered_Data_Map.Clear; 4616 4617 else 4618 Excluded_Test_Package_Bodies.Include 4619 (Test_File_Name.all & ".adb"); 4620 end if; 4621 4622 Short_Names_Used.Clear; 4623 Shortnamed_Subps.Clear; 4624 Elem_Numbers.Clear; 4625 Subp_List.Clear; 4626 Package_Info_List.Next (Pack_Cur); 4627 end loop; 4628 4629 end if; 4630 4631 Add_Test_List (Data.Unit_File_Name.all, TP_List); 4632 TP_List.Clear; 4633 4634 if Data.Is_Generic then 4635 Gen_Tests_Storage.Append (Gen_Tests); 4636 end if; 4637 4638 end Generate_Test_Package; 4639 4640 ------------------------------------------- 4641 -- Generate_Test_Package_Instantiation -- 4642 ------------------------------------------- 4643 4644 procedure Generate_Test_Package_Instantiation (Data : Data_Holder) is 4645 Output_Dir : constant String := 4646 Get_Source_Output_Dir (Data.Unit_File_Name.all); 4647 New_Unit_Name : String_Access; 4648 Test_File_Name : String_Access; 4649 4650 Cur_Stor : Generic_Tests_Storage.Cursor; 4651 Gen_Tests : Generic_Tests; 4652 Cur_Test : List_Of_Strings.Cursor; 4653 begin 4654 4655 Cur_Stor := Gen_Tests_Storage.First; 4656 loop 4657 exit when Cur_Stor = Generic_Tests_Storage.No_Element; 4658 4659 Gen_Tests := Generic_Tests_Storage.Element (Cur_Stor); 4660 4661 if Gen_Tests.Gen_Unit_Full_Name.all = Data.Gen_Unit_Full_Name.all then 4662 Cur_Test := Gen_Tests.Tested_Type_Names.First; 4663 loop 4664 exit when Cur_Test = List_Of_Strings.No_Element; 4665 4666 New_Unit_Name := 4667 new String'(Data.Unit_Full_Name.all & 4668 "." & 4669 List_Of_Strings.Element (Cur_Test) & 4670 "_" & 4671 Inst_Test_Unit_Name); 4672 Test_File_Name := 4673 new String'(Unit_To_File_Name (New_Unit_Name.all)); 4674 4675 Create (Output_Dir & Directory_Separator & 4676 Test_File_Name.all & ".ads"); 4677 4678 S_Put 4679 (0, 4680 "with " & 4681 Data.Gen_Unit_Full_Name.all & 4682 "." & 4683 List_Of_Strings.Element (Cur_Test) & 4684 Gen_Test_Unit_Name_Suff & 4685 ";"); 4686 Put_New_Line; 4687 Put_New_Line; 4688 S_Put (0, "package " & New_Unit_Name.all & " is new"); 4689 Put_New_Line; 4690 S_Put (2, 4691 Data.Unit_Full_Name.all & 4692 "." & 4693 List_Of_Strings.Element (Cur_Test) & 4694 Gen_Test_Unit_Name_Suff & 4695 ";"); 4696 4697 Close_File; 4698 4699 List_Of_Strings.Next (Cur_Test); 4700 end loop; 4701 4702 if Gen_Tests.Has_Simple_Case then 4703 4704 New_Unit_Name := 4705 new String'(Data.Unit_Full_Name.all & 4706 "." & 4707 Inst_Test_Unit_Name); 4708 Test_File_Name := 4709 new String'(Unit_To_File_Name (New_Unit_Name.all)); 4710 4711 Create (Output_Dir & Directory_Separator & 4712 Test_File_Name.all & ".ads"); 4713 4714 S_Put 4715 (0, 4716 "with " & 4717 Data.Gen_Unit_Full_Name.all & 4718 "." & 4719 Gen_Test_Unit_Name & 4720 ";"); 4721 Put_New_Line; 4722 Put_New_Line; 4723 S_Put (0, "package " & New_Unit_Name.all & " is new"); 4724 Put_New_Line; 4725 S_Put (2, 4726 Data.Unit_Full_Name.all & 4727 "." & 4728 Gen_Test_Unit_Name & 4729 ";"); 4730 4731 Close_File; 4732 4733 end if; 4734 4735 exit; 4736 end if; 4737 4738 Generic_Tests_Storage.Next (Cur_Stor); 4739 end loop; 4740 4741 end Generate_Test_Package_Instantiation; 4742 4743 -------------------------- 4744 -- Generate_Skeletons -- 4745 -------------------------- 4746 4747 procedure Generate_Skeletons (Data : Data_Holder) is 4748 Output_Dir : constant String := 4749 Get_Source_Output_Dir (Data.Unit_File_Name.all); 4750 4751 Tmp_File_Name : constant String := 4752 "gnattest_tmp_skeleton"; 4753 -- Name of temporary file created to compare with already existing 4754 -- skeleton to check if the skeleton was modified by user. 4755 4756 New_Skeleton : Boolean; 4757 -- True when the skeleton is generated for the first time. 4758 4759 Unit_Name : String_Access; 4760 -- Test package unit name. 4761 4762 New_Unit_Full_Name : String_Access; 4763 4764 Separate_Unit_Name : String_Access; 4765 -- Full name of the separated unit. 4766 4767 Separate_File_Name : String_Access; 4768 -- File name for the separated unit. 4769 4770 Separated_Name : String_Access; 4771 -- Unit name of the separated test routine of environment management. 4772 4773 Current_Type : Base_Type_Info; 4774 4775 Current_Subp : Subp_Info; 4776 4777 Subp_Cur : Subp_Data_List.Cursor; 4778 4779 TP_List : TP_Mapping_List.List; 4780 4781 procedure Set_Current_Type (Type_Numb : Natural); 4782 -- Looks trough types and nested types and sets the value of 4783 -- Current_Type with correspondig element. 4784 4785 procedure Set_Current_Type (Type_Numb : Natural) is 4786 begin 4787 4788 for 4789 I in Data.Type_Data_List.First_Index .. 4790 Data.Type_Data_List.Last_Index 4791 loop 4792 4793 if 4794 Data.Type_Data_List.Element (I).Type_Number = Type_Numb 4795 then 4796 Current_Type := Data.Type_Data_List.Element (I); 4797 exit; 4798 end if; 4799 4800 end loop; 4801 4802 end Set_Current_Type; 4803 4804 begin 4805 4806 Test_Info.Include (Data.Unit_File_Name.all, 0); 4807 4808 -- Setting up TP_List if there is one already from test_data stage. 4809 if GNATtest.Mapping.Mapping.Find (Data.Unit_File_Name.all) /= 4810 SP_Mapping.No_Element 4811 then 4812 TP_List := 4813 SP_Mapping.Element 4814 (GNATtest.Mapping.Mapping.Find (Data.Unit_File_Name.all)). 4815 Test_Info; 4816 end if; 4817 4818 -- Test routines. 4819 Subp_Cur := Data.Subp_List.First; 4820 loop 4821 exit when Subp_Cur = Subp_Data_List.No_Element; 4822 4823 Current_Subp := Subp_Data_List.Element (Subp_Cur); 4824 4825 Set_Current_Type (Current_Subp.Corresp_Type); 4826 4827 if not Current_Subp.Is_Abstract then 4828 4829 Separated_Name := new String' 4830 (Current_Subp.Subp_Mangle_Name.all); 4831 4832 if Current_Subp.Nesting.all = Data.Unit_Full_Name.all then 4833 if Current_Subp.Corresp_Type = 0 then 4834 if Data.Is_Generic then 4835 New_Unit_Full_Name := 4836 new String'(Data.Unit_Full_Name.all & 4837 "." & 4838 Gen_Test_Unit_Name); 4839 else 4840 New_Unit_Full_Name := 4841 new String'(Data.Unit_Full_Name.all & 4842 "." & 4843 Test_Data_Unit_Name & 4844 "." & 4845 Test_Unit_Name); 4846 end if; 4847 else 4848 New_Unit_Full_Name := new String'(Data.Unit_Full_Name.all); 4849 end if; 4850 else 4851 if Current_Subp.Corresp_Type = 0 then 4852 New_Unit_Full_Name := new String' 4853 (Data.Unit_Full_Name.all & "." & 4854 Test_Data_Unit_Name & "." & 4855 Test_Unit_Name & "." & 4856 Nesting_Difference 4857 (Current_Subp.Nesting.all, 4858 Data.Unit_Full_Name.all) & 4859 "." & Test_Data_Unit_Name & "." & Test_Unit_Name); 4860 4861 else 4862 Set_Current_Type (Current_Subp.Corresp_Type); 4863 4864 if Current_Type.Nesting.all = Data.Unit_Full_Name.all then 4865 New_Unit_Full_Name := new String' 4866 (Data.Unit_Full_Name.all & "." & 4867 Nesting_Difference 4868 (Current_Subp.Nesting.all, 4869 Data.Unit_Full_Name.all)); 4870 else 4871 New_Unit_Full_Name := new String' 4872 (Data.Unit_Full_Name.all & "." & 4873 Test_Data_Unit_Name & "." & 4874 Test_Unit_Name & "." & 4875 Nesting_Difference 4876 (Current_Subp.Nesting.all, 4877 Data.Unit_Full_Name.all)); 4878 end if; 4879 end if; 4880 end if; 4881 4882 if Current_Subp.Corresp_Type = 0 then 4883 4884 Unit_Name := new String'(New_Unit_Full_Name.all); 4885 4886 else 4887 4888 if Data.Is_Generic then 4889 Unit_Name := new 4890 String'(New_Unit_Full_Name.all & 4891 "." & 4892 Current_Type.Main_Type_Text_Name.all & 4893 Gen_Test_Unit_Name_Suff); 4894 else 4895 Unit_Name := new 4896 String'(New_Unit_Full_Name.all & 4897 "." & 4898 Current_Type.Main_Type_Text_Name.all & 4899 Test_Data_Unit_Name_Suff & 4900 "." & 4901 Current_Type.Main_Type_Text_Name.all & 4902 Test_Unit_Name_Suff); 4903 end if; 4904 4905 end if; 4906 4907 Free (New_Unit_Full_Name); 4908 4909 Separate_Unit_Name := new 4910 String'(Unit_Name.all & 4911 "." & 4912 Separated_Name.all); 4913 4914 Separate_File_Name := 4915 new String'(Unit_To_File_Name (Separate_Unit_Name.all) & ".adb"); 4916 4917 Test_Info.Replace 4918 (Data.Unit_File_Name.all, 4919 Test_Info.Element (Data.Unit_File_Name.all) + 1); 4920 4921 All_Tests_Counter := All_Tests_Counter + 1; 4922 4923 if not Is_Regular_File (Output_Dir & 4924 Directory_Separator & 4925 Separate_File_Name.all) 4926 then 4927 4928 New_Tests_Counter := New_Tests_Counter + 1; 4929 4930 Create 4931 (Output_Dir & Directory_Separator & Separate_File_Name.all); 4932 4933 New_Skeleton := True; 4934 else 4935 Create (Tmp_File_Name); 4936 New_Skeleton := False; 4937 end if; 4938 4939 Print_Comment_Separate 4940 (Subp_Data_List.Element (Subp_Cur)); 4941 Put_New_Line; 4942 S_Put (0, "with Gnattest_Generated;"); 4943 Put_New_Line; 4944 Put_New_Line; 4945 S_Put (0, "separate (" & Unit_Name.all & ")"); 4946 Put_New_Line; 4947 4948 if not Subp_Data_List.Element (Subp_Cur).Is_Abstract then 4949 S_Put 4950 (0, 4951 "procedure " & 4952 Separated_Name.all & 4953 " (Gnattest_T : in out "); 4954 4955 if Subp_Data_List.Element (Subp_Cur).Corresp_Type = 0 then 4956 S_Put (0, "Test) is"); 4957 else 4958 S_Put 4959 (0, 4960 "Test_" & 4961 Current_Type.Main_Type_Text_Name.all & 4962 ") is"); 4963 end if; 4964 Put_New_Line; 4965 S_Put (3, "pragma Unreferenced (Gnattest_T);"); 4966 Put_New_Line; 4967 4968 if Subp_Data_List.Element (Subp_Cur).Has_TC_Info then 4969 Put_Wrapper_Rename (3, Subp_Data_List.Element (Subp_Cur)); 4970 end if; 4971 4972 S_Put (0, "begin"); 4973 Put_New_Line; 4974 S_Put (3, 4975 "AUnit.Assertions.Assert"); 4976 Put_New_Line; 4977 S_Put (5, "(Gnattest_Generated.Default_Assert_Value,"); 4978 Put_New_Line; 4979 S_Put (6, """Test not implemented."");"); 4980 Put_New_Line; 4981 S_Put (0, "end " & Separated_Name.all & ";"); 4982 Put_New_Line; 4983 4984 end if; 4985 4986 Close_File; 4987 4988 declare 4989 Skeleton_Time : constant OS_Time := 4990 File_Time_Stamp 4991 (Output_Dir & 4992 Directory_Separator & 4993 Separate_File_Name.all); 4994 4995 Old_File, New_File : Ada.Text_IO.File_Type; 4996 Old_File_Line, New_File_Line : String_Access; 4997 Idx : Integer; 4998 4999 Unmodified : Boolean := True; 5000 begin 5001 if New_Skeleton then 5002 Add_TR 5003 (TP_List, 5004 Unit_To_File_Name (Unit_Name.all) & ".ads", 5005 Separate_File_Name.all, 5006 Format_Time (Skeleton_Time), 5007 Subp_Data_List.Element (Subp_Cur)); 5008 else 5009 Open (New_File, In_File, Tmp_File_Name); 5010 Open 5011 (Old_File, In_File, 5012 Output_Dir & 5013 Directory_Separator & 5014 Separate_File_Name.all); 5015 5016 -- Skipping header comments from both new and old skeletons. 5017 -- Simple reformatting of source code can lead to 5018 -- differences in how tested subprogram image is presented 5019 -- while the test itself is still unmodified. 5020 loop 5021 exit when End_Of_File (Old_File); 5022 Old_File_Line := new String'(Get_Line (Old_File)); 5023 Idx := Old_File_Line'First; 5024 if 5025 Old_File_Line'Length > 1 and then 5026 Old_File_Line (Idx .. Idx + 1) = "--" 5027 then 5028 Free (Old_File_Line); 5029 else 5030 exit; 5031 end if; 5032 end loop; 5033 5034 loop 5035 exit when End_Of_File (New_File); 5036 New_File_Line := new String'(Get_Line (New_File)); 5037 Idx := New_File_Line'First; 5038 if 5039 New_File_Line'Length > 1 and then 5040 New_File_Line (Idx .. Idx + 1) = "--" 5041 then 5042 Free (New_File_Line); 5043 else 5044 exit; 5045 end if; 5046 end loop; 5047 5048 loop 5049 if 5050 End_Of_File (New_File) and not End_Of_File (Old_File) 5051 then 5052 Unmodified := False; 5053 exit; 5054 end if; 5055 5056 if 5057 End_Of_File (Old_File) and not End_Of_File (New_File) 5058 then 5059 Unmodified := False; 5060 exit; 5061 end if; 5062 5063 if End_Of_File (Old_File) and End_Of_File (New_File) then 5064 exit; 5065 end if; 5066 5067 Old_File_Line := new String'(Get_Line (Old_File)); 5068 New_File_Line := new String'(Get_Line (New_File)); 5069 if Old_File_Line.all /= New_File_Line.all then 5070 Unmodified := False; 5071 exit; 5072 end if; 5073 end loop; 5074 5075 if Unmodified then 5076 Add_TR 5077 (TP_List, 5078 Unit_To_File_Name (Unit_Name.all) & ".ads", 5079 Separate_File_Name.all, 5080 Format_Time (Skeleton_Time), 5081 Subp_Data_List.Element (Subp_Cur)); 5082 else 5083 Add_TR 5084 (TP_List, 5085 Unit_To_File_Name (Unit_Name.all) & ".ads", 5086 Separate_File_Name.all, 5087 "modified", 5088 Subp_Data_List.Element (Subp_Cur)); 5089 end if; 5090 5091 Close (New_File); 5092 Close (Old_File); 5093 end if; 5094 end; 5095 5096 Free (Separate_Unit_Name); 5097 Free (Separate_File_Name); 5098 Free (Separated_Name); 5099 end if; 5100 5101 Subp_Data_List.Next (Subp_Cur); 5102 end loop; 5103 5104 Add_Test_List (Data.Unit_File_Name.all, TP_List); 5105 TP_List.Clear; 5106 5107 end Generate_Skeletons; 5108 5109 ---------------------------------- 5110 -- Get_Subprogram_From_Separate -- 5111 ---------------------------------- 5112 5113 procedure Get_Subprogram_From_Separate 5114 (File : String; 5115 UH : Unique_Hash; 5116 Subp : Subp_Info) 5117 is 5118 Input_File : Ada.Text_IO.File_Type; 5119 MD : Markered_Data; 5120 Line : String_Access; 5121 Append_Line : Boolean; 5122 begin 5123 if not Is_Regular_File (File) then 5124 return; 5125 end if; 5126 5127 MD.Commented_Out := False; 5128 MD.TR_Text := String_Vectors.Empty_Vector; 5129 MD.Short_Name := new String'(Subp.Subp_Text_Name.all); 5130 5131 Open (Input_File, In_File, File); 5132 5133 loop 5134 exit when End_Of_File (Input_File); 5135 Line := new String'(Get_Line (Input_File)); 5136 Append_Line := True; 5137 5138 if To_Lower (Line.all) = "with gnattest_generated;" then 5139 Append_Line := False; 5140 end if; 5141 5142 -- skipping test routine profile up to declaration section; 5143 -- depending on line breaks it can take different number of lines 5144 if Index (To_Lower (Line.all), "separate", Line'First) /= 0 then 5145 loop 5146 if 5147 Index (To_Lower (Line.all), ") is", Line'First) /= 0 5148 or else Trim (To_Lower (Line.all), Both) = "is" 5149 then 5150 Append_Line := False; 5151 exit; 5152 else 5153 Free (Line); 5154 Line := new String'(Get_Line (Input_File)); 5155 end if; 5156 end loop; 5157 end if; 5158 5159 -- skipping "end test_outine_name;" 5160 if 5161 Index 5162 (To_Lower (Line.all), 5163 "end " 5164 & To_Lower 5165 (Test_Routine_Prefix 5166 & Subp.Subp_Text_Name.all 5167 & "_" 5168 & Subp.Subp_Hash_V1 5169 (Subp.Subp_Hash_V1'First .. Subp.Subp_Hash_V1'First + 5)) 5170 & ";", 5171 Line'First) /= 0 5172 then 5173 Append_Line := False; 5174 end if; 5175 5176 if Append_Line then 5177 MD.TR_Text.Append (Line.all); 5178 end if; 5179 5180 Free (Line); 5181 end loop; 5182 5183 Close (Input_File); 5184 5185 if Find (Markered_Data_Map, UH) = Markered_Data_Maps.No_Element then 5186 Markered_Data_Map.Insert (UH, MD); 5187 else 5188 Markered_Data_Map.Replace (UH, MD); 5189 end if; 5190 5191 end Get_Subprogram_From_Separate; 5192 5193 ---------------------------------- 5194 -- Get_Subprograms_From_Package -- 5195 ---------------------------------- 5196 5197 procedure Get_Subprograms_From_Package (File : String) is 5198 5199 Input_File : Ada.Text_IO.File_Type; 5200 5201 Line_Counter : Natural := 0; 5202 5203 Line : String_Access; 5204 5205 Idx, Idx2 : Natural; 5206 5207 UH : Unique_Hash; 5208 MD : Markered_Data; 5209 5210 ID_Found : Boolean; 5211 5212 type Parsing_Modes is (TR, Marker, Other); 5213 5214 Parsing_Mode : Parsing_Modes := Other; 5215 Prev_Parsing_Mode : Parsing_Modes := Other; 5216 5217 procedure Report_Corrupted_Marker; 5218 pragma Unreferenced (Report_Corrupted_Marker); 5219 5220 procedure Report_Corrupted_Marker is 5221 begin 5222 Report_Err 5223 ("gnattest: marker corrupted at " 5224 & Base_Name (File) 5225 & ":" 5226 & Natural'Image (Line_Counter)); 5227 end Report_Corrupted_Marker; 5228 5229 begin 5230 5231 if not Is_Regular_File (File) then 5232 return; 5233 end if; 5234 5235 MD.Commented_Out := False; 5236 MD.Short_Name_Used := False; 5237 MD.TR_Text := String_Vectors.Empty_Vector; 5238 UH.Hash := new String'(""); 5239 UH.TC_Hash := new String'(""); 5240 5241 Open (Input_File, In_File, File); 5242 5243 loop 5244 exit when End_Of_File (Input_File); 5245 5246 Line := new String'(Get_Line (Input_File)); 5247 Line_Counter := Line_Counter + 1; 5248 5249 case Parsing_Mode is 5250 when Other => 5251 if Index (Line.all, GT_Marker_Begin) /= 0 then 5252 Parsing_Mode := Marker; 5253 Prev_Parsing_Mode := Other; 5254 ID_Found := False; 5255 end if; 5256 5257 when Marker => 5258 5259 Idx := Index (Line.all, "-- id:"); 5260 if Idx /= 0 then 5261 ID_Found := True; 5262 5263 Idx := Idx + 7; 5264 Idx2 := Index (Line.all, "/", Idx + 1); 5265 UH.Version := new String'(Line (Idx .. Idx2 - 1)); 5266 5267 Idx := Idx2 + 1; 5268 Idx2 := Index (Line.all, "/", Idx + 1); 5269 UH.Hash := new String'(Line (Idx .. Idx2 - 1)); 5270 5271 Idx := Idx2 + 1; 5272 Idx2 := Index (Line.all, "/", Idx + 1); 5273 MD.Short_Name := new String'(Line (Idx .. Idx2 - 1)); 5274 5275 Idx := Idx2 + 1; 5276 Idx2 := Index (Line.all, "/", Idx + 1); 5277 if Line (Idx .. Idx2 - 1) = "1" then 5278 MD.Short_Name_Used := True; 5279 else 5280 MD.Short_Name_Used := False; 5281 end if; 5282 5283 Idx := Idx2 + 1; 5284 Idx2 := Index (Line.all, "/", Idx + 1); 5285 if Line (Idx .. Idx2 - 1) = "1" then 5286 MD.Commented_Out := True; 5287 else 5288 MD.Commented_Out := False; 5289 end if; 5290 5291 if Idx2 < Line'Last then 5292 5293 Idx := Idx2 + 1; 5294 Idx2 := Index (Line.all, "/", Idx + 1); 5295 UH.TC_Hash := new String'(Line (Idx .. Idx2 - 1)); 5296 5297 end if; 5298 5299 else 5300 5301 if Index (Line.all, GT_Marker_End) /= 0 then 5302 if Prev_Parsing_Mode = Other then 5303 if ID_Found then 5304 Parsing_Mode := TR; 5305 else 5306 Parsing_Mode := Other; 5307 end if; 5308 end if; 5309 if Prev_Parsing_Mode = TR then 5310 Parsing_Mode := Other; 5311 end if; 5312 end if; 5313 5314 end if; 5315 5316 when TR => 5317 5318 if Index (Line.all, GT_Marker_Begin) /= 0 then 5319 Markered_Data_Map.Include (UH, MD); 5320 Prev_Parsing_Mode := TR; 5321 Parsing_Mode := Marker; 5322 5323 MD.Commented_Out := False; 5324 MD.Short_Name_Used := False; 5325 MD.TR_Text := String_Vectors.Empty_Vector; 5326 UH.Hash := new String'(""); 5327 UH.TC_Hash := new String'(""); 5328 else 5329 MD.TR_Text.Append (Line.all); 5330 end if; 5331 5332 end case; 5333 5334 end loop; 5335 5336 Close (Input_File); 5337 end Get_Subprograms_From_Package; 5338 5339 -------------------------- 5340 -- Initialize_Context -- 5341 -------------------------- 5342 5343 function Initialize_Context (Source_Name : String) return Boolean is 5344 Success : Boolean; 5345 5346 use type Asis.Errors.Error_Kinds; -- for EC12-013 5347 begin 5348 5349 Create_Tree (Source_Name, Success); 5350 5351 if not Success then 5352 Set_Source_Status (Source_Name, Bad_Content); 5353 5354 Report_Std ("gnattest: " & Source_Name & 5355 " is not a legal Ada source"); 5356 5357 return False; 5358 5359 end if; 5360 5361 Last_Context_Name := 5362 new String'(Get_Source_Suffixless_Name (Source_Name)); 5363 5364 Associate 5365 (The_Context => The_Context, 5366 Name => "", 5367 Parameters => "-C1 " 5368 & To_Wide_String (Get_Source_Suffixless_Name (Source_Name) & ".adt")); 5369 5370 begin 5371 Open (The_Context); 5372 Success := True; 5373 exception 5374 when ASIS_Failed => 5375 -- The only known situation when we can not open a C1 context for 5376 -- newly created tree is recompilation of System (see D617-017) 5377 5378 if Asis.Implementation.Status = Asis.Errors.Use_Error 5379 and then 5380 Asis.Implementation.Diagnosis = "Internal implementation error:" 5381 & " Asis.Ada_Environments.Open - System is recompiled" 5382 then 5383 Report_Err 5384 ("gnattest: can not process redefinition of System in " & 5385 Source_Name); 5386 5387 Set_Source_Status (Source_Name, Bad_Content); 5388 Success := False; 5389 else 5390 raise; 5391 end if; 5392 5393 end; 5394 5395 return Success; 5396 end Initialize_Context; 5397 5398 ---------------------------- 5399 -- Is_Callable_Subprogram -- 5400 ---------------------------- 5401 5402 function Is_Callable_Subprogram (Subp : Asis.Element) return Boolean 5403 is 5404 begin 5405 if Trait_Kind (Subp) = An_Abstract_Trait then 5406 return False; 5407 end if; 5408 if Declaration_Kind (Subp) = A_Null_Procedure_Declaration then 5409 return False; 5410 end if; 5411 return True; 5412 end Is_Callable_Subprogram; 5413 5414 ------------------------------------ 5415 -- Is_Declared_In_Regular_Package -- 5416 ------------------------------------ 5417 5418 function Is_Declared_In_Regular_Package 5419 (Elem : Asis.Element) 5420 return Boolean 5421 is 5422 Encl : Asis.Element := Enclosing_Element (Elem); 5423 begin 5424 loop 5425 exit when Is_Nil (Encl); 5426 5427 if Declaration_Kind (Encl) /= A_Package_Declaration then 5428 return False; 5429 end if; 5430 5431 Encl := Enclosing_Element (Encl); 5432 5433 end loop; 5434 5435 return True; 5436 5437 end Is_Declared_In_Regular_Package; 5438 5439 ---------------------- 5440 -- Is_Fully_Private -- 5441 ---------------------- 5442 5443 function Is_Fully_Private 5444 (Arg : Asis.Declaration) return Boolean 5445 is 5446 Corresp_Decl : Asis.Declaration; 5447 begin 5448 if Is_Private (Arg) then 5449 Corresp_Decl := Corresponding_Type_Declaration (Arg); 5450 if Is_Nil (Corresp_Decl) then 5451 return True; 5452 else 5453 return Is_Private (Corresp_Decl); 5454 end if; 5455 else 5456 return False; 5457 end if; 5458 end Is_Fully_Private; 5459 5460 ----------------- 5461 -- Mangle_Hash -- 5462 ----------------- 5463 5464 function Mangle_Hash 5465 (Subp : Asis.Declaration) return String 5466 is 5467 Full_Hash : String_Access; 5468 begin 5469 5470 if Generate_Separates then 5471 Full_Hash := new String'(Mangle_Hash_Full (Subp, True)); 5472 else 5473 Full_Hash := new String'(Mangle_Hash_Full (Subp)); 5474 end if; 5475 5476 return 5477 Test_Routine_Prefix 5478 & Get_Subp_Name (Subp) 5479 & "_" 5480 & Full_Hash (Full_Hash'First .. Full_Hash'First + 5); 5481 end Mangle_Hash; 5482 5483 ------------------------------------- 5484 -- No_Inheritance_Through_Generics -- 5485 ------------------------------------- 5486 5487 function No_Inheritance_Through_Generics 5488 (Inheritance_Root_Type : Asis.Element; 5489 Inheritance_Final_Type : Asis.Element) 5490 return Boolean 5491 is 5492 Elem : Asis.Element := Inheritance_Final_Type; 5493 Elem2 : Asis.Element; 5494 begin 5495 if 5496 Definition_Kind 5497 (Type_Declaration_View 5498 (Inheritance_Root_Type)) = A_Private_Extension_Definition 5499 or else 5500 Declaration_Kind 5501 (Inheritance_Root_Type) = A_Private_Type_Declaration 5502 then 5503 Elem2 := Corresponding_Type_Declaration (Inheritance_Root_Type); 5504 else 5505 Elem2 := Inheritance_Root_Type; 5506 end if; 5507 5508 loop 5509 if not Is_Declared_In_Regular_Package (Elem) then 5510 return False; 5511 end if; 5512 5513 exit when 5514 Is_Equal (Elem, Elem2) or else 5515 Is_Equal (Elem, (Corresponding_Type_Declaration (Elem2))); 5516 Elem := Parent_Type_Declaration (Elem); 5517 end loop; 5518 return True; 5519 end No_Inheritance_Through_Generics; 5520 5521 ------------------------------- 5522 -- Print_Comment_Declaration -- 5523 ------------------------------- 5524 5525 procedure Print_Comment_Declaration (Subp : Subp_Info; Span : Natural := 0) 5526 is 5527 File_Name : constant String := Base_Name (To_String (Text_Name 5528 (Enclosing_Compilation_Unit (Subp.Subp_Declaration)))); 5529 5530 Elem_Span : constant Asis.Text.Span := 5531 Element_Span (Subp.Subp_Declaration); 5532 begin 5533 S_Put 5534 (Span, 5535 "-- " & 5536 File_Name & 5537 ":" & 5538 Trim (Integer'Image (Elem_Span.First_Line), Both) & 5539 ":" & 5540 Trim (Integer'Image (Elem_Span.First_Column), Both) & 5541 ":" & 5542 Subp.Subp_Text_Name.all); 5543 if Subp.Has_TC_Info then 5544 S_Put (0, ":" & Subp.TC_Info.Name.all); 5545 end if; 5546 Put_New_Line; 5547 end Print_Comment_Declaration; 5548 5549 ---------------------------- 5550 -- Print_Comment_Separate -- 5551 ---------------------------- 5552 5553 procedure Print_Comment_Separate (Subp : Subp_Info; Span : Natural := 0) is 5554 5555 Params : constant Parameter_Specification_List := 5556 Parameter_Profile (Subp.Subp_Declaration); 5557 5558 Subp_Name : constant String := Get_Subp_Name (Subp.Subp_Declaration); 5559 5560 Func_Profile_Span : Asis.Text.Span; 5561 Last_Arg_Span : Asis.Text.Span; 5562 5563 begin 5564 5565 case Declaration_Kind (Subp.Subp_Declaration) is 5566 when A_Procedure_Declaration | 5567 A_Procedure_Renaming_Declaration => 5568 5569 if Params'Length = 0 then 5570 5571 S_Put (Span, "-- procedure " & Subp_Name); 5572 Put_New_Line; 5573 5574 else 5575 5576 Last_Arg_Span.First_Line := 5577 Element_Span (Subp.Subp_Declaration).First_Line; 5578 Last_Arg_Span.First_Column := 5579 Element_Span (Subp.Subp_Declaration).First_Column; 5580 Last_Arg_Span.Last_Line := 5581 Element_Span (Params (Params'First)).Last_Line; 5582 Last_Arg_Span.Last_Column := 5583 Element_Span (Params (Params'First)).Last_Column; 5584 5585 declare 5586 Proc_Lines : constant Line_List := 5587 Lines (Subp.Subp_Declaration, Last_Arg_Span); 5588 begin 5589 for I in Proc_Lines'Range loop 5590 S_Put 5591 (Span, 5592 "-- " & 5593 Trim 5594 (To_String (Non_Comment_Image (Proc_Lines (I))), 5595 Both)); 5596 if I = Proc_Lines'Last then 5597 S_Put (0, ")"); 5598 end if; 5599 Put_New_Line; 5600 end loop; 5601 end; 5602 end if; 5603 5604 when others => 5605 5606 Func_Profile_Span.First_Line := 5607 Element_Span (Subp.Subp_Declaration).First_Line; 5608 Func_Profile_Span.First_Column := 5609 Element_Span (Subp.Subp_Declaration).First_Column; 5610 Func_Profile_Span.Last_Line := 5611 Element_Span (Result_Profile (Subp.Subp_Declaration)).Last_Line; 5612 Func_Profile_Span.Last_Column := 5613 Element_Span 5614 (Result_Profile (Subp.Subp_Declaration)).Last_Column; 5615 5616 declare 5617 Func_Lines : constant Line_List := 5618 Lines (Subp.Subp_Declaration, Func_Profile_Span); 5619 begin 5620 for I in Func_Lines'Range loop 5621 S_Put 5622 (Span, 5623 "-- " & 5624 Trim 5625 (To_String (Non_Comment_Image (Func_Lines (I))), Both)); 5626 Put_New_Line; 5627 end loop; 5628 end; 5629 5630 end case; 5631 5632 if Subp.Has_TC_Info then 5633 S_Put (Span, "-- Test Case """ & Subp.TC_Info.Name.all & """"); 5634 Put_New_Line; 5635 end if; 5636 end Print_Comment_Separate; 5637 5638 -------------------- 5639 -- Process_Source -- 5640 -------------------- 5641 5642 procedure Process_Source (The_Unit : Asis.Compilation_Unit) is 5643 Source_Name : String_Access; 5644 Data : Data_Holder; 5645 5646 Suite_Data_List : Suites_Data_Type; 5647 Suite_Data : GNATtest.Harness.Generator.Data_Holder; 5648 5649 Apropriate_Source : Boolean; 5650 5651 Test_Packages : String_Set.Set; 5652 Cur : String_Set.Cursor; 5653 5654 procedure Get_Test_Packages_List (S_Data : Suites_Data_Type); 5655 5656 function Get_Suite_Components 5657 (S_Data : Suites_Data_Type; 5658 Package_Name : String) 5659 return GNATtest.Harness.Generator.Data_Holder; 5660 5661 procedure Get_Test_Packages_List (S_Data : Suites_Data_Type) 5662 is 5663 Declared_In_Generic : Boolean; 5664 Elem : Asis.Element; 5665 begin 5666 for K in S_Data.TR_List.First_Index .. S_Data.TR_List.Last_Index loop 5667 5668 Declared_In_Generic := False; 5669 Elem := S_Data.TR_List.Element (K).Original_Subp; 5670 loop 5671 exit when Is_Nil (Elem); 5672 5673 if Declaration_Kind (Elem) = A_Generic_Package_Declaration then 5674 Declared_In_Generic := True; 5675 exit; 5676 end if; 5677 5678 Elem := Enclosing_Element (Elem); 5679 end loop; 5680 5681 if not Declared_In_Generic then 5682 Test_Packages.Include 5683 (S_Data.TR_List.Element (K).Test_Package.all); 5684 end if; 5685 end loop; 5686 5687 for 5688 K in S_Data.ITR_List.First_Index .. S_Data.ITR_List.Last_Index 5689 loop 5690 Test_Packages.Include 5691 (S_Data.ITR_List.Element (K).Test_Package.all); 5692 end loop; 5693 end Get_Test_Packages_List; 5694 5695 function Get_Suite_Components 5696 (S_Data : Suites_Data_Type; 5697 Package_Name : String) 5698 return GNATtest.Harness.Generator.Data_Holder 5699 is 5700 Suite_Data : GNATtest.Harness.Generator.Data_Holder; 5701 Test_Routine : GNATtest.Harness.Generator.Test_Routine_Info; 5702 TT : GNATtest.Harness.Generator.Test_Type_Info; 5703 TR_E : GNATtest.Harness.Generator.Test_Routine_Info_Enhanced; 5704 5705 package Test_Type_Origins is new 5706 Ada.Containers.Vectors (Positive, Asis.Element, Is_Equal); 5707 use Test_Type_Origins; 5708 5709 TT_Origins : Test_Type_Origins.Vector; 5710 -- Used to set test type numbers. 5711 5712 Original_Type : Asis.Element; 5713 5714 Type_Found : Boolean; 5715 begin 5716 5717 Suite_Data.Test_Unit_Full_Name := new String'(Package_Name); 5718 5719 for 5720 K in S_Data.Test_Types.First_Index .. S_Data.Test_Types.Last_Index 5721 loop 5722 5723 if 5724 S_Data.Test_Types.Element (K).Test_Package.all = Package_Name 5725 then 5726 TT := S_Data.Test_Types.Element (K).TT_Info; 5727 TT.Tested_Type := S_Data.Test_Types.Element (K).Original_Type; 5728 Suite_Data.Test_Types.Append (TT); 5729 TT_Origins.Append (S_Data.Test_Types.Element (K).Original_Type); 5730 end if; 5731 end loop; 5732 5733 for K in S_Data.TR_List.First_Index .. S_Data.TR_List.Last_Index loop 5734 5735 if S_Data.TR_List.Element (K).Test_Package.all = Package_Name then 5736 5737 Test_Routine := S_Data.TR_List.Element (K).TR_Info; 5738 5739 -- Setting test type number; 5740 5741 Original_Type := S_Data.TR_List.Element (K).Original_Type; 5742 Type_Found := False; 5743 5744 for L in TT_Origins.First_Index .. TT_Origins.Last_Index loop 5745 if Is_Equal (TT_Origins.Element (L), Original_Type) then 5746 Test_Routine.Test_Type_Numb := L; 5747 Type_Found := True; 5748 exit; 5749 end if; 5750 end loop; 5751 5752 if Type_Found then 5753 Suite_Data.TR_List.Append (Test_Routine); 5754 Suite_Data.Good_For_Suite := True; 5755 end if; 5756 end if; 5757 end loop; 5758 5759 for 5760 K in S_Data.ITR_List.First_Index .. S_Data.ITR_List.Last_Index 5761 loop 5762 if S_Data.ITR_List.Element (K).Test_Package.all = Package_Name then 5763 5764 TR_E := S_Data.ITR_List.Element (K).TR_Info; 5765 5766 -- Setting up test type number 5767 5768 Original_Type := S_Data.ITR_List.Element (K).Original_Type; 5769 Type_Found := False; 5770 5771 for L in TT_Origins.First_Index .. TT_Origins.Last_Index loop 5772 if Is_Equal (TT_Origins.Element (L), Original_Type) then 5773 TR_E.Test_Type_Numb := L; 5774 Type_Found := True; 5775 exit; 5776 end if; 5777 end loop; 5778 5779 if Type_Found then 5780 Suite_Data.ITR_List.Append (TR_E); 5781 Suite_Data.Good_For_Suite := True; 5782 end if; 5783 5784 end if; 5785 end loop; 5786 5787 for 5788 K in S_Data.LTR_List.First_Index .. S_Data.LTR_List.Last_Index 5789 loop 5790 if S_Data.LTR_List.Element (K).Test_Package.all = Package_Name then 5791 5792 TR_E := S_Data.LTR_List.Element (K).TR_Info; 5793 5794 -- Setting up test type number 5795 5796 Original_Type := S_Data.LTR_List.Element (K).Original_Type; 5797 Type_Found := False; 5798 5799 for L in TT_Origins.First_Index .. TT_Origins.Last_Index loop 5800 if Is_Equal (TT_Origins.Element (L), Original_Type) then 5801 TR_E.Test_Type_Numb := L; 5802 Type_Found := True; 5803 exit; 5804 end if; 5805 end loop; 5806 5807 if Type_Found then 5808 TR_E.Tested_Type := Original_Type; 5809 Suite_Data.LTR_List.Append (TR_E); 5810 Suite_Data.Good_For_Substitution := True; 5811 end if; 5812 end if; 5813 end loop; 5814 5815 TT_Origins.Clear; 5816 5817 return Suite_Data; 5818 5819 end Get_Suite_Components; 5820 5821 begin 5822 5823 Source_Name := 5824 new String'(To_String (Text_Name (The_Unit))); 5825 5826 Report_Source (Source_Name.all); 5827 5828 Gather_Data (The_Unit, Data, Suite_Data_List, Apropriate_Source); 5829 5830 if Apropriate_Source then 5831 5832 -- First, create stubs if needed. This will allow to import stub_data 5833 -- packages into test packages only for actually stubbed dependencies 5834 if Stub_Mode_ON then 5835 Process_Stubs (Data.Units_To_Stub); 5836 end if; 5837 5838 declare 5839 F : File_Array_Access; 5840 begin 5841 Append 5842 (F, 5843 GNATCOLL.VFS.Create 5844 (+(Get_Source_Output_Dir (Source_Name.all)))); 5845 Create_Dirs (F); 5846 end; 5847 5848 if Substitution_Suite then 5849 Gather_Substitution_Data (Suite_Data_List); 5850 end if; 5851 if Data.Data_Kind = Declaration_Data then 5852 Generate_Nested_Hierarchy (Data); 5853 Generate_Test_Package (Data); 5854 if Generate_Separates then 5855 Generate_Skeletons (Data); 5856 end if; 5857 5858 Get_Test_Packages_List (Suite_Data_List); 5859 Cur := Test_Packages.First; 5860 loop 5861 exit when Cur = String_Set.No_Element; 5862 5863 Suite_Data := Get_Suite_Components 5864 (Suite_Data_List, 5865 String_Set.Element (Cur)); 5866 5867 if Suite_Data.Good_For_Suite then 5868 if not Stub_Mode_ON and then not Separate_Drivers then 5869 5870 GNATtest.Harness.Generator.Generate_Suite (Suite_Data); 5871 5872 if Suite_Data.Good_For_Substitution then 5873 GNATtest.Harness.Generator. 5874 Generate_Substitution_Suite_From_Tested (Suite_Data); 5875 end if; 5876 end if; 5877 end if; 5878 5879 String_Set.Next (Cur); 5880 end loop; 5881 5882 if Stub_Mode_ON or else Separate_Drivers then 5883 5884 Cur := Test_Packages.First; 5885 while Cur /= String_Set.No_Element loop 5886 5887 Suite_Data := Get_Suite_Components 5888 (Suite_Data_List, 5889 String_Set.Element (Cur)); 5890 5891 if Suite_Data.Good_For_Suite then 5892 GNATtest.Harness.Generator.Generate_Test_Drivers 5893 (Suite_Data, 5894 Data.Unit_File_Name.all, 5895 Data.Units_To_Stub); 5896 end if; 5897 if Suite_Data.Good_For_Substitution 5898 and then not Driver_Per_Unit 5899 then 5900 GNATtest.Harness.Generator. 5901 Generate_Substitution_Test_Drivers (Suite_Data); 5902 end if; 5903 String_Set.Next (Cur); 5904 end loop; 5905 end if; 5906 5907 end if; 5908 if Data.Data_Kind = Instantiation then 5909 Generate_Test_Package_Instantiation (Data); 5910 end if; 5911 Set_Source_Status (Source_Name.all, Processed); 5912 end if; 5913 5914 if Data.Data_Kind = Declaration_Data then 5915 Clear (Data.Type_Data_List); 5916 Clear (Data.Subp_List); 5917 Clear (Data.Package_Data_List); 5918 Clear (Data.Subp_Name_Frequency); 5919 Clear (Data.Units_To_Stub); 5920 end if; 5921 5922 Suite_Data.Test_Types.Clear; 5923 Suite_Data.TR_List.Clear; 5924 Suite_Data.ITR_List.Clear; 5925 Suite_Data.LTR_List.Clear; 5926 5927 end Process_Source; 5928 5929 ----------------------- 5930 -- Process_Sources -- 5931 ----------------------- 5932 5933 procedure Process_Sources is 5934 Source_Name : String_Access; 5935 Successful_Initialization : Boolean := True; 5936 The_Unit : Asis.Compilation_Unit; 5937 5938 procedure Iterate_Sources (All_CU : Asis.Compilation_Unit_List); 5939 -- iterates through compilation units and checks if they are present in 5940 -- the source table, if so - processes them. 5941 5942 procedure Iterate_Sources (All_CU : Asis.Compilation_Unit_List) is 5943 File_Name : String_Access; 5944 begin 5945 5946 for J in All_CU'Range loop 5947 5948 if Unit_Origin (All_CU (J)) = An_Application_Unit then 5949 File_Name := 5950 new String'(To_String (Text_Name (All_CU (J)))); 5951 5952 if 5953 Source_Present (File_Name.all) and then 5954 Get_Source_Status (File_Name.all) = Waiting and then 5955 not Has_Limited_View_Only (All_CU (J)) 5956 then 5957 Process_Source (All_CU (J)); 5958 end if; 5959 5960 Free (File_Name); 5961 end if; 5962 end loop; 5963 5964 end Iterate_Sources; 5965 5966 Cur : Tests_Per_Unit.Cursor; 5967 5968 begin 5969 5970 Asis.Implementation.Initialize ("-asis05 -ws"); 5971 5972 loop 5973 Source_Name := new String'(Next_Non_Processed_Source); 5974 exit when Source_Name.all = ""; 5975 5976 if 5977 Stub_Mode_ON and then Get_Source_Body (Source_Name.all) /= "" 5978 then 5979 Successful_Initialization := 5980 Initialize_Context (Get_Source_Body (Source_Name.all)); 5981 5982 if 5983 Get_Source_Status 5984 (Get_Source_Body (Source_Name.all)) = Bad_Content 5985 then 5986 -- If correspondig body is bad, the spec is also not usable 5987 -- for stubbing. 5988 5989 Set_Source_Status (Source_Name.all, Bad_Content); 5990 end if; 5991 else 5992 Successful_Initialization := Initialize_Context (Source_Name.all); 5993 end if; 5994 5995 if Successful_Initialization then 5996 5997 if Stub_Mode_ON then 5998 5999 if Get_Source_Body (Source_Name.all) = "" then 6000 The_Unit := Main_Unit_In_Current_Tree (The_Context); 6001 else 6002 The_Unit := 6003 Corresponding_Declaration 6004 (Main_Unit_In_Current_Tree (The_Context)); 6005 end if; 6006 6007 -- processing main unit 6008 Process_Source (The_Unit); 6009 6010 -- Iterate_Sources won't work in stub mode since we need 6011 -- bodies corresponding to argument specs (if they exist), 6012 -- thus we need to recreate the tree almost each time and 6013 -- little to none optimisation can be gained with 6014 -- Iterate_Sources. 6015 6016 else 6017 The_Unit := Main_Unit_In_Current_Tree (The_Context); 6018 6019 -- processing main unit 6020 Process_Source (The_Unit); 6021 6022 -- processing others in same context 6023 Iterate_Sources 6024 (Asis.Compilation_Units.Compilation_Units (The_Context)); 6025 end if; 6026 6027 end if; 6028 6029 Source_Clean_Up; 6030 Context_Clean_Up; 6031 Free (Source_Name); 6032 end loop; 6033 6034 Asis.Implementation.Finalize; 6035 6036 Generate_Project_File; 6037 Generate_Common_File; 6038 Generate_Mapping_File; 6039 6040 declare 6041 Cur_Stor : Generic_Package_Storage.Cursor := 6042 Gen_Package_Storage.First; 6043 GP : Generic_Package; 6044 begin 6045 while Cur_Stor /= Generic_Package_Storage.No_Element loop 6046 GP := Generic_Package_Storage.Element (Cur_Stor); 6047 if not GP.Has_Instantiation then 6048 Report_Std 6049 (GP.Sloc.all 6050 & ": warning: no instance of " 6051 & GP.Name.all); 6052 Report_Std 6053 (" corresponding tests are not included into harness"); 6054 end if; 6055 6056 Next (Cur_Stor); 6057 end loop; 6058 end; 6059 6060 if Verbose then 6061 Cur := Test_Info.First; 6062 loop 6063 exit when Cur = Tests_Per_Unit.No_Element; 6064 6065 Report_Std 6066 (Natural'Image (Tests_Per_Unit.Element (Cur)) & 6067 " testable subprograms in " & 6068 Base_Name (Tests_Per_Unit.Key (Cur))); 6069 6070 Tests_Per_Unit.Next (Cur); 6071 end loop; 6072 6073 Test_Info.Clear; 6074 Report_Std 6075 ("gnattest:" & 6076 Natural'Image (All_Tests_Counter) & 6077 " testable subprogram(s) processed"); 6078 Report_Std 6079 ("gnattest:" & 6080 Natural'Image (New_Tests_Counter) & 6081 " new skeleton(s) generated"); 6082 end if; 6083 6084 if Stub_Mode_ON then 6085 GNATtest.Harness.Generator.Generate_Stub_Test_Driver_Projects; 6086 elsif Separate_Drivers then 6087 GNATtest.Harness.Generator.Generate_Test_Driver_Projects; 6088 else 6089 GNATtest.Harness.Generator.Test_Runner_Generator; 6090 GNATtest.Harness.Generator.Project_Creator; 6091 end if; 6092 6093 end Process_Sources; 6094 6095 ------------------- 6096 -- Process_Stubs -- 6097 ------------------- 6098 6099 procedure Process_Stubs (List : Asis_Element_List.List) 6100 is 6101 Cur : Asis_Element_List.Cursor; 6102 CU : Compilation_Unit; 6103 Str : String_Access; 6104 begin 6105 if Is_Empty (List) then 6106 return; 6107 end if; 6108 6109 -- Once we change the context, contents of List won't make sense. 6110 Cur := List.First; 6111 while Cur /= Asis_Element_List.No_Element loop 6112 6113 CU := Enclosing_Compilation_Unit (Asis_Element_List.Element (Cur)); 6114 6115 Str := new String'(To_String (Text_Name (CU))); 6116 6117 if Get_Source_Body (Str.all) /= "" then 6118 if not Source_Stubbed (Str.all) then 6119 GNATtest.Stub.Generator.Process_Unit 6120 (CU, 6121 Get_Source_Stub_Dir (Str.all) 6122 & Directory_Separator 6123 & Base_Name (Get_Source_Body (Str.all)), 6124 Get_Source_Stub_Dir (Str.all) 6125 & Directory_Separator 6126 & Get_Source_Stub_Data_Spec (Str.all), 6127 Get_Source_Stub_Dir (Str.all) 6128 & Directory_Separator 6129 & Get_Source_Stub_Data_Body (Str.all)); 6130 Mark_Sourse_Stubbed (Str.all); 6131 end if; 6132 end if; 6133 6134 Free (Str); 6135 6136 Next (Cur); 6137 end loop; 6138 6139 end Process_Stubs; 6140 6141 --------------------------------- 6142 -- Put_Closing_Comment_Section -- 6143 --------------------------------- 6144 6145 procedure Put_Closing_Comment_Section 6146 (Subp : Subp_Info; 6147 Overloading_N : Natural; 6148 Commented_Out : Boolean := False; 6149 Use_Short_Name : Boolean := True) 6150 is 6151 Overloading_Prefix : String_Access; 6152 begin 6153 6154 if Overloading_N /= 0 then 6155 if Subp.Is_Overloaded then 6156 if Use_Short_Name then 6157 Overloading_Prefix := new String'("1_"); 6158 else 6159 Overloading_Prefix := new String' 6160 (Trim (Natural'Image (Overloading_N), Both) & "_"); 6161 end if; 6162 else 6163 Overloading_Prefix := new String'(""); 6164 end if; 6165 end if; 6166 6167 S_Put (0, "-- begin read only"); 6168 New_Line_Count; 6169 6170 if Commented_Out then 6171 S_Put 6172 (3, 6173 "-- end " 6174 & Test_Routine_Prefix 6175 & Subp.Subp_Text_Name.all 6176 & (if Subp.Has_TC_Info 6177 then "_" & Sanitize_TC_Name (Subp.TC_Info.Name.all) 6178 else "") 6179 & ";"); 6180 else 6181 S_Put 6182 (3, 6183 "end " 6184 & Test_Routine_Prefix 6185 & Overloading_Prefix.all 6186 & Subp.Subp_Text_Name.all 6187 & (if Subp.Has_TC_Info 6188 then "_" & Sanitize_TC_Name (Subp.TC_Info.Name.all) 6189 else "") 6190 & ";"); 6191 end if; 6192 New_Line_Count; 6193 S_Put (0, "-- end read only"); 6194 New_Line_Count; 6195 6196 end Put_Closing_Comment_Section; 6197 6198 --------------------------------- 6199 -- Put_Opening_Comment_Section -- 6200 --------------------------------- 6201 6202 procedure Put_Opening_Comment_Section 6203 (Subp : Subp_Info; 6204 Overloading_N : Natural; 6205 Commented_Out : Boolean := False; 6206 Use_Short_Name : Boolean := True; 6207 Type_Name : String := "") 6208 is 6209 Hash_Length_Used : constant := 15; 6210 Hash_First : constant Integer := Subp.Subp_Full_Hash'First; 6211 Hash_Last : constant Integer := 6212 Subp.Subp_Full_Hash'First + Hash_Length_Used; 6213 6214 Overloading_Prefix : String_Access; 6215 begin 6216 6217 if Overloading_N /= 0 then 6218 if Subp.Is_Overloaded then 6219 if Use_Short_Name then 6220 Overloading_Prefix := new String'("1_"); 6221 else 6222 Overloading_Prefix := new String' 6223 (Trim (Natural'Image (Overloading_N), Both) & "_"); 6224 end if; 6225 else 6226 Overloading_Prefix := new String'(""); 6227 end if; 6228 end if; 6229 6230 New_Line_Count; 6231 S_Put (0, "-- begin read only"); 6232 New_Line_Count; 6233 6234 if Subp.Corresp_Type = 0 then 6235 if Commented_Out then 6236 S_Put 6237 (3, 6238 "-- procedure " 6239 & Test_Routine_Prefix 6240 & Subp.Subp_Text_Name.all 6241 & (if Subp.Has_TC_Info 6242 then "_" & Sanitize_TC_Name (Subp.TC_Info.Name.all) 6243 else "") 6244 & " (Gnattest_T : in out Test);"); 6245 New_Line_Count; 6246 S_Put 6247 (3, 6248 "-- procedure " 6249 & Subp.Subp_Mangle_Name.all 6250 & " (Gnattest_T : in out Test) renames " 6251 & Test_Routine_Prefix 6252 & Subp.Subp_Text_Name.all 6253 & (if Subp.Has_TC_Info 6254 then "_" & Sanitize_TC_Name (Subp.TC_Info.Name.all) 6255 else "") 6256 & ";"); 6257 New_Line_Count; 6258 else 6259 S_Put 6260 (3, 6261 "procedure " 6262 & Test_Routine_Prefix 6263 & Overloading_Prefix.all 6264 & Subp.Subp_Text_Name.all 6265 & (if Subp.Has_TC_Info 6266 then "_" & Sanitize_TC_Name (Subp.TC_Info.Name.all) 6267 else "") 6268 & " (Gnattest_T : in out Test);"); 6269 New_Line_Count; 6270 S_Put 6271 (3, 6272 "procedure " 6273 & Subp.Subp_Mangle_Name.all 6274 & " (Gnattest_T : in out Test) renames " 6275 & Test_Routine_Prefix 6276 & Overloading_Prefix.all 6277 & Subp.Subp_Text_Name.all 6278 & (if Subp.Has_TC_Info 6279 then "_" & Sanitize_TC_Name (Subp.TC_Info.Name.all) 6280 else "") 6281 & ";"); 6282 New_Line_Count; 6283 end if; 6284 else 6285 if Commented_Out then 6286 S_Put 6287 (3, 6288 "-- procedure " 6289 & Test_Routine_Prefix 6290 & Subp.Subp_Text_Name.all 6291 & (if Subp.Has_TC_Info 6292 then "_" & Sanitize_TC_Name (Subp.TC_Info.Name.all) 6293 else "") 6294 & " (Gnattest_T : in out Test_" 6295 & Type_Name 6296 & ");"); 6297 New_Line_Count; 6298 S_Put 6299 (3, 6300 "-- procedure " 6301 & Subp.Subp_Mangle_Name.all 6302 & " (Gnattest_T : in out Test_" 6303 & Type_Name 6304 & ") renames " 6305 & Test_Routine_Prefix 6306 & Subp.Subp_Text_Name.all 6307 & (if Subp.Has_TC_Info 6308 then "_" & Sanitize_TC_Name (Subp.TC_Info.Name.all) 6309 else "") 6310 & ";"); 6311 New_Line_Count; 6312 else 6313 S_Put 6314 (3, 6315 "procedure " 6316 & Test_Routine_Prefix 6317 & Overloading_Prefix.all 6318 & Subp.Subp_Text_Name.all 6319 & (if Subp.Has_TC_Info 6320 then "_" & Sanitize_TC_Name (Subp.TC_Info.Name.all) 6321 else "") 6322 & " (Gnattest_T : in out Test_" 6323 & Type_Name 6324 & ");"); 6325 New_Line_Count; 6326 S_Put 6327 (3, 6328 "procedure " 6329 & Subp.Subp_Mangle_Name.all 6330 & " (Gnattest_T : in out Test_" 6331 & Type_Name 6332 & ") renames " 6333 & Test_Routine_Prefix 6334 & Overloading_Prefix.all 6335 & Subp.Subp_Text_Name.all 6336 & (if Subp.Has_TC_Info 6337 then "_" & Sanitize_TC_Name (Subp.TC_Info.Name.all) 6338 else "") 6339 & ";"); 6340 New_Line_Count; 6341 end if; 6342 end if; 6343 6344 S_Put 6345 (0, 6346 "-- id:" 6347 & Hash_Version 6348 & "/" 6349 & Subp.Subp_Full_Hash (Hash_First .. Hash_Last) 6350 & "/" 6351 & Subp.Subp_Text_Name.all 6352 & "/" 6353 & (if Use_Short_Name then "1" else "0") 6354 & "/" 6355 & (if Commented_Out then "1" else "0") 6356 & "/"); 6357 if Subp.Has_TC_Info then 6358 S_Put 6359 (0, 6360 Sanitize_TC_Name (Subp.TC_Info.Name.all) 6361 & "/"); 6362 end if; 6363 New_Line_Count; 6364 6365 if Commented_Out then 6366 S_Put 6367 (3, 6368 "-- procedure " 6369 & Test_Routine_Prefix 6370 & Subp.Subp_Text_Name.all 6371 & (if Subp.Has_TC_Info 6372 then "_" & Sanitize_TC_Name (Subp.TC_Info.Name.all) 6373 else "") 6374 & " (Gnattest_T : in out "); 6375 else 6376 S_Put 6377 (3, 6378 "procedure " 6379 & Test_Routine_Prefix 6380 & Overloading_Prefix.all 6381 & Subp.Subp_Text_Name.all 6382 & (if Subp.Has_TC_Info 6383 then "_" & Sanitize_TC_Name (Subp.TC_Info.Name.all) 6384 else "") 6385 & " (Gnattest_T : in out "); 6386 end if; 6387 if Subp.Corresp_Type = 0 then 6388 S_Put (0, "Test) is"); 6389 else 6390 S_Put 6391 (0, 6392 "Test_" 6393 & Type_Name 6394 & ") is"); 6395 end if; 6396 6397 New_Line_Count; 6398 6399 if not Commented_Out then 6400 6401 -- we cannot relate to any sloc in case of a dangling test 6402 6403 if not Omit_Sloc then 6404 S_Put 6405 (3, 6406 "-- " 6407 & Base_Name 6408 (To_String 6409 (Text_Name 6410 (Enclosing_Compilation_Unit 6411 (Subp.Subp_Declaration)))) 6412 & ":" 6413 & Trim 6414 (Integer'Image 6415 (First_Line_Number (Subp.Subp_Declaration)), Both) 6416 & ":" 6417 & Trim 6418 (Integer'Image (First_Column_Number (Subp.Subp_Declaration)), 6419 Both) 6420 & ":" 6421 & Subp.Subp_Name_Image.all); 6422 New_Line_Count; 6423 end if; 6424 6425 if Subp.Has_TC_Info then 6426 Put_Wrapper_Rename (6, Subp); 6427 end if; 6428 end if; 6429 6430 S_Put (0, "-- end read only"); 6431 New_Line_Count; 6432 6433 end Put_Opening_Comment_Section; 6434 6435 ------------------------ 6436 -- Put_Wrapper_Rename -- 6437 ------------------------ 6438 6439 procedure Put_Wrapper_Rename (Span : Natural; Current_Subp : Subp_Info) is 6440 begin 6441 6442 case Declaration_Kind (Current_Subp.Subp_Declaration) is 6443 when A_Function_Declaration | 6444 An_Expression_Function_Declaration => 6445 S_Put 6446 (Span, 6447 "function " & 6448 Current_Subp.Subp_Name_Image.all); 6449 6450 declare 6451 Params : constant 6452 Asis.Parameter_Specification_List := 6453 Parameter_Profile 6454 (Current_Subp.Subp_Declaration); 6455 6456 Result : constant Asis.Element := 6457 Result_Profile (Current_Subp.Subp_Declaration); 6458 6459 Result_Image : constant String := 6460 Trim (To_String (Element_Image (Result)), 6461 Both); 6462 begin 6463 6464 if Params'Length /= 0 then 6465 S_Put (1, "("); 6466 for I in Params'Range loop 6467 S_Put 6468 (0, 6469 Trim 6470 (To_String 6471 (Element_Image (Params (I))), 6472 Both)); 6473 if I = Params'Last then 6474 S_Put (0, ")"); 6475 else 6476 S_Put (0, "; "); 6477 end if; 6478 end loop; 6479 end if; 6480 6481 S_Put (1, "return " & Result_Image); 6482 end; 6483 6484 when A_Procedure_Declaration => 6485 S_Put 6486 (3, 6487 "procedure " & 6488 Current_Subp.Subp_Name_Image.all); 6489 6490 declare 6491 Params : constant 6492 Asis.Parameter_Specification_List := 6493 Parameter_Profile 6494 (Current_Subp.Subp_Declaration); 6495 begin 6496 6497 if Params'Length /= 0 then 6498 S_Put (1, "("); 6499 for I in Params'Range loop 6500 S_Put 6501 (0, 6502 Trim 6503 (To_String 6504 (Element_Image (Params (I))), 6505 Both)); 6506 if I = Params'Last then 6507 S_Put (0, ")"); 6508 else 6509 S_Put (0, "; "); 6510 end if; 6511 end loop; 6512 end if; 6513 end; 6514 6515 when others => null; 6516 6517 end case; 6518 6519 S_Put 6520 (1, 6521 "renames " & 6522 Wrapper_Prefix & 6523 Current_Subp.Subp_Mangle_Name.all & 6524 ";"); 6525 Put_New_Line; 6526 end Put_Wrapper_Rename; 6527 6528 ---------------------- 6529 -- Sanitize_TC_Name -- 6530 ---------------------- 6531 6532 function Sanitize_TC_Name (TC_Name : String) return String 6533 is 6534 Name : String := Trim (TC_Name, Both); 6535 6536 Tmp : String_Access := new String'(""); 6537 Buff : String_Access; 6538 6539 Underscore : Boolean := True; 6540 begin 6541 6542 for I in Name'Range loop 6543 6544 if Name (I) = ' ' then 6545 Name (I) := '_'; 6546 end if; 6547 6548 end loop; 6549 6550 for I in Name'Range loop 6551 6552 if Underscore then 6553 if Name (I) /= '_' then 6554 Underscore := False; 6555 if Is_Letter (Name (I)) or else Is_Digit (Name (I)) then 6556 Buff := new String'(Tmp.all & Name (I)); 6557 Free (Tmp); 6558 Tmp := Buff; 6559 Buff := null; 6560 end if; 6561 end if; 6562 else 6563 if 6564 Is_Letter (Name (I)) 6565 or else Is_Digit (Name (I)) 6566 or else Name (I) = '_' 6567 then 6568 Buff := new String'(Tmp.all & Name (I)); 6569 Free (Tmp); 6570 Tmp := Buff; 6571 Buff := null; 6572 if Name (I) = '_' then 6573 Underscore := True; 6574 end if; 6575 end if; 6576 end if; 6577 6578 end loop; 6579 6580 return To_Lower (Tmp.all); 6581 end Sanitize_TC_Name; 6582 6583 ----------------------- 6584 -- Source_Clean_Up -- 6585 ----------------------- 6586 6587 procedure Source_Clean_Up is 6588 Success : Boolean; 6589 begin 6590 if Last_Context_Name = null then 6591 return; 6592 end if; 6593 6594 Delete_File (Last_Context_Name.all & ".adt", Success); 6595 if not Success then 6596 Report_Std ("gnattest: cannot delete " & 6597 Last_Context_Name.all & ".adt"); 6598 end if; 6599 6600 Delete_File (Last_Context_Name.all & ".ali", Success); 6601 if not Success then 6602 Report_Std ("gnattest: cannot delete " & 6603 Last_Context_Name.all & ".ali"); 6604 end if; 6605 6606 Free (Last_Context_Name); 6607 end Source_Clean_Up; 6608 6609 ------------ 6610 -- Add_DT -- 6611 ------------ 6612 6613 procedure Add_DT 6614 (TP_List : in out TP_Mapping_List.List; 6615 TPtarg : String; 6616 Test_F : String; 6617 Line : Natural; 6618 Column : Natural) 6619 is 6620 TP : TP_Mapping; 6621 TD : DT_Mapping; 6622 6623 TP_Cur : TP_Mapping_List.Cursor := TP_List.First; 6624 begin 6625 6626 TD.File := new String'(Test_F); 6627 TD.Line := Line; 6628 TD.Column := Column; 6629 6630 loop 6631 exit when TP_Cur = TP_Mapping_List.No_Element; 6632 6633 if TP_Mapping_List.Element (TP_Cur).TP_Name.all = TPtarg then 6634 exit; 6635 end if; 6636 6637 TP_Mapping_List.Next (TP_Cur); 6638 end loop; 6639 6640 TP := TP_Mapping_List.Element (TP_Cur); 6641 TP.DT_List.Append (TD); 6642 TP_List.Replace_Element (TP_Cur, TP); 6643 6644 end Add_DT; 6645 6646 ------------ 6647 -- Add_TR -- 6648 ------------ 6649 6650 procedure Add_TR 6651 (TP_List : in out TP_Mapping_List.List; 6652 TPtarg : String; 6653 Test_F : String; 6654 Test_T : String; 6655 Subp : Subp_Info; 6656 TR_Line : Natural := 1) 6657 is 6658 TC : TC_Mapping; 6659 TR : TR_Mapping; 6660 TP : TP_Mapping; 6661 6662 TR_Cur : TR_Mapping_List.Cursor; 6663 TP_Cur : TP_Mapping_List.Cursor := TP_List.First; 6664 6665 Subp_Span : constant Asis.Text.Span := 6666 Element_Span (Subp.Subp_Declaration); 6667 TC_Span : constant Asis.Text.Span := 6668 Element_Span (Subp.TC_Info.Elem); 6669 begin 6670 6671 loop 6672 exit when TP_Cur = TP_Mapping_List.No_Element; 6673 6674 if TP_Mapping_List.Element (TP_Cur).TP_Name.all = TPtarg then 6675 exit; 6676 end if; 6677 6678 TP_Mapping_List.Next (TP_Cur); 6679 end loop; 6680 6681 if TP_Cur = TP_Mapping_List.No_Element then 6682 TP.TP_Name := new String'(TPtarg); 6683 TR.TR_Name := new String'(Subp.Subp_Text_Name.all); 6684 TR.Line := Subp_Span.First_Line; 6685 TR.Column := Subp_Span.First_Column; 6686 if Subp.Has_TC_Info then 6687 TC.TC_Name := new String'(Subp.TC_Info.Name.all); 6688 TC.Line := TC_Span.First_Line; 6689 TC.Column := TC_Span.First_Column; 6690 TC.Test := new String'(Test_F); 6691 TC.Test_Time := new String'(Test_T); 6692 TC.TR_Line := TR_Line; 6693 TR.TC_List.Append (TC); 6694 else 6695 TR.Test := new String'(Test_F); 6696 TR.Test_Time := new String'(Test_T); 6697 TR.TR_Line := TR_Line; 6698 end if; 6699 6700 TP.TR_List.Append (TR); 6701 TP_List.Append (TP); 6702 6703 return; 6704 end if; 6705 6706 TP := TP_Mapping_List.Element (TP_Cur); 6707 6708 TR_Cur := TP.TR_List.First; 6709 loop 6710 exit when TR_Cur = TR_Mapping_List.No_Element; 6711 6712 if 6713 TR_Mapping_List.Element (TR_Cur).Line = Subp_Span.First_Line and 6714 TR_Mapping_List.Element (TR_Cur).Column = Subp_Span.First_Column 6715 then 6716 exit; 6717 end if; 6718 6719 TR_Mapping_List.Next (TR_Cur); 6720 end loop; 6721 6722 if TR_Cur = TR_Mapping_List.No_Element then 6723 6724 TR.TR_Name := new String'(Subp.Subp_Text_Name.all); 6725 TR.Line := Subp_Span.First_Line; 6726 TR.Column := Subp_Span.First_Column; 6727 if Subp.Has_TC_Info then 6728 TC.TC_Name := new String'(Subp.TC_Info.Name.all); 6729 TC.Line := TC_Span.First_Line; 6730 TC.Column := TC_Span.First_Column; 6731 TC.Test := new String'(Test_F); 6732 TC.Test_Time := new String'(Test_T); 6733 TC.TR_Line := TR_Line; 6734 TR.TC_List.Append (TC); 6735 else 6736 TR.Test := new String'(Test_F); 6737 TR.Test_Time := new String'(Test_T); 6738 TR.TR_Line := TR_Line; 6739 end if; 6740 6741 TP.TR_List.Append (TR); 6742 TP_List.Replace_Element (TP_Cur, TP); 6743 6744 return; 6745 end if; 6746 6747 TR := TR_Mapping_List.Element (TR_Cur); 6748 6749 -- The only way that there is same subprogram already is when it has 6750 -- test_cases. So no need to check if it has TC_Info. 6751 TC.TC_Name := new String'(Subp.TC_Info.Name.all); 6752 TC.Line := TC_Span.First_Line; 6753 TC.Column := TC_Span.First_Column; 6754 TC.Test := new String'(Test_F); 6755 TC.Test_Time := new String'(Test_T); 6756 TC.TR_Line := TR_Line; 6757 TR.TC_List.Append (TC); 6758 6759 TP.TR_List.Replace_Element (TR_Cur, TR); 6760 TP_List.Replace_Element (TP_Cur, TP); 6761 6762 end Add_TR; 6763 6764 ----------------------- 6765 -- Test_Types_Linked -- 6766 ----------------------- 6767 6768 function Test_Types_Linked 6769 (Inheritance_Root_Type : Asis.Element; 6770 Inheritance_Final_Type : Asis.Element) 6771 return Boolean 6772 is 6773 Elem : Asis.Element := Inheritance_Final_Type; 6774 Elem2 : Asis.Element; 6775 begin 6776 6777 if 6778 Definition_Kind 6779 (Type_Declaration_View 6780 (Inheritance_Root_Type)) = A_Private_Extension_Definition 6781 or else 6782 Declaration_Kind 6783 (Inheritance_Root_Type) = A_Private_Type_Declaration 6784 then 6785 Elem2 := Corresponding_Type_Declaration (Inheritance_Root_Type); 6786 else 6787 Elem2 := Inheritance_Root_Type; 6788 end if; 6789 6790 loop 6791 if Is_Fully_Private (Elem) then 6792 return False; 6793 end if; 6794 6795 exit when 6796 Is_Equal (Elem, Elem2) or else 6797 Is_Equal (Elem, (Corresponding_Type_Declaration (Elem2))); 6798 Elem := Parent_Type_Declaration (Elem); 6799 end loop; 6800 return True; 6801 end Test_Types_Linked; 6802 6803 -------------------- 6804 -- Uncomment_Line -- 6805 -------------------- 6806 6807 function Uncomment_Line (S : String) return String is 6808 begin 6809 if S = "-- " then 6810 return ""; 6811 end if; 6812 6813 if S'Length < 5 then 6814 return S; 6815 end if; 6816 6817 if S (S'First .. S'First + 3) = "-- " then 6818 return S (S'First + 4 .. S'Last); 6819 end if; 6820 6821 return S; 6822 end Uncomment_Line; 6823 6824end GNATtest.Skeleton.Generator; 6825