summaryrefslogtreecommitdiff
path: root/gcc/testsuite/ada/acats/tests/c3/c392005.a
blob: be49cd48b75635df90cc5e739ebee7faa2b9b10a (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
-- C392005.A
--
--                             Grant of Unlimited Rights
--
--     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
--     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 
--     unlimited rights in the software and documentation contained herein.
--     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making 
--     this public release, the Government intends to confer upon all 
--     recipients unlimited rights  equal to those held by the Government.  
--     These rights include rights to use, duplicate, release or disclose the 
--     released technical data and computer software in whole or in part, in 
--     any manner and for any purpose whatsoever, and to have or permit others 
--     to do so.
--
--                                    DISCLAIMER
--
--     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
--     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED 
--     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
--     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE 
--     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
--     PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
--      Check that, for an implicitly declared dispatching operation that is
--      overridden, the body executed is the body for the overriding
--      subprogram, even if the overriding occurs in a private part.
--
--      Check for the case where the overriding operations are declared in a
--      public child unit of the package declaring the parent type, and the
--      descendant type is a private extension.
--
--      Check for both dispatching and nondispatching calls.
--
--
-- TEST DESCRIPTION:
--      Consider:
--
--      package Parent is
--         type Root is tagged ...
--         procedure Vis_Op (P: Root);
--      private
--         procedure Pri_Op (P: Root);
--      end Parent;
--
--      package Parent.Child is
--         type Derived is new Root with private;
--         -- Implicit Vis_Op (P: Derived) declared here.
--
--         procedure Pri_Op (P: Derived);                  -- (A)
--         ...
--      private
--         type Derived is new Root with record...
--         -- Implicit Pri_Op (P: Derived) declared here.

--         procedure Vis_Op (P: Derived);                  -- (B)
--         ...
--      end Parent.Child;
--
--      Type Derived inherits both Vis_Op and Pri_Op from the ancestor type
--      Root. Note, however, that Vis_Op is implicitly declared in the visible
--      part, whereas Pri_Op is implicitly declared in the private part
--      (inherited subprograms for a private extension are implicitly declared
--      after the private_extension_declaration if the corresponding
--      declaration from the ancestor is visible at that place; otherwise the
--      inherited subprogram is not declared for the private extension,
--      although it might be for the full type).
--
--      Even though Root's version of Pri_Op hasn't been implicitly declared
--      for Derived at the time Derived's version of Pri_Op has been
--      explicitly declared, the explicit Pri_Op still overrides the implicit
--      version. 
--      Also, even though the explicit Vis_Op for Derived is declared in the
--      private part it still overrides the implicit version declared in the
--      visible part. Calls with tag Derived will execute (A) and (B).
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--      26 Nov 96   SAIC    Improved for ACVC 2.1
--
--!

package C392005_0 is

   type Remote_Camera is tagged private;

   type Depth_Of_Field is range 5 .. 100;  
   type Shutter_Speed  is (One, Two_Fifty, Four_Hundred, Thousand);
   type Aperture       is (Eight, Sixteen, Thirty_Two);     

   -- ...Other declarations.

   procedure Focus (Cam   : in out Remote_Camera;
                    Depth : in     Depth_Of_Field);

   procedure Self_Test (C: in out Remote_Camera'Class);

   -- ...Other operations.

   function TC_Get_Depth (C: Remote_Camera) return Depth_Of_Field;
   function TC_Get_Speed (C: Remote_Camera) return Shutter_Speed;

private

   type Remote_Camera is tagged record
      DOF    : Depth_Of_Field := 10;
      Shutter: Shutter_Speed  := One;
      FStop  : Aperture       := Eight;
   end record;

   procedure Set_Shutter_Speed (C     : in out Remote_Camera;
                                Speed : in     Shutter_Speed);

   -- For the basic remote camera, shutter speed might be set as a function of
   -- focus perhaps, thus it is declared as a private operation (usable
   -- only internally within the abstraction).

   function Set_Aperture (C : Remote_Camera) return Aperture;
                               
end C392005_0;


     --==================================================================--


package body C392005_0 is

   procedure Focus (Cam   : in out Remote_Camera;
                    Depth : in     Depth_Of_Field) is
   begin
      -- Artificial for testing purposes.
      Cam.DOF := 46;
   end Focus;

   -----------------------------------------------------------
   procedure Set_Shutter_Speed (C     : in out Remote_Camera;
                                Speed : in     Shutter_Speed) is
   begin
      -- Artificial for testing purposes.
      C.Shutter := Thousand;
   end Set_Shutter_Speed;

   -----------------------------------------------------------
   function Set_Aperture (C : Remote_Camera) return Aperture is
   begin
      -- Artificial for testing purposes.
      return Thirty_Two;
   end Set_Aperture;

   -----------------------------------------------------------
   procedure Self_Test (C: in out Remote_Camera'Class) is
      TC_Dummy_Depth : constant Depth_Of_Field := 23;
      TC_Dummy_Speed : constant Shutter_Speed  := Four_Hundred;
   begin

      -- Test focus at various depths:
      Focus(C, TC_Dummy_Depth);
      -- ...Additional calls to Focus.

      -- Test various shutter speeds:
      Set_Shutter_Speed(C, TC_Dummy_Speed);
      -- ...Additional calls to Set_Shutter_Speed.

   end Self_Test;

   -----------------------------------------------------------
   function TC_Get_Depth (C: Remote_Camera) return Depth_Of_Field is
   begin
      return C.DOF;
   end TC_Get_Depth;

   -----------------------------------------------------------
   function TC_Get_Speed (C: Remote_Camera) return Shutter_Speed is
   begin
      return C.Shutter;
   end TC_Get_Speed;

end C392005_0;

     --==================================================================--


package C392005_0.C392005_1 is

   type Auto_Speed is new Remote_Camera with private;


   -- procedure Focus (C     : in out Auto_Speed;      -- Implicitly declared
   --                  Depth : in     Depth_Of_Field)  -- here.

   -- For the improved remote camera, shutter speed can be set manually,
   -- so it is declared as a public operation.

   -- The order of declarations for Set_Aperture and Set_Shutter_Speed are
   -- reversed from the original declarations to trap potential compiler
   -- problems related to subprogram ordering.

   function Set_Aperture (C : Auto_Speed) return Aperture;    -- Overrides
                                                              -- inherited op.

   procedure Set_Shutter_Speed (C     : in out Auto_Speed;    -- Overrides
                                Speed : in     Shutter_Speed);-- inherited op.

   -- Set_Shutter_Speed and Set_Aperture override the operations inherited
   -- from the parent, even though the inherited operations are not implicitly
   -- declared until the private part below.

   type New_Camera is private;

   function TC_Get_Aper (C: New_Camera) return Aperture;

   -- ...Other operations.

private
   type Film_Speed is (One_Hundred, Two_Hundred, Four_Hundred);

   type Auto_Speed is new Remote_Camera with record
      ASA : Film_Speed;
   end record;

   -- procedure Set_Shutter_Speed (C     : in out Auto_Speed;    -- Implicitly
   --                              Speed : in     Shutter_Speed) -- declared
                                                                 -- here.

   -- function Set_Aperture (C : Auto_Speed) return Aperture;    -- Implicitly
                                                                 -- declared.

   procedure Focus (C     : in out Auto_Speed;                -- Overrides
                    Depth : in     Depth_Of_Field);           -- inherited op.

   -- For the improved remote camera, perhaps the focusing algorithm is
   -- different, so the original Focus operation is overridden here.

   Auto_Camera : Auto_Speed;

   type New_Camera is record
      Aper : Aperture := Set_Aperture (Auto_Camera);  -- Calls the overridden,
   end record;                                        -- not the inherited op.

end C392005_0.C392005_1;


     --==================================================================--


package body C392005_0.C392005_1 is

   procedure Focus (C     : in out Auto_Speed;
                    Depth : in     Depth_Of_Field) is
   begin
      -- Artificial for testing purposes.
      C.DOF := 57;
   end Focus;

   ---------------------------------------------------------------
   procedure Set_Shutter_Speed (C     : in out Auto_Speed;
                                Speed : in     Shutter_Speed) is
   begin
      -- Artificial for testing purposes.
      C.Shutter := Two_Fifty;
   end Set_Shutter_Speed;

   -----------------------------------------------------------
   function Set_Aperture (C : Auto_Speed) return Aperture is
   begin
      -- Artificial for testing purposes.
      return Sixteen;
   end Set_Aperture;

   -----------------------------------------------------------
   function TC_Get_Aper (C: New_Camera) return Aperture is
   begin
      return C.Aper;
   end TC_Get_Aper;

end C392005_0.C392005_1;


     --==================================================================--


with C392005_0.C392005_1;

with Report;

procedure C392005 is
   Basic_Camera : C392005_0.Remote_Camera;
   Auto_Camera1 : C392005_0.C392005_1.Auto_Speed;
   Auto_Camera2 : C392005_0.C392005_1.Auto_Speed;
   Auto_Depth   : C392005_0.Depth_Of_Field := 67;
   New_Camera1  : C392005_0.C392005_1.New_Camera;
   TC_Expected_Basic_Depth : constant C392005_0.Depth_Of_Field := 46;
   TC_Expected_Auto_Depth  : constant C392005_0.Depth_Of_Field := 57;
   TC_Expected_Basic_Speed : constant C392005_0.Shutter_Speed  
                           := C392005_0.Thousand;
   TC_Expected_Auto_Speed  : constant C392005_0.Shutter_Speed  
                           := C392005_0.Two_Fifty;
   TC_Expected_New_Aper    : constant C392005_0.Aperture 
                           := C392005_0.Sixteen;

   use type C392005_0.Depth_Of_Field;
   use type C392005_0.Shutter_Speed;
   use type C392005_0.Aperture;

begin
   Report.Test ("C392005", "Dispatching for overridden primitive "        &
                "subprograms: private extension declared in child unit, " &
                "parent is tagged private whose full view is tagged record");

-- Call the class-wide operation for Remote_Camera'Class, which itself makes
-- dispatching calls to Focus and Set_Shutter_Speed:


   -- For an object of type Remote_Camera, the dispatching calls should
   -- dispatch to the bodies declared for the root type:
     
   C392005_0.Self_Test(Basic_Camera);

   if C392005_0.TC_Get_Depth (Basic_Camera) /= TC_Expected_Basic_Depth 
     or else C392005_0.TC_Get_Speed (Basic_Camera) /= TC_Expected_Basic_Speed
   then
      Report.Failed ("Calls dispatched incorrectly for root type");
   end if;


   -- For an object of type Auto_Speed, the dispatching calls should
   -- dispatch to the bodies declared for the derived type:
     
   C392005_0.Self_Test(Auto_Camera1);

   if C392005_0.C392005_1.TC_Get_Depth(Auto_Camera1) /= TC_Expected_Auto_Depth

      or
      C392005_0.C392005_1.TC_Get_Speed(Auto_Camera1) /= TC_Expected_Auto_Speed
   then
      Report.Failed ("Calls dispatched incorrectly for derived type");
   end if;

   -- For an object of type Auto_Speed, a non-dispatching call to Focus should

   -- execute the body declared for the derived type (even through it is 
   -- declared in the private part).

   C392005_0.C392005_1.Focus (Auto_Camera2, Auto_Depth);

   if C392005_0.C392005_1.TC_Get_Depth(Auto_Camera2) /= TC_Expected_Auto_Depth

   then
      Report.Failed ("Non-dispatching call to privately overriding " &
                     "subprogram executed the wrong body");
   end if;

   -- For an object of type New_Camera, the initialization using Set_Ap 
   -- should execute the overridden body, not the inherited one.

   if C392005_0.C392005_1.TC_Get_Aper (New_Camera1) /= TC_Expected_New_Aper  
   then
      Report.Failed ("Non-dispatching call to visible overriding " &
                     "subprogram executed the wrong body");
   end if;

   Report.Result;

end C392005;