1-- C392D03.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, for an inherited dispatching operation that is overridden,
28--      the body executed is the body of the overriding subprogram, even if
29--      the overriding occurs in a private part.
30--
31--      Check for the case where the overriding operation is declared in a
32--      separate (non-child) package from that declaring the parent type, and
33--      the descendant type is a record extension.
34--
35--      Check for both dispatching and nondispatching calls.
36--
37-- TEST DESCRIPTION:
38--      Consider:
39--
40--      package P is
41--         type Root is tagged ...
42--         procedure Op (A: Root);
43--      end P;
44--
45--      with P;
46--      package Q is
47--         type Derived1 is new P.Root with record...
48--         -- Implicit procedure Op (A: Derived1) declared here.
49--         type Derived2 is new P.Root with private...
50--         -- Implicit procedure Op (A: Derived2) declared here.
51--         type New_Derived is new Derived1 with private...
52--         -- Implicit procedure Op (A: New_Derived) declared here.
53--      private
54--         procedure Op (A: Derived1);  -- Overrides parent's Op.
55--         type Derived2 is new P.Root with record...
56--         procedure Op (A: Derived2);  -- Overrides parent's Op.
57--         type New_Derived is new Derived1 with record...
58--         ...
59--      end Q;
60--
61--      Both type Derived1 and Derived2 inherit Op from the parent type Root.
62--      Type New_Derived inherits (inherited) Op from Derived1.  The inherited
63--      operation is implicitly declared immediately after the type extension.
64--      The inherited operation is overridden by an explicit declaration in
65--      the private part. Even though the overriding operation is private,
66--      calls to Op with an operand of tag Derived1, Derived2, or New_Derived
67--      will execute the body of the overriding operation.
68--
69-- TEST FILES:
70--      The following files comprise this test:
71--
72--         F392D00.A
73--         C392D03.A
74--
75--
76-- CHANGE HISTORY:
77--      06 Dec 94   SAIC    ACVC 2.0
78--
79--!
80
81with F392D00;
82package C392D03_0 is
83
84   type Aperture is (Eight, Sixteen);
85
86   type Auto_Focus is new F392D00.Remote_Camera with record
87      -- ...
88      FStop : Aperture;
89   end record;
90
91   -- Implicit procedure Focus (C     : in out Auto_Focus;
92   --                           Depth : in     Depth_Of_Field) declared here.
93
94   type Auto_Flashing is new F392D00.Remote_Camera with private;
95
96   -- Implicit procedure Focus (C     : in out Auto_Flashing;
97   --                           Depth : in     Depth_Of_Field) declared here.
98
99   type Special_Focus is new Auto_Focus with private;
100
101   -- Implicit procedure Focus (C     : in out Special_Focus;
102   --                           Depth : in     Depth_Of_Field) declared here.
103
104   -- ...Other operations.
105
106private
107
108   procedure Focus (C     : in out Auto_Focus;              -- Overrides
109                    Depth : in     F392D00.Depth_Of_Field); -- parent's op.
110
111   -- For the improved remote camera, focus is set automatically, so it is
112   -- declared as a private operation.
113
114   type Auto_Flashing is new F392D00.Remote_Camera with null record;
115
116   procedure Focus (C     : in out Auto_Flashing;           -- Overrides
117                    Depth : in     F392D00.Depth_Of_Field); -- parent's op.
118
119   type Special_Focus is new Auto_Focus with null record;
120
121end C392D03_0;
122
123
124     --==================================================================--
125
126
127package body C392D03_0 is
128
129   procedure Focus (C     : in out Auto_Focus;
130                    Depth : in     F392D00.Depth_Of_Field) is
131   begin
132      -- Artificial for testing purposes.
133      C.DOF := 52;
134   end Focus;
135
136   -----------------------------------------------------------
137   procedure Focus (C     : in out Auto_Flashing;
138                    Depth : in     F392D00.Depth_Of_Field) is
139   begin
140      -- Artificial for testing purposes.
141      C.DOF := 91;
142   end Focus;
143
144end C392D03_0;
145
146
147     --==================================================================--
148
149
150with F392D00;
151with C392D03_0;
152
153with Report;
154
155procedure C392D03 is
156
157   type Focus_Ptr is access procedure
158     (P1 : in out C392D03_0.Auto_Focus;
159      P2 : in F392D00.Depth_Of_Field);
160
161   Basic_Camera   : F392D00.Remote_Camera;
162   Auto_Camera1   : C392D03_0.Auto_Focus;
163   Auto_Camera2   : C392D03_0.Auto_Focus;
164   Flash_Camera1  : C392D03_0.Auto_Flashing;
165   Flash_Camera2  : C392D03_0.Auto_Flashing;
166   Special_Camera : C392D03_0.Special_Focus;
167   Auto_Depth     : F392D00.Depth_Of_Field := 78;
168
169   TC_Expected_Basic_Depth : constant F392D00.Depth_Of_Field := 46;
170   TC_Expected_Auto_Depth  : constant F392D00.Depth_Of_Field := 52;
171   TC_Expected_Depth       : constant F392D00.Depth_Of_Field := 91;
172
173   FP : Focus_Ptr := C392D03_0.Focus'Access;
174
175   use type F392D00.Depth_Of_Field;
176
177begin
178   Report.Test ("C392D03", "Dispatching for overridden primitive " &
179                "subprograms: record extension declared in non-child " &
180                "package, parent is tagged record");
181
182
183-- Call the class-wide operation for Remote_Camera'Class, which itself makes
184-- a dispatching call to Focus:
185
186   -- For an object of type Remote_Camera, the dispatching call should
187   -- dispatch to the body declared for the root type:
188
189   F392D00.Self_Test(Basic_Camera);
190
191   if Basic_Camera.DOF /= TC_Expected_Basic_Depth then
192      Report.Failed ("Call dispatched incorrectly for root type");
193   end if;
194
195
196   -- For an object of type Auto_Focus, the dispatching call should
197   -- dispatch to the body declared for the derived type:
198
199   F392D00.Self_Test(Auto_Camera1);
200
201   if Auto_Camera1.DOF /= TC_Expected_Auto_Depth then
202      Report.Failed ("Call dispatched incorrectly for Auto_Focus type");
203   end if;
204
205
206   -- For an object of type Auto_Flash, the dispatching call should
207   -- also dispatch to the body declared for the derived type:
208
209   F392D00.Self_Test(Flash_Camera1);
210
211   if Flash_Camera1.DOF /= TC_Expected_Depth then
212      Report.Failed ("Call dispatched incorrectly for Auto_Flash type");
213   end if;
214
215   -- For an object of Auto_Flash type, a non-dispatching call to Focus should
216   -- execute the body declared for the derived type (even through it is
217   -- declared in the private part).
218
219   C392D03_0.Focus (Flash_Camera2, Auto_Depth);
220
221   if Flash_Camera2.DOF /= TC_Expected_Depth then
222      Report.Failed ("Non-dispatching call to privately overriding " &
223                     "subprogram executed the wrong body");
224   end if;
225
226   -- For an object of Auto_Focus type, a non-dispatching call to Focus should
227   -- execute the body declared for the derived type (even through it is
228   -- declared in the private part).
229
230   FP.all (Auto_Camera2, Auto_Depth);
231
232   if Auto_Camera2.DOF /= TC_Expected_Auto_Depth then
233      Report.Failed ("Non-dispatching call by using access to overriding " &
234                     "subprogram executed the wrong body");
235   end if;
236
237   -- For an object of type Special_Camera, the dispatching call should
238   -- also dispatch to the body declared for the derived type:
239
240   F392D00.Self_Test(Special_Camera);
241
242   if Special_Camera.DOF /= TC_Expected_Auto_Depth then
243      Report.Failed ("Call dispatched incorrectly for Special_Camera type");
244   end if;
245
246   Report.Result;
247
248end C392D03;
249