URL
https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk
Subversion Repositories openrisc_me
[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c7/] [c761002.a] - Rev 316
Go to most recent revision | Compare with Previous | Blame | View Log
-- C761002.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 objects of a controlled type that are created
-- by an allocator are finalized at the appropriate time. In
-- particular, check that such objects are not finalized due to
-- completion of the master in which they were allocated if the
-- corresponding access type is declared outside of that master.
--
-- Check that Unchecked_Deallocation of a controlled
-- object causes finalization of that object.
--
-- TEST DESCRIPTION:
-- This test derives a type from Ada.Finalization.Controlled, and
-- declares access types to that type in various scope scenarios.
-- The dispatching procedure Finalize is redefined for the derived
-- type to perform a check that it has been called at the
-- correct time. This is accomplished using a global variable
-- which indicates what state the software is currently
-- executing. The test utilizes the TCTouch facilities to
-- verify that Finalize is called the correct number of times, at
-- the correct times. Several calls are made to validate passing
-- the null string to check that Finalize has NOT been called at
-- that point.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
with Ada.Finalization;
package C761002_0 is
type Global is new Ada.Finalization.Controlled with null record;
procedure Finalize( It: in out Global );
type Second is new Ada.Finalization.Limited_Controlled with null record;
procedure Finalize( It: in out Second );
end C761002_0;
with Report;
with TCTouch;
package body C761002_0 is
procedure Finalize( It: in out Global ) is
begin
TCTouch.Touch('F'); ------------------------------------------------- F
end Finalize;
procedure Finalize( It: in out Second ) is
begin
TCTouch.Touch('S'); ------------------------------------------------- S
end Finalize;
end C761002_0;
with Report;
with TCTouch;
with C761002_0;
with Unchecked_Deallocation;
procedure C761002 is
-- check the straightforward case
procedure Subtest_1 is
type Access_1 is access C761002_0.Global;
V1 : Access_1;
procedure Allocate is
V2 : Access_1;
begin
V2 := new C761002_0.Global;
V1 := V2; -- "dead" assignment must not be optimized away due to
-- finalization "side effects", many more of these follow
end Allocate;
begin
Allocate;
-- no calls to Finalize should have occurred at this point
TCTouch.Validate("","Allocated nested, retained");
end Subtest_1;
-- check Unchecked_Deallocation
procedure Subtest_2 is
type Access_2 is access C761002_0.Global;
procedure Free is
new Unchecked_Deallocation(C761002_0.Global, Access_2);
V1 : Access_2;
V2 : Access_2;
procedure Allocate is
begin
V1 := new C761002_0.Global;
V2 := new C761002_0.Global;
end Allocate;
begin
Allocate;
-- no calls to Finalize should have occurred at this point.
TCTouch.Validate("","Allocated nested, non-local");
Free(V1); -- instance of Unchecked_Deallocation
-- should cause the finalization of V1.all
TCTouch.Validate("F","Unchecked Deallocation");
end Subtest_2; -- leaving this scope should cause the finalization of V2.all
-- check various master-exit scenarios
-- the "Fake" parameters are used to avoid unwanted optimizations
procedure Subtest_3 is
procedure With_Local_Block is
type Access_3 is access C761002_0.Global;
V1 : Access_3;
begin
declare
V2 : Access_3 := new C761002_0.Global;
begin
V1 := V2;
end;
TCTouch.Validate("","Local Block, normal exit");
-- the allocated object should be finalized on leaving this scope
end With_Local_Block;
procedure With_Local_Block_Return(Fake: Integer) is
type Access_4 is access C761002_0.Global;
V1 : Access_4 := new C761002_0.Global;
begin
if Fake = 0 then
declare
V2 : Access_4;
begin
V2 := new C761002_0.Global;
return; -- the two allocated objects should be finalized
end; -- upon leaving this scope
else
V1 := null;
end if;
end With_Local_Block_Return;
procedure With_Goto(Fake: Integer) is
type Access_5 is access C761002_0.Global;
V1 : Access_5 := new C761002_0.Global;
V2 : Access_5;
V3 : Access_5;
begin
if Fake = 0 then
declare
type Access_6 is access C761002_0.Second;
V6 : Access_6;
begin
V6 := new C761002_0.Second;
goto check;
end;
else
V2 := V1;
end if;
V3 := V2;
<<check>>
TCTouch.Validate("S","goto past master end");
end With_Goto;
begin
With_Local_Block;
TCTouch.Validate("F","Local Block, normal exit, after master");
With_Local_Block_Return( Report.Ident_Int(0) );
TCTouch.Validate("FF","Local Block, return from block");
With_Goto( Report.Ident_Int(0) );
TCTouch.Validate("F","With Goto");
end Subtest_3;
procedure Subtest_4 is
Oops : exception;
procedure Alley( Fake: Integer ) is
type Access_1 is access C761002_0.Global;
V1 : Access_1;
begin
V1 := new C761002_0.Global;
if Fake = 1 then
raise Oops;
end if;
V1 := null;
end Alley;
begin
Catch: begin
Alley( Report.Ident_Int(1) );
exception
when Oops => TCTouch.Validate("F","leaving via exception");
when others => Report.Failed("Wrong exception");
end Catch;
end Subtest_4;
begin -- Main test procedure.
Report.Test ("C761002", "Check that objects of a controlled type created "
& "by an allocator are finalized appropriately. "
& "Check that Unchecked_Deallocation of a "
& "controlled object causes finalization "
& "of that object" );
Subtest_1;
-- leaving the scope of the access type should finalize the
-- collection
TCTouch.Validate("F","Allocated nested, Subtest 1");
Subtest_2;
-- Unchecked_Deallocation already finalized one of the two
-- objects allocated, the other should be the only one finalized
-- at leaving the scope of the access type.
TCTouch.Validate("F","Allocated non-local");
Subtest_3;
-- there should be no remaining finalizations from this subtest
TCTouch.Validate("","Localized objects");
Subtest_4;
-- there should be no remaining finalizations from this subtest
TCTouch.Validate("","Exception testing");
Report.Result;
end C761002;
Go to most recent revision | Compare with Previous | Blame | View Log