1 |
149 |
jeremybenn |
-- C640001.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 the prefix of a subprogram call with an actual parameter
|
28 |
|
|
-- part may be an implicit dereference of an access-to-subprogram value.
|
29 |
|
|
-- Check that, for an access-to-subprogram type whose designated profile
|
30 |
|
|
-- contains parameters of a tagged generic formal type, an access-to-
|
31 |
|
|
-- subprogram value may designate dispatching and non-dispatching
|
32 |
|
|
-- operations, and that dereferences of such a value call the appropriate
|
33 |
|
|
-- subprogram.
|
34 |
|
|
--
|
35 |
|
|
-- TEST DESCRIPTION:
|
36 |
|
|
-- The test declares a tagged type (Table) with a dispatching operation
|
37 |
|
|
-- (Clear), as well as a derivative (Table2) which overrides that
|
38 |
|
|
-- operation. A subprogram with the same name and profile as Clear is
|
39 |
|
|
-- declared in a separate package -- it is therefore not a dispatching
|
40 |
|
|
-- operation of Table. For the purposes of the test, each version of Clear
|
41 |
|
|
-- modifies the components of its parameter in a unique way.
|
42 |
|
|
--
|
43 |
|
|
-- Additionally, an operation (Reset) of type Table is declared which
|
44 |
|
|
-- makes a re-dispatching call to Clear, i.e.,
|
45 |
|
|
--
|
46 |
|
|
-- procedure Reset (A: in out Table) is
|
47 |
|
|
-- begin
|
48 |
|
|
-- ...
|
49 |
|
|
-- Clear (Table'Class(A)); -- Re-dispatch based on tag of actual.
|
50 |
|
|
-- ...
|
51 |
|
|
-- end Reset;
|
52 |
|
|
--
|
53 |
|
|
-- An access-to-subprogram type is declared within a generic package,
|
54 |
|
|
-- with a designated profile which declares a parameter of a generic
|
55 |
|
|
-- formal tagged private type.
|
56 |
|
|
--
|
57 |
|
|
-- The generic is instantiated with type Table. The instance defines an
|
58 |
|
|
-- array of access-to-subprogram values (which represents a table of
|
59 |
|
|
-- operations to be performed sequentially on a single operand).
|
60 |
|
|
-- Access values designating the dispatching version of Clear, the
|
61 |
|
|
-- non-dispatching version of Clear, and Reset (which re-dispatches to
|
62 |
|
|
-- Clear) are placed in this array.
|
63 |
|
|
--
|
64 |
|
|
-- In the instance, each subprogram in the array is called by implicitly
|
65 |
|
|
-- dereferencing the corresponding access value. For the dispatching and
|
66 |
|
|
-- non-dispatching versions of Clear, the actual parameter passed is of
|
67 |
|
|
-- type Table. For Reset, the actual parameter passed is a view conversion
|
68 |
|
|
-- of an object of type Table2 to type Table, i.e., Table(Table2_Obj).
|
69 |
|
|
-- Since the tag of the operand never changes, the call to Clear within
|
70 |
|
|
-- Reset should execute Table2's version of Clear.
|
71 |
|
|
--
|
72 |
|
|
-- The main program verifies that the appropriate version of Clear is
|
73 |
|
|
-- called in each case, by checking that the components of the actual are
|
74 |
|
|
-- updated as expected.
|
75 |
|
|
--
|
76 |
|
|
--
|
77 |
|
|
-- CHANGE HISTORY:
|
78 |
|
|
-- 06 Dec 94 SAIC ACVC 2.0
|
79 |
|
|
--
|
80 |
|
|
--!
|
81 |
|
|
|
82 |
|
|
package C640001_0 is
|
83 |
|
|
|
84 |
|
|
-- Data type artificial for testing purposes.
|
85 |
|
|
|
86 |
|
|
Row_Len : constant := 10;
|
87 |
|
|
|
88 |
|
|
T : constant Boolean := True;
|
89 |
|
|
F : constant Boolean := False;
|
90 |
|
|
|
91 |
|
|
type Row_Type is array (1 .. Row_Len) of Boolean;
|
92 |
|
|
|
93 |
|
|
function Is_True (A : in Row_Type) return Boolean;
|
94 |
|
|
function Is_False (A : in Row_Type) return Boolean;
|
95 |
|
|
|
96 |
|
|
|
97 |
|
|
Init : constant Row_Type := (T, F, T, F, T, F, T, F, T, F);
|
98 |
|
|
|
99 |
|
|
type Table is tagged record -- Tagged type.
|
100 |
|
|
Row1 : Row_Type := Init;
|
101 |
|
|
Row2 : Row_Type := Init;
|
102 |
|
|
end record;
|
103 |
|
|
|
104 |
|
|
procedure Clear (A : in out Table); -- Dispatching operation.
|
105 |
|
|
|
106 |
|
|
procedure Reset (A : in out Table); -- Re-dispatching operation.
|
107 |
|
|
|
108 |
|
|
-- ...Other operations.
|
109 |
|
|
|
110 |
|
|
|
111 |
|
|
type Table2 is new Table with null record; -- Extension of Table (but
|
112 |
|
|
-- structurally identical).
|
113 |
|
|
|
114 |
|
|
procedure Clear (A : in out Table2); -- Overrides parent's op.
|
115 |
|
|
|
116 |
|
|
-- ...Other operations.
|
117 |
|
|
|
118 |
|
|
|
119 |
|
|
end C640001_0;
|
120 |
|
|
|
121 |
|
|
|
122 |
|
|
--===================================================================--
|
123 |
|
|
|
124 |
|
|
|
125 |
|
|
package body C640001_0 is
|
126 |
|
|
|
127 |
|
|
function Is_True (A : in Row_Type) return Boolean is
|
128 |
|
|
begin
|
129 |
|
|
for I in A'Range loop
|
130 |
|
|
if A(I) /= True then -- Return true if all elements
|
131 |
|
|
return False; -- of A are True.
|
132 |
|
|
end if;
|
133 |
|
|
end loop;
|
134 |
|
|
return True;
|
135 |
|
|
end Is_True;
|
136 |
|
|
|
137 |
|
|
|
138 |
|
|
function Is_False (A : in Row_Type) return Boolean is
|
139 |
|
|
begin
|
140 |
|
|
return A = Row_Type'(others => False); -- Return true if all elements
|
141 |
|
|
end Is_False; -- of A are False.
|
142 |
|
|
|
143 |
|
|
|
144 |
|
|
procedure Clear (A : in out Table) is
|
145 |
|
|
begin
|
146 |
|
|
for I in Row_Type'Range loop -- This version of Clear sets
|
147 |
|
|
A.Row1(I) := False; -- the elements of Row1 only
|
148 |
|
|
end loop; -- to False.
|
149 |
|
|
end Clear;
|
150 |
|
|
|
151 |
|
|
|
152 |
|
|
procedure Reset (A : in out Table) is
|
153 |
|
|
begin
|
154 |
|
|
Clear (Table'Class(A)); -- Redispatch to appropriate
|
155 |
|
|
-- ... Other "reset" activities. -- version of Clear.
|
156 |
|
|
end Reset;
|
157 |
|
|
|
158 |
|
|
|
159 |
|
|
procedure Clear (A : in out Table2) is
|
160 |
|
|
begin
|
161 |
|
|
for I in Row_Type'Range loop -- This version of Clear sets
|
162 |
|
|
A.Row1(I) := True; -- the elements of Row1 only
|
163 |
|
|
end loop; -- to True.
|
164 |
|
|
end Clear;
|
165 |
|
|
|
166 |
|
|
|
167 |
|
|
end C640001_0;
|
168 |
|
|
|
169 |
|
|
|
170 |
|
|
--===================================================================--
|
171 |
|
|
|
172 |
|
|
|
173 |
|
|
with C640001_0;
|
174 |
|
|
package C640001_1 is
|
175 |
|
|
|
176 |
|
|
procedure Clear (T : in out C640001_0.Table); -- Non-dispatching operation.
|
177 |
|
|
|
178 |
|
|
end C640001_1;
|
179 |
|
|
|
180 |
|
|
|
181 |
|
|
--===================================================================--
|
182 |
|
|
|
183 |
|
|
|
184 |
|
|
package body C640001_1 is
|
185 |
|
|
|
186 |
|
|
procedure Clear (T : in out C640001_0.Table) is
|
187 |
|
|
begin
|
188 |
|
|
for I in C640001_0.Row_Type'Range loop -- This version of Clear sets
|
189 |
|
|
T.Row2(I) := True; -- the elements of Row2 only
|
190 |
|
|
end loop; -- to True.
|
191 |
|
|
end Clear;
|
192 |
|
|
|
193 |
|
|
end C640001_1;
|
194 |
|
|
|
195 |
|
|
|
196 |
|
|
--===================================================================--
|
197 |
|
|
|
198 |
|
|
|
199 |
|
|
-- This unit represents a support package for table-driven processing of
|
200 |
|
|
-- data objects. Process_Operand performs a set of operations are performed
|
201 |
|
|
-- sequentially on a single operand. Note that parameters are provided to
|
202 |
|
|
-- specify which subset of operations in the operations table are to be
|
203 |
|
|
-- performed (ordinarily these might be omitted, but the test requires that
|
204 |
|
|
-- each operation be called individually for a single operand).
|
205 |
|
|
|
206 |
|
|
generic
|
207 |
|
|
type Tag is tagged private;
|
208 |
|
|
package C640001_2 is
|
209 |
|
|
|
210 |
|
|
type Proc_Ptr is access procedure (P: in out Tag);
|
211 |
|
|
|
212 |
|
|
type Op_List is private;
|
213 |
|
|
|
214 |
|
|
procedure Add_Op (Op : in Proc_Ptr; -- Add operation to
|
215 |
|
|
List : in out Op_List); -- to list of ops.
|
216 |
|
|
|
217 |
|
|
procedure Process_Operand (Operand : in out Tag; -- Execute a subset
|
218 |
|
|
List : in Op_List; -- of a list of
|
219 |
|
|
First_Op : in Positive; -- operations using
|
220 |
|
|
Last_Op : in Positive); -- a given operand.
|
221 |
|
|
|
222 |
|
|
-- ...Other operations.
|
223 |
|
|
|
224 |
|
|
private
|
225 |
|
|
type Op_Array is array (1 .. 3) of Proc_Ptr;
|
226 |
|
|
|
227 |
|
|
type Op_List is record
|
228 |
|
|
Top : Natural := 0;
|
229 |
|
|
Ops : Op_Array;
|
230 |
|
|
end record;
|
231 |
|
|
end C640001_2;
|
232 |
|
|
|
233 |
|
|
|
234 |
|
|
--===================================================================--
|
235 |
|
|
|
236 |
|
|
|
237 |
|
|
package body C640001_2 is
|
238 |
|
|
|
239 |
|
|
procedure Add_Op (Op : in Proc_Ptr;
|
240 |
|
|
List : in out Op_List) is
|
241 |
|
|
begin
|
242 |
|
|
List.Top := List.Top + 1; -- Artificial; no Constraint_Error protection.
|
243 |
|
|
List.Ops(List.Top) := Op;
|
244 |
|
|
end Add_Op;
|
245 |
|
|
|
246 |
|
|
|
247 |
|
|
procedure Process_Operand (Operand : in out Tag;
|
248 |
|
|
List : in Op_List;
|
249 |
|
|
First_Op : in Positive;
|
250 |
|
|
Last_Op : in Positive) is
|
251 |
|
|
begin
|
252 |
|
|
for I in First_Op .. Last_Op loop
|
253 |
|
|
List.Ops(I)(Operand); -- Implicit dereference of an
|
254 |
|
|
end loop; -- access-to-subprogram value.
|
255 |
|
|
end Process_Operand;
|
256 |
|
|
|
257 |
|
|
end C640001_2;
|
258 |
|
|
|
259 |
|
|
|
260 |
|
|
--===================================================================--
|
261 |
|
|
|
262 |
|
|
|
263 |
|
|
with C640001_0;
|
264 |
|
|
with C640001_1;
|
265 |
|
|
with C640001_2;
|
266 |
|
|
|
267 |
|
|
with Report;
|
268 |
|
|
procedure C640001 is
|
269 |
|
|
|
270 |
|
|
package Table_Support is new C640001_2 (C640001_0.Table);
|
271 |
|
|
|
272 |
|
|
Sub_Ptr : Table_Support.Proc_Ptr;
|
273 |
|
|
My_List : Table_Support.Op_List;
|
274 |
|
|
My_Table1 : C640001_0.Table; -- Initial values of both Row1 &
|
275 |
|
|
-- Row2 are (T,F,T,F,T,F,T,F,T,F).
|
276 |
|
|
My_Table2 : C640001_0.Table2; -- Initial values of both Row1 &
|
277 |
|
|
-- Row2 are (T,F,T,F,T,F,T,F,T,F).
|
278 |
|
|
begin
|
279 |
|
|
Report.Test ("C640001", "Check that, for an access-to-subprogram type " &
|
280 |
|
|
"whose designated profile contains parameters " &
|
281 |
|
|
"of a tagged generic formal type, an access-" &
|
282 |
|
|
"to-subprogram value may designate dispatching " &
|
283 |
|
|
"and non-dispatching operations");
|
284 |
|
|
|
285 |
|
|
--
|
286 |
|
|
-- Add subprogram access values to list:
|
287 |
|
|
--
|
288 |
|
|
|
289 |
|
|
Sub_Ptr := C640001_0.Clear'Access; -- Designates dispatching op.
|
290 |
|
|
Table_Support.Add_Op (Sub_Ptr, My_List); -- (1st operation on My_List).
|
291 |
|
|
|
292 |
|
|
Sub_Ptr := C640001_1.Clear'Access; -- Designates non-dispatching op.
|
293 |
|
|
Table_Support.Add_Op (Sub_Ptr, My_List); -- (2nd operation on My_List).
|
294 |
|
|
|
295 |
|
|
Sub_Ptr := C640001_0.Reset'Access; -- Designates re-dispatching op.
|
296 |
|
|
Table_Support.Add_Op (Sub_Ptr, My_List); -- (3rd operation on My_List).
|
297 |
|
|
|
298 |
|
|
|
299 |
|
|
--
|
300 |
|
|
-- Call dispatching operation:
|
301 |
|
|
--
|
302 |
|
|
|
303 |
|
|
Table_Support.Process_Operand (My_Table1, My_List, 1, 1); -- Call 1st op.
|
304 |
|
|
|
305 |
|
|
if not C640001_0.Is_False (My_Table1.Row1) then
|
306 |
|
|
Report.Failed ("Wrong result after calling dispatching operation");
|
307 |
|
|
end if;
|
308 |
|
|
|
309 |
|
|
|
310 |
|
|
--
|
311 |
|
|
-- Call non-dispatching operation:
|
312 |
|
|
--
|
313 |
|
|
|
314 |
|
|
Table_Support.Process_Operand (My_Table1, My_List, 2, 2); -- Call 2nd op.
|
315 |
|
|
|
316 |
|
|
if not C640001_0.Is_True (My_Table1.Row2) then
|
317 |
|
|
Report.Failed ("Wrong result after calling non-dispatching operation");
|
318 |
|
|
end if;
|
319 |
|
|
|
320 |
|
|
|
321 |
|
|
--
|
322 |
|
|
-- Call re-dispatching operation:
|
323 |
|
|
--
|
324 |
|
|
|
325 |
|
|
Table_Support.Process_Operand (C640001_0.Table(My_Table2), -- View conv.
|
326 |
|
|
My_List, 3, 3); -- Call 3rd op.
|
327 |
|
|
|
328 |
|
|
if not C640001_0.Is_True (My_Table2.Row1) then
|
329 |
|
|
Report.Failed ("Wrong result after calling re-dispatching operation");
|
330 |
|
|
end if;
|
331 |
|
|
|
332 |
|
|
|
333 |
|
|
Report.Result;
|
334 |
|
|
end C640001;
|