diff options
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/c7/c761002.a')
| -rw-r--r-- | gcc-4.9/gcc/testsuite/ada/acats/tests/c7/c761002.a | 245 |
1 files changed, 245 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c7/c761002.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c7/c761002.a new file mode 100644 index 000000000..5b807bba7 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c7/c761002.a @@ -0,0 +1,245 @@ +-- 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; |