3 -- Grant of Unlimited Rights
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
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.
27 -- Check that a subprogram dispatches correctly with a controlling
28 -- access parameter. Check that a subprogram dispatches correctly
29 -- when it has access parameters that are not controlling.
30 -- Check with and without default expressions.
33 -- The three packages define layers of tagged types. The root tagged
34 -- type contains a character value used to check that the right object
35 -- got passed to the right routine. Each subprogram has a unique
36 -- TCTouch tag, upper case values are used for subprograms, lower case
37 -- values are used for object values.
39 -- Notes on style: the "tagged" comment lines --I and --A represent
40 -- commentary about what gets inherited and what becomes abstract,
41 -- respectively. The author felt these to be necessary with this test
42 -- to reduce some of the additional complexities.
44 --3.9.2(16,17,18,20);6.0
47 -- 22 SEP 95 SAIC Initial version
48 -- 22 APR 96 SAIC Revised for 2.1
49 -- 05 JAN 98 EDS Change return type of C392010_2.Func_W_Non to make
51 -- 21 JUN 00 RLB Changed expected result to reflect the appropriate
52 -- value of the default expression.
53 -- 20 JUL 00 RLB Removed entire call pending resolution by the ARG.
57 ----------------------------------------------------------------- C392010_0
61 -- define a root tagged type
62 type Tagtype_Level_0
is tagged record
66 type Access_Procedure
is access procedure( P
: Tagtype_Level_0
);
68 procedure Proc_1
( P
: Tagtype_Level_0
);
70 procedure Proc_2
( P
: Tagtype_Level_0
);
72 function A_Default_Value
return Tagtype_Level_0
;
74 procedure Proc_w_Ap_and_Cp
( AP
: Access_Procedure
;
75 Cp
: Tagtype_Level_0
);
76 -- has both access procedure and controlling parameter
78 procedure Proc_w_Ap_and_Cp_w_Def
( AP
: Access_Procedure
:= Proc_2
'Access;
80 := A_Default_Value
); ------------ z
81 -- has both access procedure and controlling parameter with defaults
84 -- Check that access parameters may be controlling.
86 procedure Proc_w_Cp_Ap
( Cp_Ap
: access Tagtype_Level_0
);
87 -- has access parameter that is controlling
89 function Func_w_Cp_Ap_and_Cr
( Cp_Ap
: access Tagtype_Level_0
)
90 return Tagtype_Level_0
;
91 -- has access parameter that is controlling, and controlling result
93 Level_0_Global_Object
: aliased Tagtype_Level_0
94 := ( Ch_Item
=> 'a' ); ---------------------------- a
98 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
101 package body C392010_0
is
103 procedure Proc_1
( P
: Tagtype_Level_0
) is
105 TCTouch
.Touch
('A'); --------------------------------------------------- A
106 TCTouch
.Touch
(P
.Ch_Item
); -- depends on the value passed -------------- ?
109 procedure Proc_2
( P
: Tagtype_Level_0
) is
111 TCTouch
.Touch
('B'); --------------------------------------------------- B
112 TCTouch
.Touch
(P
.Ch_Item
); -- depends on the value passed -------------- ?
115 function A_Default_Value
return Tagtype_Level_0
is
117 return (Ch_Item
=> 'z'); ---------------------------------------------- z
120 procedure Proc_w_Ap_and_Cp
( Ap
: Access_Procedure
;
121 Cp
: Tagtype_Level_0
) is
123 TCTouch
.Touch
('C'); --------------------------------------------------- C
125 end Proc_w_Ap_and_Cp
;
127 procedure Proc_w_Ap_and_Cp_w_Def
( AP
: Access_Procedure
:= Proc_2
'Access;
129 := A_Default_Value
) is
131 TCTouch
.Touch
('D'); --------------------------------------------------- D
133 end Proc_w_Ap_and_Cp_w_Def
;
135 procedure Proc_w_Cp_Ap
( Cp_Ap
: access Tagtype_Level_0
) is
137 TCTouch
.Touch
('E'); --------------------------------------------------- E
138 TCTouch
.Touch
(Cp_Ap
.Ch_Item
); -- depends on the value passed ---------- ?
141 function Func_w_Cp_Ap_and_Cr
( Cp_Ap
: access Tagtype_Level_0
)
142 return Tagtype_Level_0
is
144 TCTouch
.Touch
('F'); --------------------------------------------------- F
145 TCTouch
.Touch
(Cp_Ap
.Ch_Item
); -- depends on the value passed ---------- ?
146 return ( Ch_Item
=> 'b' ); -------------------------------------------- b
147 end Func_w_Cp_Ap_and_Cr
;
151 ----------------------------------------------------------------- C392010_1
156 type Tagtype_Level_1
is new C392010_0
.Tagtype_Level_0
with record
160 type Access_Tagtype_Level_1
is access all Tagtype_Level_1
'Class;
162 -- the following procedures are inherited by the above declaration:
163 --I procedure Proc_1( P: Tagtype_Level_1 );
165 --I procedure Proc_2( P: Tagtype_Level_1 );
167 --I procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure;
168 --I Cp : Tagtype_Level_1 );
170 --I procedure Proc_w_Ap_and_Cp_w_Def
171 --I ( AP : C392010_0.Access_Procedure := Proc_2'Access;
172 --I Cp : Tagtype_Level_1 := A_Default_Value );
174 --I procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_1 );
177 -- the following functions become abstract due to the above declaration:
178 --A function A_Default_Value return Tagtype_Level_1;
180 --A function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_1 )
181 --A return Tagtype_Level_1;
183 -- so, in the interest of testing dispatching, we override them all:
184 -- except Proc_1 and Proc_2
186 procedure Proc_w_Ap_and_Cp
( AP
: C392010_0
.Access_Procedure
;
187 Cp
: Tagtype_Level_1
);
189 function A_Default_Value
return Tagtype_Level_1
;
191 procedure Proc_w_Ap_and_Cp_w_Def
(
192 AP
: C392010_0
.Access_Procedure
:= C392010_0
.Proc_2
'Access;
193 Cp
: Tagtype_Level_1
:= A_Default_Value
);
195 procedure Proc_w_Cp_Ap
( Cp_Ap
: access Tagtype_Level_1
);
197 function Func_w_Cp_Ap_and_Cr
( Cp_Ap
: access Tagtype_Level_1
)
198 return Tagtype_Level_1
;
200 -- to test the objective:
201 -- Check that a subprogram dispatches correctly when it has
202 -- access parameters that are not controlling.
204 procedure Proc_w_Non
( Cp_Ap
: access Tagtype_Level_1
;
205 NonCp_Ap
: access C392010_0
.Tagtype_Level_0
206 := C392010_0
.Level_0_Global_Object
'Access );
208 function Func_w_Non
( Cp_Ap
: access Tagtype_Level_1
;
209 NonCp_Ap
: access C392010_0
.Tagtype_Level_0
210 := C392010_0
.Level_0_Global_Object
'Access )
211 return Access_Tagtype_Level_1
;
213 Level_1_Global_Object
: aliased Tagtype_Level_1
215 Ch_Item
=> 'c' ); --------------------------- c
219 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
222 package body C392010_1
is
224 procedure Proc_w_Ap_and_Cp
( AP
: C392010_0
.Access_Procedure
;
225 Cp
: Tagtype_Level_1
) is
227 TCTouch
.Touch
('G'); --------------------------------------------------- G
228 Ap
.All( C392010_0
.Tagtype_Level_0
( Cp
) );
229 end Proc_w_Ap_and_Cp
;
231 procedure Proc_w_Ap_and_Cp_w_Def
(
232 AP
: C392010_0
.Access_Procedure
:= C392010_0
.Proc_2
'Access;
233 Cp
: Tagtype_Level_1
:= A_Default_Value
)
236 TCTouch
.Touch
('H'); --------------------------------------------------- H
237 Ap
.All( C392010_0
.Tagtype_Level_0
( Cp
) );
238 end Proc_w_Ap_and_Cp_w_Def
;
240 procedure Proc_w_Cp_Ap
( Cp_Ap
: access Tagtype_Level_1
) is
242 TCTouch
.Touch
('I'); --------------------------------------------------- I
243 TCTouch
.Touch
(Cp_Ap
.Ch_Item
); -- depends on the value passed ---------- ?
246 function A_Default_Value
return Tagtype_Level_1
is
248 return ( Int_Item
=> 0, Ch_Item
=> 'y' ); ---------------------------- y
251 function Func_w_Cp_Ap_and_Cr
( Cp_Ap
: access Tagtype_Level_1
)
252 return Tagtype_Level_1
is
254 TCTouch
.Touch
('J'); --------------------------------------------------- J
255 TCTouch
.Touch
(Cp_Ap
.Ch_Item
); -- depends on the value passed ---------- ?
256 return ( Int_Item
=> 2, Ch_Item
=> 'd' ); ----------------------------- d
257 end Func_w_Cp_Ap_and_Cr
;
259 procedure Proc_w_Non
( Cp_Ap
: access Tagtype_Level_1
;
260 NonCp_Ap
: access C392010_0
.Tagtype_Level_0
261 := C392010_0
.Level_0_Global_Object
'Access ) is
263 TCTouch
.Touch
('K'); --------------------------------------------------- K
264 TCTouch
.Touch
(Cp_Ap
.Ch_Item
); ----- depends on the value passed ------- ?
265 TCTouch
.Touch
(NonCp_Ap
.Ch_Item
); -- depends on the value passed ------- ?
268 Own_Item
: aliased Tagtype_Level_1
:= ( Int_Item
=> 3, Ch_Item
=> 'e' );
270 function Func_w_Non
( Cp_Ap
: access Tagtype_Level_1
;
271 NonCp_Ap
: access C392010_0
.Tagtype_Level_0
272 := C392010_0
.Level_0_Global_Object
'Access )
273 return Access_Tagtype_Level_1
is
275 TCTouch
.Touch
('L'); --------------------------------------------------- L
276 TCTouch
.Touch
(Cp_Ap
.Ch_Item
); ----- depends on the value passed ------- ?
277 TCTouch
.Touch
(NonCp_Ap
.Ch_Item
); -- depends on the value passed ------- ?
278 return Own_Item
'Access; ----------------------------------------------- e
285 ----------------------------------------------------------------- C392010_2
291 Lev2_Level_0_Global_Object
: aliased C392010_0
.Tagtype_Level_0
292 := ( Ch_Item
=> 'f' ); ---------------------------- f
294 type Tagtype_Level_2
is new C392010_1
.Tagtype_Level_1
with record
295 Another_Int_Item
: Integer;
298 type Access_Tagtype_Level_2
is access all Tagtype_Level_2
;
300 -- the following procedures are inherited by the above declaration:
301 --I procedure Proc_1( P: Tagtype_Level_2 );
303 --I procedure Proc_2( P: Tagtype_Level_2 );
305 --I procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure;
306 --I Cp : Tagtype_Level_2 );
308 --I procedure Proc_w_Ap_and_Cp_w_Def
309 --I (AP: C392010_0.Access_Procedure := C392010_0. Proc_2'Access;
310 --I CP: Tagtype_Level_2 := A_Default_Value );
312 --I procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_2 );
314 --I procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_2;
315 --I NonCp_Ap : access C392010_0.Tagtype_Level_0
316 --I := C392010_0.Level_0_Global_Object'Access );
318 -- the following functions become abstract due to the above declaration:
319 --A function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_2 )
320 --A return Tagtype_Level_2;
322 --A function A_Default_Value
323 --A return Access_Tagtype_Level_2;
325 -- so we override the interesting ones to check the objective:
326 -- Check that a subprogram with parameters of distinct tagged types may
327 -- be primitive for only one type (i.e. the other tagged types must be
328 -- declared in other packages). Check that the subprogram does not
329 -- dispatch for the other type(s).
331 procedure Proc_w_Non
( Cp_Ap
: access Tagtype_Level_2
;
332 NonCp_Ap
: access C392010_0
.Tagtype_Level_0
333 := Lev2_Level_0_Global_Object
'Access );
335 function Func_w_Non
( Cp_Ap
: access Tagtype_Level_2
;
336 NonCp_Ap
: access C392010_0
.Tagtype_Level_0
337 := Lev2_Level_0_Global_Object
'Access )
338 return C392010_1
.Access_Tagtype_Level_1
;
340 -- and override the other abstract functions
341 function Func_w_Cp_Ap_and_Cr
( Cp_Ap
: access Tagtype_Level_2
)
342 return Tagtype_Level_2
;
344 function A_Default_Value
return Tagtype_Level_2
;
348 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
352 package body C392010_2
is
354 procedure Proc_w_Non
( Cp_Ap
: access Tagtype_Level_2
;
355 NonCp_Ap
: access C392010_0
.Tagtype_Level_0
356 := Lev2_Level_0_Global_Object
'Access ) is
358 TCTouch
.Touch
('M'); --------------------------------------------------- M
359 TCTouch
.Touch
(Cp_Ap
.Ch_Item
); ----- depends on the value passed ------- ?
360 TCTouch
.Touch
(NonCp_Ap
.Ch_Item
); -- depends on the value passed ------- ?
363 function A_Default_Value
return Tagtype_Level_2
is
365 return ( Another_Int_Item | Int_Item
=> 0, Ch_Item
=> 'x' ); -------- x
368 Own
: aliased Tagtype_Level_2
369 := ( Another_Int_Item | Int_Item
=> 4, Ch_Item
=> 'g' );
371 function Func_w_Non
( Cp_Ap
: access Tagtype_Level_2
;
372 NonCp_Ap
: access C392010_0
.Tagtype_Level_0
373 := Lev2_Level_0_Global_Object
'Access )
374 return C392010_1
.Access_Tagtype_Level_1
is
376 TCTouch
.Touch
('N'); --------------------------------------------------- N
377 TCTouch
.Touch
(Cp_Ap
.Ch_Item
); ----- depends on the value passed ------- ?
378 TCTouch
.Touch
(NonCp_Ap
.Ch_Item
); -- depends on the value passed ------- ?
379 return Own
'Access; ---------------------------------------------------- g
382 function Func_w_Cp_Ap_and_Cr
( Cp_Ap
: access Tagtype_Level_2
)
383 return Tagtype_Level_2
is
385 TCTouch
.Touch
('P'); --------------------------------------------------- P
386 TCTouch
.Touch
(Cp_Ap
.Ch_Item
); ----- depends on the value passed ------- ?
387 return ( Another_Int_Item | Int_Item
=> 5, Ch_Item
=> 'h' ); ---------- h
388 end Func_w_Cp_Ap_and_Cr
;
394 ------------------------------------------------------------------- C392010
398 with C392010_0
, C392010_1
, C392010_2
;
402 type Access_Class_0
is access all C392010_0
.Tagtype_Level_0
'Class;
404 -- define an array of class-wide pointers:
405 type Zero_Dispatch_List
is array(Natural range <>) of Access_Class_0
;
407 Item_0
: aliased C392010_0
.Tagtype_Level_0
:= ( Ch_Item
=> 'k' ); ------ k
408 Item_1
: aliased C392010_1
.Tagtype_Level_1
:= ( Ch_Item
=> 'm', ------ m
410 Item_2
: aliased C392010_2
.Tagtype_Level_2
:= ( Ch_Item
=> 'n', ------ n
412 Another_Int_Item
=> 1 );
414 Z
: Zero_Dispatch_List
(1..3) := (Item_0
'Access,Item_1
'Access,Item_2
'Access);
416 procedure Subtest_1
( Items
: Zero_Dispatch_List
) is
417 -- there is little difference between the actions for _1 and _2 in
418 -- this subtest due to the nature of _2 inheriting most operations
420 -- this subtest checks operations available to Level_0'Class
422 for I
in Items
'Range loop
424 C392010_0
.Proc_w_Ap_and_Cp
( C392010_0
.Proc_1
'Access, Items
(I
).all );
426 -- actual is class-wide, operation should dispatch
428 case I
is -- use defaults
429 when 1 => C392010_0
.Proc_w_Ap_and_Cp_w_Def
;
431 when 2 => C392010_1
.Proc_w_Ap_and_Cp_w_Def
;
433 when 3 => null; -- Removed following pending resolution by ARG
435 -- C392010_2.Proc_w_Ap_and_Cp_w_Def;
437 when others => Report
.Failed
("Unexpected loop value");
440 C392010_0
.Proc_w_Ap_and_Cp_w_Def
-- override defaults
441 ( C392010_0
.Proc_1
'Access, Items
(I
).all );
444 C392010_0
.Proc_w_Cp_Ap
( Items
(I
) );
447 -- function return value is controlling for procedure call
448 C392010_0
.Proc_w_Ap_and_Cp_w_Def
( C392010_0
.Proc_1
'Access,
449 C392010_0
.Func_w_Cp_Ap_and_Cr
( Items
(I
) ) );
450 -- FkDAb, JmHAd, PnHAh
451 -- note that the function evaluates first
456 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
458 type Access_Class_1
is access all C392010_1
.Tagtype_Level_1
'Class;
460 type One_Dispatch_List
is array(Natural range <>) of Access_Class_1
;
462 Object_1
: aliased C392010_1
.Tagtype_Level_1
:= ( Ch_Item
=> 'p', ----- p
464 Object_2
: aliased C392010_2
.Tagtype_Level_2
:= ( Ch_Item
=> 'q', ----- q
466 Another_Int_Item
=> 1 );
468 D
: One_Dispatch_List
(1..2) := (Object_1
'Access, Object_2
'Access);
470 procedure Subtest_2
( Items
: One_Dispatch_List
) is
471 -- this subtest checks operations available to Level_1'Class,
472 -- specifically those operations that are not testable in subtest_1,
473 -- the operations with parameters of the two tagged type objects.
475 for I
in Items
'Range loop
477 C392010_1
.Proc_w_Non
( -- t_1, t_2
478 C392010_1
.Func_w_Non
( Items
(I
),
479 C392010_0
.Tagtype_Level_0
(Z
(I
).all)'Access ), -- Lpk Nqm
480 C392010_0
.Tagtype_Level_0
(Z
(I
+1).all)'Access ); -- Kem Mgn
485 begin -- Main test procedure.
487 Report
.Test
("C392010", "Check that a subprogram dispatches correctly " &
488 "with a controlling access parameter. " &
489 "Check that a subprogram dispatches correctly " &
490 "when it has access parameters that are not " &
491 "controlling. Check with and without default " &
497 --TCTouch.Validate( "CAkDBzDAkEkFkDAb"
498 -- & "GAmHByHAmImJmHAd"
499 -- & "GAnHBxHAnInPnHAh", "Subtest 1" );
501 -- Result pending resultion of AI-239:
502 TCTouch
.Validate
( "CAkDBzDAkEkFkDAb"
504 & "GAnHAnInPnHAh", "Subtest 1" );
508 TCTouch
.Validate
( "LpkKem" & "NqmMgn", "Subtest 2" );