-- C760011.A -- -- Grant of Unlimited Rights -- -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained -- unlimited rights in the software and documentation contained herein. -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making -- this public release, the Government intends to confer upon all -- recipients unlimited rights equal to those held by the Government. -- These rights include rights to use, duplicate, release or disclose the -- released technical data and computer software in whole or in part, in -- any manner and for any purpose whatsoever, and to have or permit others -- to do so. -- -- DISCLAIMER -- -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A -- PARTICULAR PURPOSE OF SAID MATERIAL. --* -- -- OBJECTIVE: -- Check that the anonymous objects of a controlled type associated with -- function results and aggregates are finalized no later than the -- end of the innermost enclosing declarative_item or statement. Also -- check this for function calls and aggregates of a noncontrolled type -- with controlled components. -- -- TEST DESCRIPTION: -- This test defines a controlled type with a discriminant, the -- discriminant is use as an index into a global table to indicate that -- the object has been finalized. The controlled type is used as the -- component of a non-controlled type, and the non-controlled type is -- used for the same set of tests. Following is a table of the tests -- performed and their associated tag character. -- -- 7.6(21) allows for the optimizations that remove these temporary -- objects from ever existing. As such this test checks that in the -- case the object was initialized (the only access we have to -- determining if it ever existed) it must subsequently be finalized. -- -- CASE TABLE: -- A - aggregate test, controlled -- B - aggregate test, controlled -- C - aggregate test, non_controlled -- D - function test, controlled -- E - function test, non_controlled -- F - formal parameter function test, controlled -- G - formal parameter aggregate test, controlled -- H - formal parameter function test, non_controlled -- I - formal parameter aggregate test, non_controlled -- -- X - scratch object, not consequential to the objective -- Y - scratch object, not consequential to the objective -- Z - scratch object, not consequential to the objective -- -- -- CHANGE HISTORY: -- 22 MAY 95 SAIC Initial version -- 24 APR 96 SAIC Minor doc fixes, visibility patch -- 14 NOV 96 SAIC Revised for release 2.1 -- --! ------------------------------------------------------------------- C760011_0 with Ada.Finalization; package C760011_0 is type Tracking_Array is array(Character range 'A'..'Z') of Boolean; Initialized : Tracking_Array := (others => False); Finalized : Tracking_Array := (others => False); type Controlled_Type(Tag : Character) is new Ada.Finalization.Controlled with record TC_Component : String(1..4) := "ACVC"; end record; procedure Initialize( It: in out Controlled_Type ); procedure Finalize ( It: in out Controlled_Type ); function Create(With_Tag: Character) return Controlled_Type; type Non_Controlled(Tag : Character := 'Y') is record Controlled_Component : Controlled_Type(Tag); end record; procedure Initialize( It: in out Non_Controlled ); procedure Finalize ( It: in out Non_Controlled ); function Create(With_Tag: Character) return Non_Controlled; Under_Debug : constant Boolean := False; -- construction lines end C760011_0; -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- with Report; package body C760011_0 is procedure Initialize( It: in out Controlled_Type ) is begin It.TC_Component := (others => It.Tag); if It.Tag in Tracking_Array'Range then Initialized(It.Tag) := True; end if; if Under_Debug then Report.Comment("Initializing Tag: " & It.Tag ); end if; end Initialize; procedure Finalize( It: in out Controlled_Type ) is begin if Under_Debug then Report.Comment("Finalizing for Tag: " & It.Tag ); end if; if It.Tag in Finalized'Range then Finalized(It.Tag) := True; end if; end Finalize; function Create(With_Tag: Character) return Controlled_Type is begin return Controlled_Type'(Ada.Finalization.Controlled with Tag => With_Tag, TC_Component => "*CON" ); end Create; procedure Initialize( It: in out Non_Controlled ) is begin Report.Failed("Called Initialize for Non_Controlled"); end Initialize; procedure Finalize( It: in out Non_Controlled ) is begin Report.Failed("Called Finalize for Non_Controlled"); end Finalize; function Create(With_Tag: Character) return Non_Controlled is begin return Non_Controlled'(Tag => With_Tag, Controlled_Component => ( Ada.Finalization.Controlled with Tag => With_Tag, TC_Component => "#NON" ) ); end Create; end C760011_0; --------------------------------------------------------------------- C760011 with Report; with TCTouch; with C760011_0; with Ada.Finalization; -- needed to be able to create extension aggregates procedure C760011 is use type C760011_0.Controlled_Type; use type C760011_0.Controlled_Type'Class; use type C760011_0.Non_Controlled; subtype AFC is Ada.Finalization.Controlled; procedure Check_Result( Tag : Character; Message : String ) is -- make allowance for 7.6(21) optimizations begin if C760011_0.Initialized(Tag) then TCTouch.Assert(C760011_0.Finalized(Tag),Message); elsif C760011_0.Under_Debug then Report.Comment("Optimized away: " & Tag ); end if; end Check_Result; procedure Subtest_1 is procedure Subtest_1_Local_1 is An_Object : C760011_0.Controlled_Type'Class := C760011_0.Controlled_Type'(AFC with 'X', "ONE*"); -- initialize An_Object begin if C760011_0.Controlled_Type(An_Object) = C760011_0.Controlled_Type'(AFC with 'A', "ONE*") then Report.Failed("Comparison bad"); -- A = X !!! end if; end Subtest_1_Local_1; -- An_Object must be Finalized by this point. procedure Subtest_1_Local_2 is An_Object : C760011_0.Controlled_Type('B'); begin An_Object := (AFC with 'B', "TWO!" ); if Report.Ident_Char(An_Object.Tag) /= 'B' then Report.Failed("Subtest_1_Local_2 Optimization Foil: Bad Data!"); end if; exception when others => Report.Failed("Bad controlled assignment"); end Subtest_1_Local_2; -- An_Object must be Finalized by this point. procedure Subtest_1_Local_3 is An_Object : C760011_0.Non_Controlled('C'); begin TCTouch.Assert_Not(C760011_0.Finalized('C'), "Non_Controlled declaration C"); An_Object := C760011_0.Non_Controlled'('C', Controlled_Component => (AFC with 'C', "TEE!")); if Report.Ident_Char(An_Object.Tag) /= 'C' then Report.Failed("Subtest_1_Local_3 Optimization Foil: Bad Data!"); end if; end Subtest_1_Local_3; -- Only controlled components of An_Object must be finalized; it is an -- error to call Finalize for An_Object begin Subtest_1_Local_1; Check_Result( 'A', "Aggregate in subprogram 1" ); Subtest_1_Local_2; Check_Result( 'B', "Aggregate in subprogram 2" ); Subtest_1_Local_3; Check_Result( 'C', "Embedded aggregate in subprogram 3" ); end Subtest_1; procedure Subtest_2 is -- using 'Z' for both evades order issues Con_Object : C760011_0.Controlled_Type('Z'); Non_Object : C760011_0.Non_Controlled('Z'); begin if Report.Ident_Bool( Con_Object = C760011_0.Create('D') ) then Report.Failed("Con_Object catastrophe"); end if; -- Controlled function result should be finalized by now Check_Result( 'D', "Function Result" ); if Report.Ident_Bool( Non_Object = C760011_0.Create('E') ) then Report.Failed("Non_Object catastrophe"); end if; -- Controlled component of function result should be finalized by now Check_Result( 'E', "Function Result" ); end Subtest_2; procedure Subtest_3(Con : in C760011_0.Controlled_Type) is begin if Con.Tag not in 'F'..'G' then Report.Failed("Bad value passed to subtest 3 " & Con.Tag & ' ' & Report.Ident_Str(Con.TC_Component)); end if; end Subtest_3; procedure Subtest_4(Non : in C760011_0.Non_Controlled) is begin if Non.Tag not in 'H'..'I' then Report.Failed("Bad value passed to subtest 4 " & Non.Tag & ' ' & Report.Ident_Str(Non.Controlled_Component.TC_Component)); end if; end Subtest_4; begin -- Main test procedure. Report.Test ("C760011", "Check that anonymous objects of controlled " & "types or types containing controlled types " & "are finalized no later than the end of the " & "innermost enclosing declarative_item or " & "statement" ); Subtest_1; Subtest_2; Subtest_3(C760011_0.Create('F')); Check_Result( 'F', "Function as formal F" ); Subtest_3(C760011_0.Controlled_Type'(AFC with 'G',"GIGI")); Check_Result( 'G', "Aggregate as formal G" ); Subtest_4(C760011_0.Create('H')); Check_Result( 'H', "Function as formal H" ); Subtest_4(C760011_0.Non_Controlled'('I', (AFC with 'I',"IAGO"))); Check_Result( 'I', "Aggregate as formal I" ); Report.Result; end C760011;