1-- C760001.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 Initialize is called for objects and components of 28-- a controlled type when the objects and components are not 29-- assigned explicit initial values. Check this for "simple" controlled 30-- objects, controlled record components and arrays with controlled 31-- components. 32-- 33-- Check that if an explicit initial value is assigned to an object 34-- or component of a controlled type then Initialize is not called. 35-- 36-- TEST DESCRIPTION: 37-- This test derives a type for Ada.Finalization.Controlled, and 38-- overrides the Initialize and Adjust operations for the type. The 39-- intent of the type is that it should carry incremental values 40-- indicating the ordering of events with respect to these (and default 41-- initialization) operations. The body of the test uses these values 42-- to determine that the implicit calls to these subprograms happen 43-- (or don't) at the appropriate times. 44-- 45-- The test further derives types from this "root" type, which are the 46-- actual types used in the test. One of the types is "simply" derived 47-- from the "root" type, the other contains a component of the first 48-- type, thus nesting a controlled object as a record component in 49-- controlled objects. 50-- 51-- The main program declares objects of these types and checks the 52-- values of the components to ascertain that they have been touched 53-- as expected. 54-- 55-- Note that Finalization procedures are provided. This test does not 56-- test that the calls to Finalization are made correctly. The 57-- Finalization procedures are provided to catch an implementation that 58-- calls Finalization at an incorrect time. 59-- 60-- 61-- CHANGE HISTORY: 62-- 06 Dec 94 SAIC ACVC 2.0 63-- 10 Oct 95 SAIC Update and repair for ACVC 2.0.1 64-- 65--! 66 67---------------------------------------------------------------- C760001_0 68 69with Ada.Finalization; 70package C760001_0 is 71 subtype Unique_ID is Natural; 72 function Unique_Value return Unique_ID; 73 -- increments each time it's called 74 75 function Most_Recent_Unique_Value return Unique_ID; 76 -- returns the same value as the most recent call to Unique_Value 77 78 type Root_Controlled is new Ada.Finalization.Controlled with record 79 My_ID : Unique_ID := Unique_Value; 80 My_Init_ID : Unique_ID := Unique_ID'First; 81 My_Adj_ID : Unique_ID := Unique_ID'First; 82 end record; 83 84 procedure Initialize( R: in out Root_Controlled ); 85 procedure Adjust ( R: in out Root_Controlled ); 86 87 TC_Initialize_Calls_Is_Failing : Boolean := False; 88 89end C760001_0; 90 91-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- 92 93with Report; 94package body C760001_0 is 95 96 Global_Unique_Counter : Unique_ID := 0; 97 98 function Unique_Value return Unique_ID is 99 begin 100 Global_Unique_Counter := Global_Unique_Counter +1; 101 return Global_Unique_Counter; 102 end Unique_Value; 103 104 function Most_Recent_Unique_Value return Unique_ID is 105 begin 106 return Global_Unique_Counter; 107 end Most_Recent_Unique_Value; 108 109 procedure Initialize( R: in out Root_Controlled ) is 110 begin 111 if TC_Initialize_Calls_Is_Failing then 112 Report.Failed("Initialized incorrectly called"); 113 end if; 114 R.My_Init_ID := Unique_Value; 115 end Initialize; 116 117 procedure Adjust( R: in out Root_Controlled ) is 118 begin 119 R.My_Adj_ID := Unique_Value; 120 end Adjust; 121 122end C760001_0; 123 124---------------------------------------------------------------- C760001_1 125 126with Ada.Finalization; 127with C760001_0; 128package C760001_1 is 129 130 type Proc_ID is (None, Init, Adj, Fin); 131 132 type Test_Controlled is new C760001_0.Root_Controlled with record 133 Last_Proc_Called: Proc_ID := None; 134 end record; 135 136 procedure Initialize( TC: in out Test_Controlled ); 137 procedure Adjust ( TC: in out Test_Controlled ); 138 procedure Finalize ( TC: in out Test_Controlled ); 139 140 type Nested_Controlled is new C760001_0.Root_Controlled with record 141 Nested : C760001_0.Root_Controlled; 142 Last_Proc_Called: Proc_ID := None; 143 end record; 144 145 procedure Initialize( TC: in out Nested_Controlled ); 146 procedure Adjust ( TC: in out Nested_Controlled ); 147 procedure Finalize ( TC: in out Nested_Controlled ); 148 149end C760001_1; 150 151-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- 152 153with Report; 154package body C760001_1 is 155 156 procedure Initialize( TC: in out Test_Controlled ) is 157 begin 158 if TC.Last_Proc_Called /= None then 159 Report.Failed("Initialize for Test_Controlled"); 160 end if; 161 TC.Last_Proc_Called := Init; 162 C760001_0.Initialize(C760001_0.Root_Controlled(TC)); 163 end Initialize; 164 165 procedure Adjust ( TC: in out Test_Controlled ) is 166 begin 167 TC.Last_Proc_Called := Adj; 168 C760001_0.Adjust(C760001_0.Root_Controlled(TC)); 169 end Adjust; 170 171 procedure Finalize ( TC: in out Test_Controlled ) is 172 begin 173 TC.Last_Proc_Called := Fin; 174 end Finalize; 175 176 procedure Initialize( TC: in out Nested_Controlled ) is 177 begin 178 if TC.Last_Proc_Called /= None then 179 Report.Failed("Initialize for Nested_Controlled"); 180 end if; 181 TC.Last_Proc_Called := Init; 182 C760001_0.Initialize(C760001_0.Root_Controlled(TC)); 183 end Initialize; 184 185 procedure Adjust ( TC: in out Nested_Controlled ) is 186 begin 187 TC.Last_Proc_Called := Adj; 188 C760001_0.Adjust(C760001_0.Root_Controlled(TC)); 189 end Adjust; 190 191 procedure Finalize ( TC: in out Nested_Controlled ) is 192 begin 193 TC.Last_Proc_Called := Fin; 194 end Finalize; 195 196end C760001_1; 197 198---------------------------------------------------------------- C760001 199 200with Report; 201with TCTouch; 202with C760001_0; 203with C760001_1; 204with Ada.Finalization; 205procedure C760001 is 206 207 use type C760001_1.Proc_ID; 208 209 -- in the first test, test the simple case. Check that a controlled object 210 -- causes a call to the procedure Initialize. 211 -- Also check that assignment causes a call to Adjust. 212 213 procedure Check_Simple_Objects is 214 S,T : C760001_1.Test_Controlled; 215 begin 216 TCTouch.Assert(S.My_ID < S.My_Init_ID,"Default before dispatch"); 217 TCTouch.Assert((S.Last_Proc_Called = C760001_1.Init) and 218 (T.Last_Proc_Called = C760001_1.Init), 219 "Initialize for simple object"); 220 S := T; 221 TCTouch.Assert((S.Last_Proc_Called = C760001_1.Adj), 222 "Adjust for simple object"); 223 TCTouch.Assert((S.My_ID = T.My_ID), 224 "Simple object My_ID's don't match"); 225 TCTouch.Assert((S.My_Init_ID = T.My_Init_ID), 226 "Simple object My_Init_ID's don't match"); 227 TCTouch.Assert((S.My_Adj_ID > T.My_Adj_ID), 228 "Simple object My_Adj_ID's in wrong order"); 229 end Check_Simple_Objects; 230 231 -- in the second test, test a more complex case, check that a controlled 232 -- component of a controlled object gets processed correctly 233 234 procedure Check_Nested_Objects is 235 NO1 : C760001_1.Nested_Controlled; 236 begin 237 TCTouch.Assert((NO1.My_ID < NO1.My_Init_Id), 238 "Default value order incorrect"); 239 TCTouch.Assert((NO1.My_Init_Id > NO1.Nested.My_Init_ID), 240 "Initialization call order incorrect"); 241 end Check_Nested_Objects; 242 243 -- check that objects assigned an initial value at declaration are Adjusted 244 -- and NOT Initialized 245 246 procedure Check_Objects_With_Initial_Values is 247 248 TC_Now : constant C760001_0.Unique_ID := C760001_0.Unique_Value; 249 250 A: C760001_1.Test_Controlled := 251 ( Ada.Finalization.Controlled 252 with TC_Now, 253 TC_Now, 254 TC_Now, 255 C760001_1.None); 256 257 B: C760001_1.Nested_Controlled := 258 ( Ada.Finalization.Controlled 259 with TC_Now, 260 TC_Now, 261 TC_Now, 262 C760001_0.Root_Controlled(A), 263 C760001_1.None); 264 265 begin 266 -- the implementation may or may not call Adjust for the values 267 -- assigned into A and B, 268 -- but should NOT call Initialize. 269 -- if the value used in the aggregate is overwritten by Initialize, 270 -- this indicates failure 271 TCTouch.Assert(A.My_Init_Id = TC_Now, 272 "Initialize was called for A with initial value"); 273 TCTouch.Assert(B.My_Init_Id = TC_Now, 274 "Initialize was called for B with initial value"); 275 TCTouch.Assert(B.Nested.My_Init_ID = TC_Now, 276 "Initialize was called for B.Nested initial value"); 277 end Check_Objects_With_Initial_Values; 278 279 procedure Check_Array_Case is 280 type Array_Simple is array(1..4) of C760001_1.Test_Controlled; 281 type Array_Nested is array(1..4) of C760001_1.Nested_Controlled; 282 283 Simple_Array_Default : Array_Simple; 284 285 Nested_Array_Default : Array_Nested; 286 287 TC_A_Bit_Later : C760001_0.Unique_ID; 288 289 begin 290 TC_A_Bit_Later := C760001_0.Unique_Value; 291 for N in 1..4 loop 292 TCTouch.Assert(Simple_Array_Default(N).Last_Proc_Called 293 = C760001_1.Init, 294 "Initialize for array initial value"); 295 296 TCTouch.Assert( (Simple_Array_Default(N).My_Init_ID 297 > C760001_0.Unique_ID'First) 298 and (Simple_Array_Default(N).My_Init_ID 299 < TC_A_Bit_Later), 300 "Initialize timing for simple array"); 301 302 TCTouch.Assert( (Nested_Array_Default(N).My_Init_ID 303 > C760001_0.Unique_ID'First) 304 and (Nested_Array_Default(N).My_Init_ID 305 < TC_A_Bit_Later), 306 "Initialize timing for container array"); 307 308 TCTouch.Assert(Nested_Array_Default(N).Last_Proc_Called 309 = C760001_1.Init, 310 "Initialize for nested array (outer) initial value"); 311 312 TCTouch.Assert( (Nested_Array_Default(N).Nested.My_Init_ID 313 > C760001_0.Unique_ID'First) 314 and (Nested_Array_Default(N).Nested.My_Init_ID 315 < Nested_Array_Default(N).My_Init_ID), 316 "Initialize timing for array content"); 317 end loop; 318 end Check_Array_Case; 319 320 procedure Check_Array_Case_With_Initial_Values is 321 322 TC_Now : constant C760001_0.Unique_ID := C760001_0.Unique_Value; 323 324 type Array_Simple is array(1..4) of C760001_1.Test_Controlled; 325 type Array_Nested is array(1..4) of C760001_1.Nested_Controlled; 326 327 Simple_Array_Explicit : Array_Simple := ( 1..4 => ( 328 Ada.Finalization.Controlled 329 with TC_Now, 330 TC_Now, 331 TC_Now, 332 C760001_1.None ) ); 333 334 A : constant C760001_0.Root_Controlled := 335 ( Ada.Finalization.Controlled 336 with others => TC_Now); 337 338 Nested_Array_Explicit : Array_Nested := ( 1..4 => ( 339 Ada.Finalization.Controlled 340 with TC_Now, 341 TC_Now, 342 TC_Now, 343 A, 344 C760001_1.None ) ); 345 346 begin 347 -- the implementation may or may not call Adjust for the values 348 -- assigned into Simple_Array_Explicit and Nested_Array_Explicit, 349 -- but should NOT call Initialize. 350 -- if the value used in the aggregate is overwritten by Initialize, 351 -- this indicates failure 352 for N in 1..4 loop 353 TCTouch.Assert(Simple_Array_Explicit(N).My_Init_ID 354 = TC_Now, 355 "Initialize was called for array with initial value"); 356 TCTouch.Assert(Nested_Array_Explicit(N).My_Init_ID 357 = TC_Now, 358 "Initialize was called for nested array (outer) with initial value"); 359 TCTouch.Assert(Nested_Array_Explicit(N).Nested.My_Init_ID = TC_Now, 360 "Initialize was called for nested array (inner) with initial value"); 361 end loop; 362 end Check_Array_Case_With_Initial_Values; 363 364-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- 365 366begin -- Main test procedure. 367 368 Report.Test ("C760001", "Check that Initialize is called for objects " & 369 "and components of a controlled type when the " & 370 "objects and components are not assigned " & 371 "explicit initial values. Check that if an " & 372 "explicit initial value is assigned to an " & 373 "object or component of a controlled type " & 374 "then Initialize is not called" ); 375 376 Check_Simple_Objects; 377 378 Check_Nested_Objects; 379 380 Check_Array_Case; 381 382 C760001_0.TC_Initialize_Calls_Is_Failing := True; 383 384 Check_Objects_With_Initial_Values; 385 386 Check_Array_Case_With_Initial_Values; 387 388 Report.Result; 389 390end C760001; 391