1 |
149 |
jeremybenn |
-- C760007.A
|
2 |
|
|
--
|
3 |
|
|
-- Grant of Unlimited Rights
|
4 |
|
|
--
|
5 |
|
|
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
|
6 |
|
|
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
|
7 |
|
|
-- unlimited rights in the software and documentation contained herein.
|
8 |
|
|
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
|
9 |
|
|
-- this public release, the Government intends to confer upon all
|
10 |
|
|
-- recipients unlimited rights equal to those held by the Government.
|
11 |
|
|
-- These rights include rights to use, duplicate, release or disclose the
|
12 |
|
|
-- released technical data and computer software in whole or in part, in
|
13 |
|
|
-- any manner and for any purpose whatsoever, and to have or permit others
|
14 |
|
|
-- 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 Adjust is called for the execution of a return
|
28 |
|
|
-- statement for a function returning a result of a (non-limited)
|
29 |
|
|
-- controlled type.
|
30 |
|
|
--
|
31 |
|
|
-- Check that Adjust is called when evaluating an aggregate
|
32 |
|
|
-- component association for a controlled component.
|
33 |
|
|
--
|
34 |
|
|
-- Check that Adjust is called for the assignment of the ancestor
|
35 |
|
|
-- expression of an extension aggregate when the type of the
|
36 |
|
|
-- aggregate is controlled.
|
37 |
|
|
--
|
38 |
|
|
-- TEST DESCRIPTION:
|
39 |
|
|
-- A type is derived from Ada.Finalization.Controlled; the dispatching
|
40 |
|
|
-- procedure Adjust is defined for the new type. Structures and
|
41 |
|
|
-- subprograms to model the test objectives are used to check that
|
42 |
|
|
-- Adjust is called at the right time. For the sake of simplicity,
|
43 |
|
|
-- globally accessible data is used to check that the calls are made.
|
44 |
|
|
--
|
45 |
|
|
--
|
46 |
|
|
-- CHANGE HISTORY:
|
47 |
|
|
-- 06 DEC 94 SAIC ACVC 2.0
|
48 |
|
|
-- 14 OCT 95 SAIC Update and repair for ACVC 2.0.1
|
49 |
|
|
-- 05 APR 96 SAIC Add RM reference
|
50 |
|
|
-- 06 NOV 96 SAIC Reduce adjust requirement
|
51 |
|
|
-- 25 NOV 97 EDS Allowed zero calls to adjust at line 144
|
52 |
|
|
--!
|
53 |
|
|
|
54 |
|
|
---------------------------------------------------------------- C760007_0
|
55 |
|
|
|
56 |
|
|
with Ada.Finalization;
|
57 |
|
|
package C760007_0 is
|
58 |
|
|
|
59 |
|
|
type Controlled is new Ada.Finalization.Controlled with record
|
60 |
|
|
TC_ID : Natural := Natural'Last;
|
61 |
|
|
end record;
|
62 |
|
|
procedure Adjust( Object: in out Controlled );
|
63 |
|
|
|
64 |
|
|
type Structure is record
|
65 |
|
|
Controlled_Component : Controlled;
|
66 |
|
|
end record;
|
67 |
|
|
|
68 |
|
|
type Child is new Controlled with record
|
69 |
|
|
TC_XX : Natural := Natural'Last;
|
70 |
|
|
end record;
|
71 |
|
|
procedure Adjust( Object: in out Child );
|
72 |
|
|
|
73 |
|
|
Adjust_Count : Natural := 0;
|
74 |
|
|
Child_Adjust_Count : Natural := 0;
|
75 |
|
|
|
76 |
|
|
end C760007_0;
|
77 |
|
|
|
78 |
|
|
package body C760007_0 is
|
79 |
|
|
|
80 |
|
|
procedure Adjust( Object: in out Controlled ) is
|
81 |
|
|
begin
|
82 |
|
|
Adjust_Count := Adjust_Count +1;
|
83 |
|
|
end Adjust;
|
84 |
|
|
|
85 |
|
|
procedure Adjust( Object: in out Child ) is
|
86 |
|
|
begin
|
87 |
|
|
Child_Adjust_Count := Child_Adjust_Count +1;
|
88 |
|
|
end Adjust;
|
89 |
|
|
|
90 |
|
|
end C760007_0;
|
91 |
|
|
|
92 |
|
|
------------------------------------------------------------------ C760007
|
93 |
|
|
|
94 |
|
|
with Report;
|
95 |
|
|
with C760007_0;
|
96 |
|
|
procedure C760007 is
|
97 |
|
|
|
98 |
|
|
procedure Check_Adjust_Count(Message: String;
|
99 |
|
|
Min: Natural := 1;
|
100 |
|
|
Max: Natural := 2) is
|
101 |
|
|
begin
|
102 |
|
|
|
103 |
|
|
-- in order to allow for the anonymous objects referred to in
|
104 |
|
|
-- the reference manual, the check for calls to Adjust must be
|
105 |
|
|
-- in a range. This number must then be further adjusted
|
106 |
|
|
-- to allow for the optimization that does not call for an adjust
|
107 |
|
|
-- of an aggregate initial value built directly in the object
|
108 |
|
|
|
109 |
|
|
if C760007_0.Adjust_Count not in Min..Max then
|
110 |
|
|
Report.Failed(Message
|
111 |
|
|
& " = " & Natural'Image(C760007_0.Adjust_Count));
|
112 |
|
|
end if;
|
113 |
|
|
C760007_0.Adjust_Count := 0;
|
114 |
|
|
end Check_Adjust_Count;
|
115 |
|
|
|
116 |
|
|
procedure Check_Child_Adjust_Count(Message: String;
|
117 |
|
|
Min: Natural := 1;
|
118 |
|
|
Max: Natural := 2) is
|
119 |
|
|
begin
|
120 |
|
|
-- ditto above
|
121 |
|
|
|
122 |
|
|
if C760007_0.Child_Adjust_Count not in Min..Max then
|
123 |
|
|
Report.Failed(Message
|
124 |
|
|
& " = " & Natural'Image(C760007_0.Child_Adjust_Count));
|
125 |
|
|
end if;
|
126 |
|
|
C760007_0.Child_Adjust_Count := 0;
|
127 |
|
|
end Check_Child_Adjust_Count;
|
128 |
|
|
|
129 |
|
|
Object : C760007_0.Controlled;
|
130 |
|
|
|
131 |
|
|
-- Check that Adjust is called for the execution of a return
|
132 |
|
|
-- statement for a function returning a result of a (non-limited)
|
133 |
|
|
-- controlled type or a result of a noncontrolled type with
|
134 |
|
|
-- controlled components.
|
135 |
|
|
|
136 |
|
|
procedure Subtest_1 is
|
137 |
|
|
function Create return C760007_0.Controlled is
|
138 |
|
|
New_Object : C760007_0.Controlled;
|
139 |
|
|
begin
|
140 |
|
|
return New_Object;
|
141 |
|
|
end Create;
|
142 |
|
|
|
143 |
|
|
procedure Examine( Thing : in C760007_0.Controlled ) is
|
144 |
|
|
begin
|
145 |
|
|
Check_Adjust_Count("Function call passed as parameter",0);
|
146 |
|
|
end Examine;
|
147 |
|
|
|
148 |
|
|
begin
|
149 |
|
|
-- this assignment must call Adjust:
|
150 |
|
|
-- 1: on the value resulting from the function
|
151 |
|
|
-- ** unless this is optimized out by building the result directly
|
152 |
|
|
-- in the target object.
|
153 |
|
|
-- 2: on Object once it's been assigned
|
154 |
|
|
-- may call adjust
|
155 |
|
|
-- 1: for a anonymous object created in the evaluation of the function
|
156 |
|
|
-- 2: for a anonymous object created in the assignment operation
|
157 |
|
|
|
158 |
|
|
Object := Create;
|
159 |
|
|
|
160 |
|
|
Check_Adjust_Count("Function call",1,4);
|
161 |
|
|
|
162 |
|
|
Examine( Create );
|
163 |
|
|
|
164 |
|
|
end Subtest_1;
|
165 |
|
|
|
166 |
|
|
-- Check that Adjust is called when evaluating an aggregate
|
167 |
|
|
-- component association for a controlled component.
|
168 |
|
|
|
169 |
|
|
procedure Subtest_2 is
|
170 |
|
|
S : C760007_0.Structure;
|
171 |
|
|
|
172 |
|
|
procedure Examine( Thing : in C760007_0.Structure ) is
|
173 |
|
|
begin
|
174 |
|
|
Check_Adjust_Count("Aggregate passed as parameter");
|
175 |
|
|
end Examine;
|
176 |
|
|
|
177 |
|
|
begin
|
178 |
|
|
-- this assignment must call Adjust:
|
179 |
|
|
-- 1: on the value resulting from the aggregate
|
180 |
|
|
-- ** unless this is optimized out by building the result directly
|
181 |
|
|
-- in the target object.
|
182 |
|
|
-- 2: on Object once it's been assigned
|
183 |
|
|
-- may call adjust
|
184 |
|
|
-- 1: for a anonymous object created in the evaluation of the aggregate
|
185 |
|
|
-- 2: for a anonymous object created in the assignment operation
|
186 |
|
|
S := ( Controlled_Component => Object );
|
187 |
|
|
Check_Adjust_Count("Aggregate and Assignment", 1, 4);
|
188 |
|
|
|
189 |
|
|
Examine( C760007_0.Structure'(Controlled_Component => Object) );
|
190 |
|
|
end Subtest_2;
|
191 |
|
|
|
192 |
|
|
-- Check that Adjust is called for the assignment of the ancestor
|
193 |
|
|
-- expression of an extension aggregate when the type of the
|
194 |
|
|
-- aggregate is controlled.
|
195 |
|
|
|
196 |
|
|
procedure Subtest_3 is
|
197 |
|
|
Bambino : C760007_0.Child;
|
198 |
|
|
|
199 |
|
|
procedure Examine( Thing : in C760007_0.Child ) is
|
200 |
|
|
begin
|
201 |
|
|
Check_Adjust_Count("Extension aggregate as parameter (ancestor)", 0, 2);
|
202 |
|
|
Check_Child_Adjust_Count("Extension aggregate as parameter", 0, 4);
|
203 |
|
|
end Examine;
|
204 |
|
|
|
205 |
|
|
begin
|
206 |
|
|
-- implementation permissions make all of the following calls to adjust
|
207 |
|
|
-- optional:
|
208 |
|
|
-- these assignments may call Adjust:
|
209 |
|
|
-- 1: on the value resulting from the aggregate
|
210 |
|
|
-- 2: on Object once it's been assigned
|
211 |
|
|
-- 3: for a anonymous object created in the evaluation of the aggregate
|
212 |
|
|
-- 4: for a anonymous object created in the assignment operation
|
213 |
|
|
Bambino := ( Object with TC_XX => 10 );
|
214 |
|
|
Check_Adjust_Count("Ancestor (expression) part of aggregate", 0, 2);
|
215 |
|
|
Check_Child_Adjust_Count("Child aggregate assignment 1", 0, 4 );
|
216 |
|
|
|
217 |
|
|
Bambino := ( C760007_0.Controlled with TC_XX => 11 );
|
218 |
|
|
Check_Adjust_Count("Ancestor (subtype_mark) part of aggregate", 0, 2);
|
219 |
|
|
Check_Child_Adjust_Count("Child aggregate assignment 2", 0, 4 );
|
220 |
|
|
|
221 |
|
|
Examine( ( Object with TC_XX => 21 ) );
|
222 |
|
|
|
223 |
|
|
Examine( ( C760007_0.Controlled with TC_XX => 37 ) );
|
224 |
|
|
|
225 |
|
|
end Subtest_3;
|
226 |
|
|
|
227 |
|
|
begin -- Main test procedure.
|
228 |
|
|
|
229 |
|
|
Report.Test ("C760007", "Check that Adjust is called for the " &
|
230 |
|
|
"execution of a return statement for a " &
|
231 |
|
|
"function returning a result containing a " &
|
232 |
|
|
"controlled type. Check that Adjust is " &
|
233 |
|
|
"called when evaluating an aggregate " &
|
234 |
|
|
"component association for a controlled " &
|
235 |
|
|
"component. " &
|
236 |
|
|
"Check that Adjust is called for the " &
|
237 |
|
|
"assignment of the ancestor expression of an " &
|
238 |
|
|
"extension aggregate when the type of the " &
|
239 |
|
|
"aggregate is controlled" );
|
240 |
|
|
|
241 |
|
|
Subtest_1;
|
242 |
|
|
Subtest_2;
|
243 |
|
|
Subtest_3;
|
244 |
|
|
|
245 |
|
|
Report.Result;
|
246 |
|
|
|
247 |
|
|
end C760007;
|