1-- C761012.A
2--
3--                             Grant of Unlimited Rights
4--
5--     The Ada Conformity Assessment Authority (ACAA) holds unlimited
6--     rights in the software and documentation contained herein. Unlimited
7--     rights are the same as those granted by the U.S. Government for older
8--     parts of the Ada Conformity Assessment Test Suite, and are defined
9--     in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
10--     intends to confer upon all recipients unlimited rights equal to those
11--     held by the ACAA. These rights include rights to use, duplicate,
12--     release or disclose the released technical data and computer software
13--     in whole or in part, in any manner and for any purpose whatsoever, and
14--     to have or permit others to do so.
15--
16--                                    DISCLAIMER
17--
18--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
19--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
20--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
21--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
22--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
23--     PARTICULAR PURPOSE OF SAID MATERIAL.
24--*
25--
26-- OBJECTIVE:
27--    Check that an anonymous object is finalized with its enclosing master if
28--    a transfer of control or exception occurs prior to performing its normal
29--    finalization.  (Defect Report 8652/0023, as reflected in
30--    Technical Corrigendum 1, RM95 7.6.1(13.1/1)).
31--
32-- CHANGE HISTORY:
33--    29 JAN 2001   PHL   Initial version.
34--     5 DEC 2001   RLB   Reformatted for ACATS.
35--
36--!
37with Ada.Finalization;
38use Ada.Finalization;
39package C761012_0 is
40
41    type Ctrl (D : Boolean) is new Controlled with
42        record
43            case D is
44                when False =>
45                    C1 : Integer;
46                when True =>
47                    C2 : Float;
48            end case;
49        end record;
50
51    function Create return Ctrl;
52    procedure Finalize (Obj : in out Ctrl);
53    function Finalize_Was_Called return Boolean;
54
55end C761012_0;
56
57with Report;
58use Report;
59package body C761012_0 is
60
61    Finalization_Flag : Boolean := False;
62
63    function Create return Ctrl is
64        Obj : Ctrl (Ident_Bool (True));
65    begin
66        Obj.C2 := 3.0;
67        return Obj;
68    end Create;
69
70    procedure Finalize (Obj : in out Ctrl) is
71    begin
72        Finalization_Flag := True;
73    end Finalize;
74
75    function Finalize_Was_Called return Boolean is
76    begin
77        if Finalization_Flag then
78            Finalization_Flag := False;
79            return True;
80        else
81            return False;
82        end if;
83    end Finalize_Was_Called;
84
85end C761012_0;
86
87with Ada.Exceptions;
88use Ada.Exceptions;
89with C761012_0;
90use C761012_0;
91with Report;
92use Report;
93procedure C761012 is
94begin
95    Test ("C761012",
96          "Check that an anonymous object is finalized with its enclosing " &
97             "master if a transfer of control or exception occurs prior to " &
98             "performing its normal finalization");
99
100    Excep:
101        begin
102
103            declare
104                I : Integer := Create.C1; -- Raises Constraint_Error
105            begin
106                Failed
107                   ("Improper component selection did not raise Constraint_Error, I =" &
108                    Integer'Image (I));
109            exception
110                when Constraint_Error =>
111                    Failed ("Constraint_Error caught by the wrong handler");
112            end;
113
114            Failed ("Transfer of control did not happen correctly");
115
116        exception
117            when Constraint_Error =>
118                if not Finalize_Was_Called then
119                    Failed ("Finalize wasn't called when the master was left " &
120                            "- Constraint_Error");
121                end if;
122            when E: others =>
123                Failed ("Exception " & Exception_Name (E) &
124                        " raised - " & Exception_Information (E));
125        end Excep;
126
127    Transfer:
128        declare
129            Finalize_Was_Called_Before_Leaving_Exit : Boolean;
130        begin
131
132            begin
133                loop
134                    exit when Create.C2 = 3.0;
135                end loop;
136                Finalize_Was_Called_Before_Leaving_Exit := Finalize_Was_Called;
137                if Finalize_Was_Called_Before_Leaving_Exit then
138                    Comment ("Finalize called before the transfer of control");
139                end if;
140            end;
141
142            if not Finalize_Was_Called and then
143               not Finalize_Was_Called_Before_Leaving_Exit then
144                Failed ("Finalize wasn't called when the master was left " &
145                        "- transfer of control");
146            end if;
147        end Transfer;
148
149    Result;
150end C761012;
151
152