diff options
author | upstream source tree <ports@midipix.org> | 2015-03-15 20:14:05 -0400 |
---|---|---|
committer | upstream source tree <ports@midipix.org> | 2015-03-15 20:14:05 -0400 |
commit | 554fd8c5195424bdbcabf5de30fdc183aba391bd (patch) | |
tree | 976dc5ab7fddf506dadce60ae936f43f58787092 /gcc/testsuite/ada/acats/tests/c7/c761012.a | |
download | cbb-gcc-4.6.4-554fd8c5195424bdbcabf5de30fdc183aba391bd.tar.bz2 cbb-gcc-4.6.4-554fd8c5195424bdbcabf5de30fdc183aba391bd.tar.xz |
obtained gcc-4.6.4.tar.bz2 from upstream website;upstream
verified gcc-4.6.4.tar.bz2.sig;
imported gcc-4.6.4 source tree from verified upstream tarball.
downloading a git-generated archive based on the 'upstream' tag
should provide you with a source tree that is binary identical
to the one extracted from the above tarball.
if you have obtained the source via the command 'git clone',
however, do note that line-endings of files in your working
directory might differ from line-endings of the respective
files in the upstream repository.
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c7/c761012.a')
-rw-r--r-- | gcc/testsuite/ada/acats/tests/c7/c761012.a | 151 |
1 files changed, 151 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c7/c761012.a b/gcc/testsuite/ada/acats/tests/c7/c761012.a new file mode 100644 index 000000000..77b9e2253 --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c7/c761012.a @@ -0,0 +1,151 @@ +-- C761012.A +-- +-- Grant of Unlimited Rights +-- +-- The Ada Conformity Assessment Authority (ACAA) holds unlimited +-- rights in the software and documentation contained herein. Unlimited +-- rights are the same as those granted by the U.S. Government for older +-- parts of the Ada Conformity Assessment Test Suite, and are defined +-- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA +-- intends to confer upon all recipients unlimited rights equal to those +-- held by the ACAA. 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 an anonymous object is finalized with its enclosing master if +-- a transfer of control or exception occurs prior to performing its normal +-- finalization. (Defect Report 8652/0023, as reflected in +-- Technical Corrigendum 1, RM95 7.6.1(13.1/1)). +-- +-- CHANGE HISTORY: +-- 29 JAN 2001 PHL Initial version. +-- 5 DEC 2001 RLB Reformatted for ACATS. +-- +--! +with Ada.Finalization; +use Ada.Finalization; +package C761012_0 is + + type Ctrl (D : Boolean) is new Controlled with + record + case D is + when False => + C1 : Integer; + when True => + C2 : Float; + end case; + end record; + + function Create return Ctrl; + procedure Finalize (Obj : in out Ctrl); + function Finalize_Was_Called return Boolean; + +end C761012_0; + +with Report; +use Report; +package body C761012_0 is + + Finalization_Flag : Boolean := False; + + function Create return Ctrl is + Obj : Ctrl (Ident_Bool (True)); + begin + Obj.C2 := 3.0; + return Obj; + end Create; + + procedure Finalize (Obj : in out Ctrl) is + begin + Finalization_Flag := True; + end Finalize; + + function Finalize_Was_Called return Boolean is + begin + if Finalization_Flag then + Finalization_Flag := False; + return True; + else + return False; + end if; + end Finalize_Was_Called; + +end C761012_0; + +with Ada.Exceptions; +use Ada.Exceptions; +with C761012_0; +use C761012_0; +with Report; +use Report; +procedure C761012 is +begin + Test ("C761012", + "Check that an anonymous object is finalized with its enclosing " & + "master if a transfer of control or exception occurs prior to " & + "performing its normal finalization"); + + Excep: + begin + + declare + I : Integer := Create.C1; -- Raises Constraint_Error + begin + Failed + ("Improper component selection did not raise Constraint_Error, I =" & + Integer'Image (I)); + exception + when Constraint_Error => + Failed ("Constraint_Error caught by the wrong handler"); + end; + + Failed ("Transfer of control did not happen correctly"); + + exception + when Constraint_Error => + if not Finalize_Was_Called then + Failed ("Finalize wasn't called when the master was left " & + "- Constraint_Error"); + end if; + when E: others => + Failed ("Exception " & Exception_Name (E) & + " raised - " & Exception_Information (E)); + end Excep; + + Transfer: + declare + Finalize_Was_Called_Before_Leaving_Exit : Boolean; + begin + + begin + loop + exit when Create.C2 = 3.0; + end loop; + Finalize_Was_Called_Before_Leaving_Exit := Finalize_Was_Called; + if Finalize_Was_Called_Before_Leaving_Exit then + Comment ("Finalize called before the transfer of control"); + end if; + end; + + if not Finalize_Was_Called and then + not Finalize_Was_Called_Before_Leaving_Exit then + Failed ("Finalize wasn't called when the master was left " & + "- transfer of control"); + end if; + end Transfer; + + Result; +end C761012; + |