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, for an implicitly declared dispatching operation that is
28 -- overridden, the body executed is the body for the overriding
29 -- subprogram, even if the overriding occurs in a private part.
30 -- Check that, for an implicitly declared dispatching operation that is
31 -- NOT overridden, the body executed is the body of the corresponding
32 -- subprogram of the parent type.
34 -- Check for the case where the overriding (and non-overriding) operations
35 -- are declared for a private extension (and its full type) in a public
36 -- child unit of the package declaring the ancestor type, and the ancestor
37 -- type is a tagged private type whose full view is itself a derived type.
43 -- type Root is tagged ...
44 -- procedure Vis_Op (P: Root);
46 -- procedure Pri_Op (P: Root); -- (A)
49 -- package Intermediate is
50 -- type Mid is tagged private;
52 -- type Mid is new Parent.Root with record ...
53 -- -- Implicit Vis_Op (P: Mid) declared here.
55 -- procedure Vis_Op (P: Mid); -- (B)
58 -- package Intermediate.Child is
59 -- type Derived is new Mid with private;
61 -- procedure Pri_Op (P: Derived); -- (C)
65 -- type Derived is new Mid with record...
66 -- -- Implicit Vis_Op (P: Derived) declared here.
68 -- end Intermediate.Child;
70 -- Type Derived inherits Vis_Op from the parent type Mid. Note, however,
71 -- that it is implicitly declared in the private part (inherited
72 -- subprograms for a derived_type_definition -- in this case, the full
73 -- type -- are implicitly declared at the earliest place within the
74 -- immediate scope of the type_declaration where the corresponding
75 -- declaration from the parent is visible).
77 -- Because Parent.Pri_Op is never visible within the immediate scope
78 -- of Mid, it is not implicitly declared for Mid. Thus, it is also not
79 -- implicitly declared for Derived. As a result, the version of Pri_Op
80 -- declared at (C) above does not override an inherited version of
81 -- Parent.Pri_Op and is totally unrelated to it.
83 -- Dispatching calls with tag Mid will execute (A) and (B). Dispatching
84 -- calls with tag Derived from Parent will execute the bodies of (B)
85 -- and (A). Dispatching calls with tag Derived from Parent.Child
86 -- will execute the bodies of (B) and (C).
89 -- The following files comprise this test:
96 -- 06 Dec 94 SAIC ACVC 2.0
103 type Zoom_Camera
is tagged private;
105 procedure Self_Test
(C
: in out Zoom_Camera
'Class);
107 -- ...Additional operations.
110 function TC_Correct_Result
(C
: Zoom_Camera
;
111 D
: F392D00
.Depth_Of_Field
;
112 S
: F392D00
.Shutter_Speed
) return Boolean;
116 type Magnification
is (Low
, Medium
, High
);
118 type Zoom_Camera
is new F392D00
.Remote_Camera
with record
122 -- procedure Focus (C : in out Zoom_Camera; -- Implicitly
123 -- Depth : in Depth_Of_Field) -- declared
126 procedure Focus
(C
: in out Zoom_Camera
; -- Overrides
127 Depth
: in F392D00
.Depth_Of_Field
); -- inherited op.
129 -- For the remote zoom camera, perhaps the focusing algorithm is different
130 -- in some way, so the original Focus operation is overridden here.
132 -- Since the partial view is not an extension, the overriding operation
133 -- must be declared after the full type. This version of Focus, although
134 -- not visible for type Zoom_Camera from outside the package, can still be
138 -- Note: F392D00.Set_Shutter_Speed is inherited by Zoom_Camera from
139 -- F392D00.Remote_Camera, but since the operation never becomes visible
140 -- within the immediate scope of Zoom_Camera, it is never implicitly
146 --==================================================================--
149 package body C392D01_0
is
151 procedure Focus
(C
: in out Zoom_Camera
;
152 Depth
: in F392D00
.Depth_Of_Field
) is
154 -- Artificial for testing purposes.
158 -----------------------------------------------------------
159 -- Indirect call to F392D00.Self_Test since the main does not know
160 -- that Zoom_Camera is a private extension of F392D00.Basic_Camera.
161 procedure Self_Test
(C
: in out Zoom_Camera
'Class) is
163 F392D00
.Self_Test
(C
);
164 -- ...Additional self-testing.
167 -----------------------------------------------------------
168 function TC_Correct_Result
(C
: Zoom_Camera
;
169 D
: F392D00
.Depth_Of_Field
;
170 S
: F392D00
.Shutter_Speed
) return Boolean is
171 use type F392D00
.Depth_Of_Field
;
172 use type F392D00
.Shutter_Speed
;
174 return (C
.DOF
= D
and C
.Shutter
= S
);
175 end TC_Correct_Result
;
180 --==================================================================--
184 package C392D01_0
.C392D01_1
is
186 type Film_Speed
is private;
188 type Auto_Speed
is new Zoom_Camera
with private;
190 -- Implicit function TC_Correct_Result (Auto_Speed) declared here.
192 procedure Set_Shutter_Speed
(C
: in out Auto_Speed
;
193 Speed
: in F392D00
.Shutter_Speed
);
195 -- This version of Set_Shutter_Speed does NOT override the operation
196 -- inherited from Zoom_Camera, because the inherited operation is never
197 -- visible (and thus, is never implicitly declared) within the immediate
198 -- scope of type Auto_Speed.
200 procedure Self_Test
(C
: in out Auto_Speed
'Class);
202 -- ...Other operations.
205 type Film_Speed
is (One_Hundred
, Two_Hundred
, Four_Hundred
);
207 type Auto_Speed
is new Zoom_Camera
with record
211 -- procedure Focus (C : in out Auto_Speed; -- Implicitly
212 -- Depth : in F392D00.Depth_Of_Field); -- declared
215 end C392D01_0
.C392D01_1
;
218 --==================================================================--
221 package body C392D01_0
.C392D01_1
is
223 procedure Set_Shutter_Speed
(C
: in out Auto_Speed
;
224 Speed
: in F392D00
.Shutter_Speed
) is
226 -- Artificial for testing purposes.
227 C
.Shutter
:= F392D00
.Two_Fifty
;
228 end Set_Shutter_Speed
;
230 -------------------------------------------------------
231 procedure Self_Test
(C
: in out Auto_Speed
'Class) is
233 -- Artificial for testing purposes.
234 Set_Shutter_Speed
(C
, F392D00
.Thousand
);
238 end C392D01_0
.C392D01_1
;
241 --==================================================================--
245 with C392D01_0
.C392D01_1
;
250 Zooming_Camera
: C392D01_0
.Zoom_Camera
;
251 Auto_Camera1
: C392D01_0
.C392D01_1
.Auto_Speed
;
252 Auto_Camera2
: C392D01_0
.C392D01_1
.Auto_Speed
;
254 TC_Expected_Zoom_Depth
: constant F392D00
.Depth_Of_Field
:= 83;
255 TC_Expected_Auto_Depth
: constant F392D00
.Depth_Of_Field
:= 83;
256 TC_Expected_Depth
: constant F392D00
.Depth_Of_Field
:= 83;
257 TC_Expected_Zoom_Speed
: constant F392D00
.Shutter_Speed
259 TC_Expected_Auto_Speed
: constant F392D00
.Shutter_Speed
261 TC_Expected_Speed
: constant F392D00
.Shutter_Speed
262 := F392D00
.Two_Fifty
;
264 use type F392D00
.Depth_Of_Field
;
265 use type F392D00
.Shutter_Speed
;
268 Report
.Test
("C392D01", "Dispatching for overridden and non-overridden " &
269 "primitive subprograms: private extension declared in child " &
270 "unit, parent is tagged private whose full view is derived " &
275 -- Call the class-wide operation (Self_Test) for Zoom_Camera'Class, which
276 -- itself calls the class-wide operation for Remote_Camera'Class, which
277 -- in turn makes dispatching calls to Focus and Set_Shutter_Speed:
280 -- For an object of type Zoom_Camera, the dispatching call to Focus should
281 -- dispatch to the body explicitly declared for Zoom_Camera. The dispatching
282 -- to Set_Shutter_Speed should dispatch to the body declared for
285 C392D01_0
.Self_Test
(Zooming_Camera
);
287 if not C392D01_0
.TC_Correct_Result
(Zooming_Camera
,
288 TC_Expected_Zoom_Depth
,
289 TC_Expected_Zoom_Speed
)
291 Report
.Failed
("Calls dispatched incorrectly for tagged private type");
294 -- For an object of type Auto_Speed, the dispatching call to Focus should
295 -- dispatch to the body explicitly declared for Zoom_Camera. The dispatching
296 -- call to Set_Shutter_Speed should dispatch to the body explicitly declared
297 -- for Remote_Camera:
299 C392D01_0
.Self_Test
(Auto_Camera1
);
301 if not C392D01_0
.C392D01_1
.TC_Correct_Result
(Auto_Camera1
,
302 TC_Expected_Auto_Depth
,
303 TC_Expected_Auto_Speed
)
305 Report
.Failed
("Calls dispatched incorrectly for private extension");
308 -- Call to Self_Test from C392D01_0.C392D01_1 invokes the dispatching call
309 -- to Focus which should dispatch to the body explicitly declared for
310 -- Zoom_Camera. The dispatching call to Set_Shutter_Speed should dispatch
311 -- to the body explicitly declared for Auto_Speed:
313 C392D01_0
.C392D01_1
.Self_Test
(Auto_Camera2
);
315 if not C392D01_0
.C392D01_1
.TC_Correct_Result
(Auto_Camera2
,
319 Report
.Failed
("Call to explicit subprogram executed the wrong body");