1-- C760011.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 the anonymous objects of a controlled type associated with 28-- function results and aggregates are finalized no later than the 29-- end of the innermost enclosing declarative_item or statement. Also 30-- check this for function calls and aggregates of a noncontrolled type 31-- with controlled components. 32-- 33-- TEST DESCRIPTION: 34-- This test defines a controlled type with a discriminant, the 35-- discriminant is use as an index into a global table to indicate that 36-- the object has been finalized. The controlled type is used as the 37-- component of a non-controlled type, and the non-controlled type is 38-- used for the same set of tests. Following is a table of the tests 39-- performed and their associated tag character. 40-- 41-- 7.6(21) allows for the optimizations that remove these temporary 42-- objects from ever existing. As such this test checks that in the 43-- case the object was initialized (the only access we have to 44-- determining if it ever existed) it must subsequently be finalized. 45-- 46-- CASE TABLE: 47-- A - aggregate test, controlled 48-- B - aggregate test, controlled 49-- C - aggregate test, non_controlled 50-- D - function test, controlled 51-- E - function test, non_controlled 52-- F - formal parameter function test, controlled 53-- G - formal parameter aggregate test, controlled 54-- H - formal parameter function test, non_controlled 55-- I - formal parameter aggregate test, non_controlled 56-- 57-- X - scratch object, not consequential to the objective 58-- Y - scratch object, not consequential to the objective 59-- Z - scratch object, not consequential to the objective 60-- 61-- 62-- CHANGE HISTORY: 63-- 22 MAY 95 SAIC Initial version 64-- 24 APR 96 SAIC Minor doc fixes, visibility patch 65-- 14 NOV 96 SAIC Revised for release 2.1 66-- 67--! 68 69------------------------------------------------------------------- C760011_0 70 71with Ada.Finalization; 72package C760011_0 is 73 type Tracking_Array is array(Character range 'A'..'Z') of Boolean; 74 75 Initialized : Tracking_Array := (others => False); 76 Finalized : Tracking_Array := (others => False); 77 78 type Controlled_Type(Tag : Character) is 79 new Ada.Finalization.Controlled with record 80 TC_Component : String(1..4) := "ACVC"; 81 end record; 82 procedure Initialize( It: in out Controlled_Type ); 83 procedure Finalize ( It: in out Controlled_Type ); 84 function Create(With_Tag: Character) return Controlled_Type; 85 86 type Non_Controlled(Tag : Character := 'Y') is record 87 Controlled_Component : Controlled_Type(Tag); 88 end record; 89 procedure Initialize( It: in out Non_Controlled ); 90 procedure Finalize ( It: in out Non_Controlled ); 91 function Create(With_Tag: Character) return Non_Controlled; 92 93 Under_Debug : constant Boolean := False; -- construction lines 94 95end C760011_0; 96 97-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- 98 99with Report; 100package body C760011_0 is 101 102 procedure Initialize( It: in out Controlled_Type ) is 103 begin 104 It.TC_Component := (others => It.Tag); 105 if It.Tag in Tracking_Array'Range then 106 Initialized(It.Tag) := True; 107 end if; 108 if Under_Debug then 109 Report.Comment("Initializing Tag: " & It.Tag ); 110 end if; 111 end Initialize; 112 113 procedure Finalize( It: in out Controlled_Type ) is 114 begin 115 if Under_Debug then 116 Report.Comment("Finalizing for Tag: " & It.Tag ); 117 end if; 118 if It.Tag in Finalized'Range then 119 Finalized(It.Tag) := True; 120 end if; 121 end Finalize; 122 123 function Create(With_Tag: Character) return Controlled_Type is 124 begin 125 return Controlled_Type'(Ada.Finalization.Controlled 126 with Tag => With_Tag, 127 TC_Component => "*CON" ); 128 end Create; 129 130 procedure Initialize( It: in out Non_Controlled ) is 131 begin 132 Report.Failed("Called Initialize for Non_Controlled"); 133 end Initialize; 134 135 procedure Finalize( It: in out Non_Controlled ) is 136 begin 137 Report.Failed("Called Finalize for Non_Controlled"); 138 end Finalize; 139 140 function Create(With_Tag: Character) return Non_Controlled is 141 begin 142 return Non_Controlled'(Tag => With_Tag, Controlled_Component => ( 143 Ada.Finalization.Controlled 144 with Tag => With_Tag, 145 TC_Component => "#NON" ) ); 146 end Create; 147 148end C760011_0; 149 150--------------------------------------------------------------------- C760011 151 152with Report; 153with TCTouch; 154with C760011_0; 155with Ada.Finalization; -- needed to be able to create extension aggregates 156procedure C760011 is 157 158 use type C760011_0.Controlled_Type; 159 use type C760011_0.Controlled_Type'Class; 160 use type C760011_0.Non_Controlled; 161 162 subtype AFC is Ada.Finalization.Controlled; 163 164 procedure Check_Result( Tag : Character; Message : String ) is 165 -- make allowance for 7.6(21) optimizations 166 begin 167 if C760011_0.Initialized(Tag) then 168 TCTouch.Assert(C760011_0.Finalized(Tag),Message); 169 elsif C760011_0.Under_Debug then 170 Report.Comment("Optimized away: " & Tag ); 171 end if; 172 end Check_Result; 173 174 procedure Subtest_1 is 175 176 177 procedure Subtest_1_Local_1 is 178 An_Object : C760011_0.Controlled_Type'Class 179 := C760011_0.Controlled_Type'(AFC with 'X', "ONE*"); 180 -- initialize An_Object 181 begin 182 if C760011_0.Controlled_Type(An_Object) 183 = C760011_0.Controlled_Type'(AFC with 'A', "ONE*") then 184 Report.Failed("Comparison bad"); -- A = X !!! 185 end if; 186 end Subtest_1_Local_1; 187 -- An_Object must be Finalized by this point. 188 189 procedure Subtest_1_Local_2 is 190 An_Object : C760011_0.Controlled_Type('B'); 191 begin 192 An_Object := (AFC with 'B', "TWO!" ); 193 if Report.Ident_Char(An_Object.Tag) /= 'B' then 194 Report.Failed("Subtest_1_Local_2 Optimization Foil: Bad Data!"); 195 end if; 196 exception 197 when others => Report.Failed("Bad controlled assignment"); 198 end Subtest_1_Local_2; 199 -- An_Object must be Finalized by this point. 200 201 procedure Subtest_1_Local_3 is 202 An_Object : C760011_0.Non_Controlled('C'); 203 begin 204 TCTouch.Assert_Not(C760011_0.Finalized('C'), 205 "Non_Controlled declaration C"); 206 An_Object := C760011_0.Non_Controlled'('C', Controlled_Component 207 => (AFC with 'C', "TEE!")); 208 if Report.Ident_Char(An_Object.Tag) /= 'C' then 209 Report.Failed("Subtest_1_Local_3 Optimization Foil: Bad Data!"); 210 end if; 211 end Subtest_1_Local_3; 212 -- Only controlled components of An_Object must be finalized; it is an 213 -- error to call Finalize for An_Object 214 215 begin 216 Subtest_1_Local_1; 217 Check_Result( 'A', "Aggregate in subprogram 1" ); 218 219 Subtest_1_Local_2; 220 Check_Result( 'B', "Aggregate in subprogram 2" ); 221 222 Subtest_1_Local_3; 223 Check_Result( 'C', "Embedded aggregate in subprogram 3" ); 224 end Subtest_1; 225 226 227 procedure Subtest_2 is 228 -- using 'Z' for both evades order issues 229 Con_Object : C760011_0.Controlled_Type('Z'); 230 Non_Object : C760011_0.Non_Controlled('Z'); 231 begin 232 if Report.Ident_Bool( Con_Object = C760011_0.Create('D') ) then 233 Report.Failed("Con_Object catastrophe"); 234 end if; 235 -- Controlled function result should be finalized by now 236 Check_Result( 'D', "Function Result" ); 237 238 if Report.Ident_Bool( Non_Object = C760011_0.Create('E') ) then 239 Report.Failed("Non_Object catastrophe"); 240 end if; 241 -- Controlled component of function result should be finalized by now 242 Check_Result( 'E', "Function Result" ); 243 end Subtest_2; 244 245 246 procedure Subtest_3(Con : in C760011_0.Controlled_Type) is 247 begin 248 if Con.Tag not in 'F'..'G' then 249 Report.Failed("Bad value passed to subtest 3 " & Con.Tag & ' ' 250 & Report.Ident_Str(Con.TC_Component)); 251 end if; 252 end Subtest_3; 253 254 255 procedure Subtest_4(Non : in C760011_0.Non_Controlled) is 256 begin 257 if Non.Tag not in 'H'..'I' then 258 Report.Failed("Bad value passed to subtest 4 " 259 & Non.Tag & ' ' 260 & Report.Ident_Str(Non.Controlled_Component.TC_Component)); 261 end if; 262 end Subtest_4; 263 264 265begin -- Main test procedure. 266 267 Report.Test ("C760011", "Check that anonymous objects of controlled " & 268 "types or types containing controlled types " & 269 "are finalized no later than the end of the " & 270 "innermost enclosing declarative_item or " & 271 "statement" ); 272 273 Subtest_1; 274 275 Subtest_2; 276 277 Subtest_3(C760011_0.Create('F')); 278 Check_Result( 'F', "Function as formal F" ); 279 280 Subtest_3(C760011_0.Controlled_Type'(AFC with 'G',"GIGI")); 281 Check_Result( 'G', "Aggregate as formal G" ); 282 283 Subtest_4(C760011_0.Create('H')); 284 Check_Result( 'H', "Function as formal H" ); 285 286 Subtest_4(C760011_0.Non_Controlled'('I', (AFC with 'I',"IAGO"))); 287 Check_Result( 'I', "Aggregate as formal I" ); 288 289 Report.Result; 290 291end C760011; 292