1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
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;
|
