OpenCores
URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c3/] [c392d01.a] - Blame information for rev 294

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- C392D01.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 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.
33
--
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.
38
--
39
-- TEST DESCRIPTION:
40
--      Consider:
41
--
42
--      package Parent is
43
--         type Root is tagged ...
44
--         procedure Vis_Op (P: Root);
45
--      private
46
--         procedure Pri_Op (P: Root);                     -- (A)
47
--      end Parent;
48
--
49
--      package Intermediate is
50
--         type Mid is tagged private;
51
--      private
52
--         type Mid is new Parent.Root with record ...
53
--         -- Implicit Vis_Op (P: Mid) declared here.
54
--
55
--         procedure Vis_Op (P: Mid);                      -- (B)
56
--      end Intermediate;
57
--
58
--      package Intermediate.Child is
59
--         type Derived is new Mid with private;
60
--
61
--         procedure Pri_Op (P: Derived);                  -- (C)
62
--         ...
63
--
64
--      private
65
--         type Derived is new Mid with record...
66
--         -- Implicit Vis_Op (P: Derived) declared here.
67
--         ...
68
--      end Intermediate.Child;
69
--
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).
76
--
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.
82
--
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).
87
--
88
-- TEST FILES:
89
--      The following files comprise this test:
90
--
91
--         F392D00.A
92
--         C392D01.A
93
--
94
--
95
-- CHANGE HISTORY:
96
--      06 Dec 94   SAIC    ACVC 2.0
97
--
98
--!
99
 
100
with F392D00;
101
package C392D01_0 is
102
 
103
   type Zoom_Camera is tagged private;
104
 
105
   procedure Self_Test (C : in out Zoom_Camera'Class);
106
 
107
   -- ...Additional operations.
108
 
109
 
110
   function TC_Correct_Result (C : Zoom_Camera;
111
                               D : F392D00.Depth_Of_Field;
112
                               S : F392D00.Shutter_Speed) return Boolean;
113
 
114
private
115
 
116
   type Magnification is (Low, Medium, High);
117
 
118
   type Zoom_Camera is new F392D00.Remote_Camera with record
119
      Mag : Magnification;
120
   end record;
121
 
122
   -- procedure Focus (C     : in out Zoom_Camera;               -- Implicitly
123
   --                  Depth : in     Depth_Of_Field)            -- declared
124
                                                                 -- here.
125
 
126
   procedure Focus (C     : in out Zoom_Camera;                -- Overrides
127
                    Depth : in     F392D00.Depth_Of_Field);    -- inherited op.
128
 
129
   -- For the remote zoom camera, perhaps the focusing algorithm is different
130
   -- in some way, so the original Focus operation is overridden here.
131
 
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
135
   -- dispatched to.
136
 
137
 
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
141
   -- declared.
142
 
143
end C392D01_0;
144
 
145
 
146
     --==================================================================--
147
 
148
 
149
package body C392D01_0 is
150
 
151
   procedure Focus (C     : in out Zoom_Camera;
152
                    Depth : in     F392D00.Depth_Of_Field) is
153
   begin
154
      -- Artificial for testing purposes.
155
      C.DOF := 83;
156
   end Focus;
157
 
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
162
   begin
163
      F392D00.Self_Test (C);
164
      -- ...Additional self-testing.
165
   end Self_Test;
166
 
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;
173
   begin
174
      return (C.DOF = D and C.Shutter = S);
175
   end TC_Correct_Result;
176
 
177
end C392D01_0;
178
 
179
 
180
     --==================================================================--
181
 
182
 
183
with F392D00;
184
package C392D01_0.C392D01_1 is
185
 
186
   type Film_Speed is private;
187
 
188
   type Auto_Speed is new Zoom_Camera with private;
189
 
190
   -- Implicit function TC_Correct_Result (Auto_Speed) declared here.
191
 
192
   procedure Set_Shutter_Speed (C     : in out Auto_Speed;
193
                                Speed : in     F392D00.Shutter_Speed);
194
 
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.
199
 
200
   procedure Self_Test (C : in out Auto_Speed'Class);
201
 
202
   -- ...Other operations.
203
 
204
private
205
   type Film_Speed is (One_Hundred, Two_Hundred, Four_Hundred);
206
 
207
   type Auto_Speed is new Zoom_Camera with record
208
      ASA : Film_Speed;
209
   end record;
210
 
211
   -- procedure Focus (C     : in out Auto_Speed;                -- Implicitly
212
   --                  Depth : in     F392D00.Depth_Of_Field);   -- declared
213
                                                                 -- here.
214
 
215
end C392D01_0.C392D01_1;
216
 
217
 
218
     --==================================================================--
219
 
220
 
221
package body C392D01_0.C392D01_1 is
222
 
223
   procedure Set_Shutter_Speed (C     : in out Auto_Speed;
224
                                Speed : in     F392D00.Shutter_Speed) is
225
   begin
226
      -- Artificial for testing purposes.
227
      C.Shutter := F392D00.Two_Fifty;
228
   end Set_Shutter_Speed;
229
 
230
   -------------------------------------------------------
231
   procedure Self_Test (C : in out Auto_Speed'Class) is
232
   begin
233
      -- Artificial for testing purposes.
234
      Set_Shutter_Speed (C, F392D00.Thousand);
235
      Focus (C, 27);
236
   end Self_Test;
237
 
238
end C392D01_0.C392D01_1;
239
 
240
 
241
     --==================================================================--
242
 
243
 
244
with F392D00;
245
with C392D01_0.C392D01_1;
246
 
247
with Report;
248
 
249
procedure C392D01 is
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;
253
 
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
258
                          := F392D00.Thousand;
259
   TC_Expected_Auto_Speed : constant F392D00.Shutter_Speed
260
                          := F392D00.Thousand;
261
   TC_Expected_Speed      : constant F392D00.Shutter_Speed
262
                          := F392D00.Two_Fifty;
263
 
264
   use type F392D00.Depth_Of_Field;
265
   use type F392D00.Shutter_Speed;
266
 
267
begin
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  " &
271
                "type");
272
 
273
 
274
 
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:
278
 
279
 
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
283
   -- Remote_Camera:
284
 
285
   C392D01_0.Self_Test(Zooming_Camera);
286
 
287
   if not C392D01_0.TC_Correct_Result (Zooming_Camera,
288
                                       TC_Expected_Zoom_Depth,
289
                                       TC_Expected_Zoom_Speed)
290
   then
291
      Report.Failed ("Calls dispatched incorrectly for tagged private type");
292
   end if;
293
 
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:
298
 
299
   C392D01_0.Self_Test(Auto_Camera1);
300
 
301
   if not C392D01_0.C392D01_1.TC_Correct_Result (Auto_Camera1,
302
                                                 TC_Expected_Auto_Depth,
303
                                                 TC_Expected_Auto_Speed)
304
   then
305
      Report.Failed ("Calls dispatched incorrectly for private extension");
306
   end if;
307
 
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:
312
 
313
   C392D01_0.C392D01_1.Self_Test(Auto_Camera2);
314
 
315
   if not C392D01_0.C392D01_1.TC_Correct_Result (Auto_Camera2,
316
                                                 TC_Expected_Depth,
317
                                                 TC_Expected_Speed)
318
   then
319
      Report.Failed ("Call to explicit subprogram executed the wrong body");
320
   end if;
321
 
322
   Report.Result;
323
 
324
end C392D01;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.