1-- C761003.A 2-- 3-- Grant of Unlimited Rights 4-- 5-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, 6-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 7-- unlimited rights in the software and documentation contained herein. 8-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making 9-- this public release, the Government intends to confer upon all 10-- recipients unlimited rights equal to those held by the Government. 11-- These rights include rights to use, duplicate, release or disclose the 12-- released technical data and computer software in whole or in part, in 13-- any manner and for any purpose whatsoever, and to have or permit others 14-- to do so. 15-- 16-- DISCLAIMER 17-- 18-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR 19-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED 20-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE 21-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE 22-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A 23-- PARTICULAR PURPOSE OF SAID MATERIAL. 24--* 25-- 26-- OBJECTIVE: 27-- Check that an object of a controlled type is finalized when the 28-- enclosing master is complete. 29-- Check this for controlled types where the derived type has a 30-- discriminant. 31-- Check this for subprograms of abstract types derived from the 32-- types in Ada.Finalization. 33-- 34-- Check that finalization of controlled objects is 35-- performed in the correct order. In particular, check that if 36-- multiple objects of controlled types are declared immediately 37-- within the same declarative part then type are finalized in the 38-- reverse order of their creation. 39-- 40-- TEST DESCRIPTION: 41-- This test checks these conditions for subprograms and 42-- block statements; both variables and constants of controlled 43-- types; cases of a controlled component of a record type, as 44-- well as an array with controlled components. 45-- 46-- The base controlled types used for the test are defined 47-- with a character discriminant. The initialize procedure for 48-- the types will record the order of creation in a globally 49-- accessible array, the finalize procedure for the types will call 50-- TCTouch with that tag character. The test can then check that 51-- the order of finalization is indeed the reverse of the order of 52-- creation (assuming that the implementation calls Initialize in 53-- the order that the objects are created). 54-- 55-- 56-- CHANGE HISTORY: 57-- 06 Dec 94 SAIC ACVC 2.0 58-- 02 Nov 95 SAIC ACVC 2.0.1 59-- 60--! 61 62------------------------------------------------------------ C761003_Support 63 64package C761003_Support is 65 66 function Pick_Char return Character; 67 -- successive calls to Pick_Char return distinct characters which may 68 -- be assigned to objects to track an order sequence. These characters 69 -- are then used in calls to TCTouch.Touch. 70 71 procedure Validate(Initcount : Natural; 72 Testnumber : Natural; 73 Check_Order : Boolean := True); 74 -- does a little extra processing prior to calling TCTouch.Validate, 75 -- specifically, it reverses the stored string of characters, and checks 76 -- for a correct count. 77 78 Inits_Order : String(1..255); 79 Inits_Called : Natural := 0; 80 81end C761003_Support; 82 83-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- 84 85with Report; 86with TCTouch; 87package body C761003_Support is 88 type Pick_Rotation is mod 52; 89 type Pick_String is array(Pick_Rotation) of Character; 90 91 From : constant Pick_String := "ABCDEFGHIJKLMNOPQRSTUVWXYZ" 92 & "abcdefghijklmnopqrstuvwxyz"; 93 Recent_Pick : Pick_Rotation := Pick_Rotation'Last; 94 95 function Pick_Char return Character is 96 begin 97 Recent_Pick := Recent_Pick +1; 98 return From(Recent_Pick); 99 end Pick_Char; 100 101 function Invert(S:String) return String is 102 T: String(1..S'Length); 103 begin 104 for SI in reverse S'Range loop 105 T(S'Last - SI + 1) := S(SI); 106 end loop; 107 return T; 108 end Invert; 109 110 procedure Validate(Initcount : Natural; 111 Testnumber : Natural; 112 Check_Order : Boolean := True) is 113 Number : constant String := Natural'Image(Testnumber); 114 begin 115 if Inits_Called /= Initcount then 116 Report.Failed("Got" & Natural'Image(Inits_Called) & " inits, expected" 117 & Natural'Image(Initcount) & ", Subtest " & Number); 118 TCTouch.Flush; 119 else 120 TCTouch.Validate( 121 Invert(Inits_Order(1..Inits_Called)), 122 "Subtest " & Number, Order_Meaningful => Check_Order ); 123 end if; 124 Inits_Called := 0; -- reset for the next batch 125 end Validate; 126 127end C761003_Support; 128 129------------------------------------------------------------------ C761003_0 130 131with Ada.Finalization; 132package C761003_0 is 133 134 type Global(Tag: Character) is new Ada.Finalization.Controlled 135 with null record; 136 137 procedure Initialize( It: in out Global ); 138 procedure Finalize ( It: in out Global ); 139 140 Null_Global : Global('1') := (Ada.Finalization.Controlled with Tag => '1'); 141 142 type Second(Tag: Character) is new Ada.Finalization.Limited_Controlled 143 with null record; 144 145 procedure Initialize( It: in out Second ); 146 procedure Finalize ( It: in out Second ); 147 148end C761003_0; 149 150------------------------------------------------------------------ C761003_1 151 152with Ada.Finalization; 153package C761003_1 is 154 155 type Global is abstract new Ada.Finalization.Controlled with record 156 Tag: Character; 157 end record; 158 159 procedure Initialize( It: in out Global ); 160 procedure Finalize ( It: in out Global ); 161 162 type Second is abstract new Ada.Finalization.Limited_Controlled with record 163 Tag: Character; 164 end record; 165 166 procedure Initialize( It: in out Second ); 167 procedure Finalize ( It: in out Second ); 168 169end C761003_1; 170 171------------------------------------------------------------------ C761003_2 172 173with C761003_1; 174package C761003_2 is 175 176 type Global is new C761003_1.Global with null record; 177 -- inherits Initialize and Finalize 178 179 type Second is new C761003_1.Second with null record; 180 -- inherits Initialize and Finalize 181 182end C761003_2; 183 184-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- C761003_0 185 186with TCTouch; 187with C761003_Support; 188package body C761003_0 is 189 190 package Sup renames C761003_Support; 191 192 procedure Initialize( It: in out Global ) is 193 begin 194 Sup.Inits_Called := Sup.Inits_Called +1; 195 Sup.Inits_Order(Sup.Inits_Called) := It.Tag; 196 end Initialize; 197 198 procedure Finalize( It: in out Global ) is 199 begin 200 TCTouch.Touch(It.Tag); --------------------------------------------- Tag 201 end Finalize; 202 203 procedure Initialize( It: in out Second ) is 204 begin 205 Sup.Inits_Called := Sup.Inits_Called +1; 206 Sup.Inits_Order(Sup.Inits_Called) := It.Tag; 207 end Initialize; 208 209 procedure Finalize( It: in out Second ) is 210 begin 211 TCTouch.Touch(It.Tag); --------------------------------------------- Tag 212 end Finalize; 213 214end C761003_0; 215 216-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- C761003_1 217 218with TCTouch; 219with C761003_Support; 220package body C761003_1 is 221 222 package Sup renames C761003_Support; 223 224 procedure Initialize( It: in out Global ) is 225 begin 226 Sup.Inits_Called := Sup.Inits_Called +1; 227 It.Tag := Sup.Pick_Char; 228 Sup.Inits_Order(Sup.Inits_Called) := It.Tag; 229 end Initialize; 230 231 procedure Finalize( It: in out Global ) is 232 begin 233 TCTouch.Touch(It.Tag); --------------------------------------------- Tag 234 end Finalize; 235 236 procedure Initialize( It: in out Second ) is 237 begin 238 Sup.Inits_Called := Sup.Inits_Called +1; 239 It.Tag := Sup.Pick_Char; 240 Sup.Inits_Order(Sup.Inits_Called) := It.Tag; 241 end Initialize; 242 243 procedure Finalize( It: in out Second ) is 244 begin 245 TCTouch.Touch(It.Tag); --------------------------------------------- Tag 246 end Finalize; 247 248end C761003_1; 249 250-------------------------------------------------------------------- C761003 251 252with Report; 253with TCTouch; 254with C761003_0; 255with C761003_2; 256with C761003_Support; 257procedure C761003 is 258 259 package Sup renames C761003_Support; 260 261---------------------------------------------------------------- Subtest_1 262 263 Subtest_1_Inits_Expected : constant := 5; -- includes 1 previous 264 265 procedure Subtest_1 is 266 267 -- the constant will take its constraint from the value. 268 -- must be declared first to be finalized last (and take the 269 -- initialize from before calling subtest_1) 270 Item_1 : constant C761003_0.Global := C761003_0.Null_Global; 271 272 -- Item_2, declared second, should be finalized second to last. 273 Item_2 : C761003_0.Global(Sup.Pick_Char); 274 275 -- Item_3 and Item_4 will be created in the order of the 276 -- list. 277 Item_3, Item_4 : C761003_0.Global(Sup.Pick_Char); 278 279 -- Item_5 will be finalized first. 280 Item_5 : C761003_0.Second(Sup.Pick_Char); 281 282 begin 283 if Item_3.Tag >= Item_4.Tag then 284 Report.Failed("Controlled objects created by list in wrong order"); 285 end if; 286 -- check that nothing has happened yet! 287 TCTouch.Validate("","Subtest 1 body"); 288 end Subtest_1; 289 290---------------------------------------------------------------- Subtest_2 291 292 -- These declarations should cause calls to initialize and 293 -- finalize. The expected operations are the subprograms associated 294 -- with the abstract types. Note that for these objects, the 295 -- Initialize and Finalize are visible only by inheritance. 296 297 Subtest_2_Inits_Expected : constant := 4; 298 299 procedure Subtest_2 is 300 301 Item_1 : C761003_2.Global; 302 Item_2, Item_3 : C761003_2.Global; 303 Item_4 : C761003_2.Second; 304 305 begin 306 -- check that nothing has happened yet! 307 TCTouch.Validate("","Subtest 2 body"); 308 end Subtest_2; 309 310---------------------------------------------------------------- Subtest_3 311 312 -- Test for controlled objects embedded in arrays. Using structures 313 -- that will cause a checkable order. 314 315 Subtest_3_Inits_Expected : constant := 8; 316 317 procedure Subtest_3 is 318 319 type Global_List is array(Natural range <>) 320 of C761003_0.Global(Sup.Pick_Char); 321 322 Items : Global_List(1..4); -- components have the same tag 323 324 type Second_List is array(Natural range <>) 325 of C761003_0.Second(Sup.Pick_Char); 326 327 Second_Items : Second_List(1..4); -- components have the same tag, 328 -- distinct from the tag used in Items 329 330 begin 331 -- check that nothing has happened yet! 332 TCTouch.Validate("","Subtest 3 body"); 333 end Subtest_3; 334 335---------------------------------------------------------------- Subtest_4 336 337 -- These declarations should cause dispatching calls to initialize and 338 -- finalize. The expected operations are the subprograms associated 339 -- with the abstract types. 340 341 Subtest_4_Inits_Expected : constant := 2; 342 343 procedure Subtest_4 is 344 345 type Global_Rec is record 346 Item1: C761003_0.Global(Sup.Pick_Char); 347 end record; 348 349 type Second_Rec is record 350 Item2: C761003_2.Second; 351 end record; 352 353 G : Global_Rec; 354 S : Second_Rec; 355 356 begin 357 -- check that nothing has happened yet! 358 TCTouch.Validate("","Subtest 4 body"); 359 end Subtest_4; 360 361---------------------------------------------------------------- Subtest_5 362 363 -- Test for controlled objects embedded in arrays. In these cases, the 364 -- order of the finalization of the components is not defined by the 365 -- language. 366 367 Subtest_5_Inits_Expected : constant := 8; 368 369 procedure Subtest_5 is 370 371 372 type Another_Global_List is array(Natural range <>) 373 of C761003_2.Global; 374 375 More_Items : Another_Global_List(1..4); 376 377 type Another_Second_List is array(Natural range <>) 378 of C761003_2.Second; 379 380 Second_More_Items : Another_Second_List(1..4); 381 382 begin 383 -- check that nothing has happened yet! 384 TCTouch.Validate("","Subtest 5 body"); 385 end Subtest_5; 386 387---------------------------------------------------------------- Subtest_6 388 389 -- These declarations should cause dispatching calls to initialize and 390 -- finalize. The expected operations are the subprograms associated 391 -- with the abstract types. 392 393 Subtest_6_Inits_Expected : constant := 2; 394 395 procedure Subtest_6 is 396 397 type Global_Rec is record 398 Item2: C761003_2.Global; 399 end record; 400 401 type Second_Rec is record 402 Item1: C761003_0.Second(Sup.Pick_Char); 403 end record; 404 405 G : Global_Rec; 406 S : Second_Rec; 407 408 begin 409 -- check that nothing has happened yet! 410 TCTouch.Validate("","Subtest 6 body"); 411 end Subtest_6; 412 413begin -- Main test procedure. 414 415 Report.Test ("C761003", "Check that an object of a controlled type " 416 & "is finalized when the enclosing master is " 417 & "complete, left by a transfer of control, " 418 & "and performed in the correct order" ); 419 420 -- adjust for optional adjusts and initializes for C761003_0.Null_Global 421 TCTouch.Flush; -- clear the optional adjust 422 if Sup.Inits_Called /= 1 then 423 -- C761003_0.Null_Global did not get "initialized" 424 C761003_0.Initialize(C761003_0.Null_Global); -- prime the pump 425 end if; 426 427 Subtest_1; 428 Sup.Validate(Subtest_1_Inits_Expected, 1); 429 430 Subtest_2; 431 Sup.Validate(Subtest_2_Inits_Expected, 2); 432 433 Subtest_3; 434 Sup.Validate(Subtest_3_Inits_Expected, 3); 435 436 Subtest_4; 437 Sup.Validate(Subtest_4_Inits_Expected, 4); 438 439 Subtest_5; 440 Sup.Validate(Subtest_5_Inits_Expected, 5, Check_Order => False); 441 442 Subtest_6; 443 Sup.Validate(Subtest_6_Inits_Expected, 6); 444 445 Report.Result; 446 447end C761003; 448