-- C761002.A
|
-- C761002.A
|
--
|
--
|
-- Grant of Unlimited Rights
|
-- Grant of Unlimited Rights
|
--
|
--
|
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
|
-- 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
|
-- 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 in the software and documentation contained herein.
|
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
|
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
|
-- this public release, the Government intends to confer upon all
|
-- this public release, the Government intends to confer upon all
|
-- recipients unlimited rights equal to those held by the Government.
|
-- recipients unlimited rights equal to those held by the Government.
|
-- These rights include rights to use, duplicate, release or disclose the
|
-- These rights include rights to use, duplicate, release or disclose the
|
-- released technical data and computer software in whole or in part, in
|
-- 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
|
-- any manner and for any purpose whatsoever, and to have or permit others
|
-- to do so.
|
-- to do so.
|
--
|
--
|
-- DISCLAIMER
|
-- DISCLAIMER
|
--
|
--
|
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
|
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
|
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
|
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
|
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
|
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
|
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
|
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
|
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
|
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
|
-- PARTICULAR PURPOSE OF SAID MATERIAL.
|
-- PARTICULAR PURPOSE OF SAID MATERIAL.
|
--*
|
--*
|
--
|
--
|
-- OBJECTIVE:
|
-- OBJECTIVE:
|
-- Check that objects of a controlled type that are created
|
-- Check that objects of a controlled type that are created
|
-- by an allocator are finalized at the appropriate time. In
|
-- by an allocator are finalized at the appropriate time. In
|
-- particular, check that such objects are not finalized due to
|
-- particular, check that such objects are not finalized due to
|
-- completion of the master in which they were allocated if the
|
-- completion of the master in which they were allocated if the
|
-- corresponding access type is declared outside of that master.
|
-- corresponding access type is declared outside of that master.
|
--
|
--
|
-- Check that Unchecked_Deallocation of a controlled
|
-- Check that Unchecked_Deallocation of a controlled
|
-- object causes finalization of that object.
|
-- object causes finalization of that object.
|
--
|
--
|
-- TEST DESCRIPTION:
|
-- TEST DESCRIPTION:
|
-- This test derives a type from Ada.Finalization.Controlled, and
|
-- This test derives a type from Ada.Finalization.Controlled, and
|
-- declares access types to that type in various scope scenarios.
|
-- declares access types to that type in various scope scenarios.
|
-- The dispatching procedure Finalize is redefined for the derived
|
-- The dispatching procedure Finalize is redefined for the derived
|
-- type to perform a check that it has been called at the
|
-- type to perform a check that it has been called at the
|
-- correct time. This is accomplished using a global variable
|
-- correct time. This is accomplished using a global variable
|
-- which indicates what state the software is currently
|
-- which indicates what state the software is currently
|
-- executing. The test utilizes the TCTouch facilities to
|
-- executing. The test utilizes the TCTouch facilities to
|
-- verify that Finalize is called the correct number of times, at
|
-- verify that Finalize is called the correct number of times, at
|
-- the correct times. Several calls are made to validate passing
|
-- the correct times. Several calls are made to validate passing
|
-- the null string to check that Finalize has NOT been called at
|
-- the null string to check that Finalize has NOT been called at
|
-- that point.
|
-- that point.
|
--
|
--
|
--
|
--
|
-- CHANGE HISTORY:
|
-- CHANGE HISTORY:
|
-- 06 Dec 94 SAIC ACVC 2.0
|
-- 06 Dec 94 SAIC ACVC 2.0
|
--
|
--
|
--!
|
--!
|
|
|
with Ada.Finalization;
|
with Ada.Finalization;
|
package C761002_0 is
|
package C761002_0 is
|
type Global is new Ada.Finalization.Controlled with null record;
|
type Global is new Ada.Finalization.Controlled with null record;
|
procedure Finalize( It: in out Global );
|
procedure Finalize( It: in out Global );
|
|
|
type Second is new Ada.Finalization.Limited_Controlled with null record;
|
type Second is new Ada.Finalization.Limited_Controlled with null record;
|
procedure Finalize( It: in out Second );
|
procedure Finalize( It: in out Second );
|
end C761002_0;
|
end C761002_0;
|
|
|
with Report;
|
with Report;
|
with TCTouch;
|
with TCTouch;
|
package body C761002_0 is
|
package body C761002_0 is
|
|
|
procedure Finalize( It: in out Global ) is
|
procedure Finalize( It: in out Global ) is
|
begin
|
begin
|
TCTouch.Touch('F'); ------------------------------------------------- F
|
TCTouch.Touch('F'); ------------------------------------------------- F
|
end Finalize;
|
end Finalize;
|
|
|
procedure Finalize( It: in out Second ) is
|
procedure Finalize( It: in out Second ) is
|
begin
|
begin
|
TCTouch.Touch('S'); ------------------------------------------------- S
|
TCTouch.Touch('S'); ------------------------------------------------- S
|
end Finalize;
|
end Finalize;
|
end C761002_0;
|
end C761002_0;
|
|
|
with Report;
|
with Report;
|
with TCTouch;
|
with TCTouch;
|
with C761002_0;
|
with C761002_0;
|
with Unchecked_Deallocation;
|
with Unchecked_Deallocation;
|
procedure C761002 is
|
procedure C761002 is
|
|
|
-- check the straightforward case
|
-- check the straightforward case
|
procedure Subtest_1 is
|
procedure Subtest_1 is
|
type Access_1 is access C761002_0.Global;
|
type Access_1 is access C761002_0.Global;
|
V1 : Access_1;
|
V1 : Access_1;
|
procedure Allocate is
|
procedure Allocate is
|
V2 : Access_1;
|
V2 : Access_1;
|
begin
|
begin
|
V2 := new C761002_0.Global;
|
V2 := new C761002_0.Global;
|
V1 := V2; -- "dead" assignment must not be optimized away due to
|
V1 := V2; -- "dead" assignment must not be optimized away due to
|
-- finalization "side effects", many more of these follow
|
-- finalization "side effects", many more of these follow
|
end Allocate;
|
end Allocate;
|
begin
|
begin
|
Allocate;
|
Allocate;
|
-- no calls to Finalize should have occurred at this point
|
-- no calls to Finalize should have occurred at this point
|
TCTouch.Validate("","Allocated nested, retained");
|
TCTouch.Validate("","Allocated nested, retained");
|
end Subtest_1;
|
end Subtest_1;
|
|
|
-- check Unchecked_Deallocation
|
-- check Unchecked_Deallocation
|
procedure Subtest_2 is
|
procedure Subtest_2 is
|
type Access_2 is access C761002_0.Global;
|
type Access_2 is access C761002_0.Global;
|
procedure Free is
|
procedure Free is
|
new Unchecked_Deallocation(C761002_0.Global, Access_2);
|
new Unchecked_Deallocation(C761002_0.Global, Access_2);
|
V1 : Access_2;
|
V1 : Access_2;
|
V2 : Access_2;
|
V2 : Access_2;
|
|
|
procedure Allocate is
|
procedure Allocate is
|
begin
|
begin
|
V1 := new C761002_0.Global;
|
V1 := new C761002_0.Global;
|
V2 := new C761002_0.Global;
|
V2 := new C761002_0.Global;
|
end Allocate;
|
end Allocate;
|
|
|
begin
|
begin
|
Allocate;
|
Allocate;
|
-- no calls to Finalize should have occurred at this point.
|
-- no calls to Finalize should have occurred at this point.
|
TCTouch.Validate("","Allocated nested, non-local");
|
TCTouch.Validate("","Allocated nested, non-local");
|
|
|
Free(V1); -- instance of Unchecked_Deallocation
|
Free(V1); -- instance of Unchecked_Deallocation
|
-- should cause the finalization of V1.all
|
-- should cause the finalization of V1.all
|
TCTouch.Validate("F","Unchecked Deallocation");
|
TCTouch.Validate("F","Unchecked Deallocation");
|
end Subtest_2; -- leaving this scope should cause the finalization of V2.all
|
end Subtest_2; -- leaving this scope should cause the finalization of V2.all
|
|
|
-- check various master-exit scenarios
|
-- check various master-exit scenarios
|
-- the "Fake" parameters are used to avoid unwanted optimizations
|
-- the "Fake" parameters are used to avoid unwanted optimizations
|
procedure Subtest_3 is
|
procedure Subtest_3 is
|
procedure With_Local_Block is
|
procedure With_Local_Block is
|
type Access_3 is access C761002_0.Global;
|
type Access_3 is access C761002_0.Global;
|
V1 : Access_3;
|
V1 : Access_3;
|
begin
|
begin
|
declare
|
declare
|
V2 : Access_3 := new C761002_0.Global;
|
V2 : Access_3 := new C761002_0.Global;
|
begin
|
begin
|
V1 := V2;
|
V1 := V2;
|
end;
|
end;
|
TCTouch.Validate("","Local Block, normal exit");
|
TCTouch.Validate("","Local Block, normal exit");
|
-- the allocated object should be finalized on leaving this scope
|
-- the allocated object should be finalized on leaving this scope
|
end With_Local_Block;
|
end With_Local_Block;
|
|
|
procedure With_Local_Block_Return(Fake: Integer) is
|
procedure With_Local_Block_Return(Fake: Integer) is
|
type Access_4 is access C761002_0.Global;
|
type Access_4 is access C761002_0.Global;
|
V1 : Access_4 := new C761002_0.Global;
|
V1 : Access_4 := new C761002_0.Global;
|
begin
|
begin
|
if Fake = 0 then
|
if Fake = 0 then
|
declare
|
declare
|
V2 : Access_4;
|
V2 : Access_4;
|
begin
|
begin
|
V2 := new C761002_0.Global;
|
V2 := new C761002_0.Global;
|
return; -- the two allocated objects should be finalized
|
return; -- the two allocated objects should be finalized
|
end; -- upon leaving this scope
|
end; -- upon leaving this scope
|
else
|
else
|
V1 := null;
|
V1 := null;
|
end if;
|
end if;
|
end With_Local_Block_Return;
|
end With_Local_Block_Return;
|
|
|
procedure With_Goto(Fake: Integer) is
|
procedure With_Goto(Fake: Integer) is
|
type Access_5 is access C761002_0.Global;
|
type Access_5 is access C761002_0.Global;
|
V1 : Access_5 := new C761002_0.Global;
|
V1 : Access_5 := new C761002_0.Global;
|
V2 : Access_5;
|
V2 : Access_5;
|
V3 : Access_5;
|
V3 : Access_5;
|
begin
|
begin
|
if Fake = 0 then
|
if Fake = 0 then
|
declare
|
declare
|
type Access_6 is access C761002_0.Second;
|
type Access_6 is access C761002_0.Second;
|
V6 : Access_6;
|
V6 : Access_6;
|
begin
|
begin
|
V6 := new C761002_0.Second;
|
V6 := new C761002_0.Second;
|
goto check;
|
goto check;
|
end;
|
end;
|
else
|
else
|
V2 := V1;
|
V2 := V1;
|
end if;
|
end if;
|
V3 := V2;
|
V3 := V2;
|
<>
|
<>
|
TCTouch.Validate("S","goto past master end");
|
TCTouch.Validate("S","goto past master end");
|
end With_Goto;
|
end With_Goto;
|
|
|
begin
|
begin
|
With_Local_Block;
|
With_Local_Block;
|
TCTouch.Validate("F","Local Block, normal exit, after master");
|
TCTouch.Validate("F","Local Block, normal exit, after master");
|
|
|
With_Local_Block_Return( Report.Ident_Int(0) );
|
With_Local_Block_Return( Report.Ident_Int(0) );
|
TCTouch.Validate("FF","Local Block, return from block");
|
TCTouch.Validate("FF","Local Block, return from block");
|
|
|
With_Goto( Report.Ident_Int(0) );
|
With_Goto( Report.Ident_Int(0) );
|
TCTouch.Validate("F","With Goto");
|
TCTouch.Validate("F","With Goto");
|
|
|
end Subtest_3;
|
end Subtest_3;
|
|
|
procedure Subtest_4 is
|
procedure Subtest_4 is
|
|
|
Oops : exception;
|
Oops : exception;
|
|
|
procedure Alley( Fake: Integer ) is
|
procedure Alley( Fake: Integer ) is
|
type Access_1 is access C761002_0.Global;
|
type Access_1 is access C761002_0.Global;
|
V1 : Access_1;
|
V1 : Access_1;
|
begin
|
begin
|
V1 := new C761002_0.Global;
|
V1 := new C761002_0.Global;
|
if Fake = 1 then
|
if Fake = 1 then
|
raise Oops;
|
raise Oops;
|
end if;
|
end if;
|
V1 := null;
|
V1 := null;
|
end Alley;
|
end Alley;
|
|
|
begin
|
begin
|
Catch: begin
|
Catch: begin
|
Alley( Report.Ident_Int(1) );
|
Alley( Report.Ident_Int(1) );
|
exception
|
exception
|
when Oops => TCTouch.Validate("F","leaving via exception");
|
when Oops => TCTouch.Validate("F","leaving via exception");
|
when others => Report.Failed("Wrong exception");
|
when others => Report.Failed("Wrong exception");
|
end Catch;
|
end Catch;
|
end Subtest_4;
|
end Subtest_4;
|
|
|
begin -- Main test procedure.
|
begin -- Main test procedure.
|
|
|
Report.Test ("C761002", "Check that objects of a controlled type created "
|
Report.Test ("C761002", "Check that objects of a controlled type created "
|
& "by an allocator are finalized appropriately. "
|
& "by an allocator are finalized appropriately. "
|
& "Check that Unchecked_Deallocation of a "
|
& "Check that Unchecked_Deallocation of a "
|
& "controlled object causes finalization "
|
& "controlled object causes finalization "
|
& "of that object" );
|
& "of that object" );
|
|
|
Subtest_1;
|
Subtest_1;
|
-- leaving the scope of the access type should finalize the
|
-- leaving the scope of the access type should finalize the
|
-- collection
|
-- collection
|
TCTouch.Validate("F","Allocated nested, Subtest 1");
|
TCTouch.Validate("F","Allocated nested, Subtest 1");
|
|
|
Subtest_2;
|
Subtest_2;
|
-- Unchecked_Deallocation already finalized one of the two
|
-- Unchecked_Deallocation already finalized one of the two
|
-- objects allocated, the other should be the only one finalized
|
-- objects allocated, the other should be the only one finalized
|
-- at leaving the scope of the access type.
|
-- at leaving the scope of the access type.
|
TCTouch.Validate("F","Allocated non-local");
|
TCTouch.Validate("F","Allocated non-local");
|
|
|
Subtest_3;
|
Subtest_3;
|
-- there should be no remaining finalizations from this subtest
|
-- there should be no remaining finalizations from this subtest
|
TCTouch.Validate("","Localized objects");
|
TCTouch.Validate("","Localized objects");
|
|
|
Subtest_4;
|
Subtest_4;
|
-- there should be no remaining finalizations from this subtest
|
-- there should be no remaining finalizations from this subtest
|
TCTouch.Validate("","Exception testing");
|
TCTouch.Validate("","Exception testing");
|
|
|
Report.Result;
|
Report.Result;
|
|
|
end C761002;
|
end C761002;
|
|
|
