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