1-- C392D02.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 a primitive procedure declared in a private part is not
28--      overridden by a procedure explicitly declared at a place where the
29--      primitive procedure in question is not visible.
30--
31--      Check for the case where the non-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-- TEST DESCRIPTION:
36--      Consider:
37--
38--      package P is
39--         type Root is tagged ...
40--      private
41--         procedure Pri_Op (A: Root);
42--      end P;
43--
44--      with P;
45--      package Q is
46--         type Derived is new P.Root with record...
47--         procedure Pri_Op (A: Derived);  -- Does NOT override parent's Op.
48--         ...
49--      end Q;
50--
51--      Type Derived inherits Pri_Op from the parent type Root. However,
52--      because P.Pri_Op is never visible within the immediate scope of
53--      Derived, it is not implicitly declared for Derived. As a result,
54--      the explicit Q.Pri_Op does not override P.Pri_Op and is totally
55--      unrelated to it.
56--
57--      Dispatching calls to P.Pri_Op with operands of tag Derived will
58--      not dispatch to Q.Pri_Op; the body executed will be that of P.Pri_Op.
59--
60-- TEST FILES:
61--      The following files comprise this test:
62--
63--         F392D00.A
64--         C392D02.A
65--
66--
67-- CHANGE HISTORY:
68--      06 Dec 94   SAIC    ACVC 2.0
69--
70--!
71
72with F392D00;
73package C392D02_0 is
74
75   type Aperture is (Eight, Sixteen);
76
77   type Auto_Speed is new F392D00.Remote_Camera with record
78      -- ...
79      FStop : Aperture;
80   end record;
81
82
83   procedure Set_Shutter_Speed (C     : in out Auto_Speed;
84                                Speed : in     F392D00.Shutter_Speed);
85                                                   -- Does NOT override.
86
87   -- This version of Set_Shutter_Speed does NOT override the operation
88   -- inherited from the parent, because the inherited operation is never
89   -- visible (and thus, is never implicitly declared) within the immediate
90   -- scope of type Auto_Speed.
91
92   procedure Self_Test (C : in out Auto_Speed'Class);
93
94   -- ...Other operations.
95
96end C392D02_0;
97
98
99     --==================================================================--
100
101
102package body C392D02_0 is
103
104   procedure Set_Shutter_Speed (C     : in out Auto_Speed;
105                                Speed : in     F392D00.Shutter_Speed) is
106   begin
107      -- Artificial for testing purposes.
108      C.Shutter := F392D00.Four_Hundred;
109   end Set_Shutter_Speed;
110
111   ----------------------------------------------------
112   procedure Self_Test (C : in out Auto_Speed'Class) is
113   begin
114      -- Should dispatch to the Set_Shutter_Speed explicitly declared
115      -- for Auto_Speed.
116      Set_Shutter_Speed (C, F392D00.Two_Fifty);
117   end Self_Test;
118
119end C392D02_0;
120
121
122     --==================================================================--
123
124
125with F392D00;
126with C392D02_0;
127
128with Report;
129
130procedure C392D02 is
131   Basic_Camera : F392D00.Remote_Camera;
132   Auto_Camera1 : C392D02_0.Auto_Speed;
133   Auto_Camera2 : C392D02_0.Auto_Speed;
134
135   TC_Expected_Basic_Speed : constant F392D00.Shutter_Speed
136                           := F392D00.Thousand;
137   TC_Expected_Speed       : constant F392D00.Shutter_Speed
138                           := F392D00.Four_Hundred;
139
140   use type F392D00.Shutter_Speed;
141
142begin
143   Report.Test ("C392D02", "Dispatching for non-overridden primitive " &
144                "subprograms: record extension declared in non-child " &
145                "package, parent is tagged record");
146
147-- Call the class-wide operation for Remote_Camera'Class, which dispatches
148-- to Set_Shutter_Speed:
149
150   -- For an object of type Remote_Camera, the dispatching call should
151   -- dispatch to the body declared for the root type:
152
153   F392D00.Self_Test(Basic_Camera);
154
155   if Basic_Camera.Shutter /= TC_Expected_Basic_Speed then
156      Report.Failed ("Call dispatched incorrectly for root type");
157   end if;
158
159
160   -- C392D02_0.Set_Shutter_Speed should never be called by F392D00.Self_Test,
161   -- since C392D02_0.Set_Shutter_Speed does not override
162   -- F392D00.Set_Shutter_Speed.
163
164   -- For an object of type Auto_Speed, the dispatching call should
165   -- also dispatch to the body declared for the root type:
166
167   F392D00.Self_Test(Auto_Camera1);
168
169   if Auto_Camera1.Shutter /= TC_Expected_Basic_Speed then
170      Report.Failed ("Call dispatched incorrectly for derived type");
171   end if;
172
173   -- Call to Self_Test from C392D02_0 invokes the dispatching call to
174   -- Set_Shutter_Speed which should dispatch to the body explicitly declared
175   -- for Auto_Speed:
176
177   C392D02_0.Self_Test(Auto_Camera2);
178
179   if Auto_Camera2.Shutter /= TC_Expected_Speed then
180      Report.Failed ("Call to explicit subprogram executed the wrong body");
181   end if;
182
183   Report.Result;
184
185end C392D02;
186