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/] [c7/] [c730002.a] - Blame information for rev 294

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- C730002.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 the full view of a private extension may be derived
28
--      indirectly from the ancestor type (i.e., the parent type of the full
29
--      type may be any descendant of the ancestor type). Check that, for
30
--      a primitive subprogram of the private extension that is inherited from
31
--      the ancestor type and not overridden, the formal parameter names and
32
--      default expressions come from the corresponding primitive subprogram
33
--      of the ancestor type, while the body comes from that of the parent
34
--      type.
35
--      Check for a case where the parent type is derived from the ancestor
36
--      type through a series of types produced by generic instantiations.
37
--      Examine both the static and dynamic binding cases.
38
--
39
-- TEST DESCRIPTION:
40
--      Consider:
41
--
42
--      package P is
43
--         type Ancestor is tagged ...
44
--         procedure Op (P1: Ancestor; P2: Boolean := True);
45
--      end P;
46
--
47
--      with P;
48
--      generic
49
--         type T is new P.Ancestor with private;
50
--      package Gen1 is
51
--         type Enhanced is new T with private;
52
--         procedure Op (A: Enhanced; B: Boolean := True);
53
--         -- other specific procedures...
54
--      private
55
--         type Enhanced is new T with ...
56
--      end Gen1;
57
--
58
--      with P, Gen1;
59
--      package N is new Gen1 (P.Ancestor);
60
--
61
--      with N;
62
--      generic
63
--         type T is new N.Enhanced with private;
64
--      package Gen2 is
65
--         type Enhanced_Again is new T with private;
66
--         procedure Op (X: Enhanced_Again; Y: Boolean := False);
67
--         -- other specific procedures...
68
--      private
69
--         type Enhanced_Again is new T with ...
70
--      end Gen2;
71
--
72
--      with N, Gen2;
73
--      package Q is new Gen2 (N.Enhanced);
74
--
75
--      with P, Q;
76
--      package R is
77
--         type Priv_Ext is new P.Ancestor with private;         -- (A)
78
--         -- Inherits procedure Op (P1: Priv_Ext; P2: Boolean := True);
79
--         -- But body executed is that of Q.Op.
80
--      private
81
--         type Priv_Ext is new Q.Enhanced_Again with record ... -- (B)
82
--      end R;
83
--
84
--      The ancestor type in (A) differs from the parent type in (B); the
85
--      parent of the full type is descended from the ancestor type of the
86
--      private extension, in this case through a series of types produced
87
--      by generic instantiations.  Gen1 redefines the implementation of Op
88
--      for any type that has one.  N is an instance of Gen1 for the ancestor
89
--      type. Gen2 again redefines the implementation of Op for any type that
90
--      has one. Q is an instance of Gen2 for the extension of the P.Ancestor
91
--      declared in N.  Both N and Q could define other operations which we
92
--      don't want to be available in R.  For a call to Op (from outside the
93
--      scope of the full view) with an operand of type R.Priv_Ext, the body
94
--      executed will be that of Q.Op (the parent type's version), but the
95
--      formal parameter names and default expression come from that of P.Op
96
--      (the ancestor type's version).
97
--
98
--
99
-- CHANGE HISTORY:
100
--      06 Dec 94   SAIC    ACVC 2.0
101
--      27 Feb 97   CTA.PWB Added elaboration pragmas.
102
--!
103
 
104
package C730002_0 is
105
 
106
   type Hours_Type      is range 0..1000;
107
   type Personnel_Type  is range 0..10;
108
   type Specialist_ID is (Manny, Moe, Jack, Curly, Joe, Larry);
109
 
110
   type Engine_Type is tagged record
111
      Ave_Repair_Time    : Hours_Type     := 0;     -- Default init. for
112
      Personnel_Required : Personnel_Type := 0;     -- component fields.
113
      Specialist         : Specialist_ID  := Manny;
114
   end record;
115
 
116
   procedure Routine_Maintenance (Engine     : in out Engine_Type ;
117
                                  Specialist : in     Specialist_ID := Moe);
118
 
119
   -- The Routine_Maintenance procedure implements the processing required
120
   -- for an engine.
121
 
122
end C730002_0;
123
 
124
     --==================================================================--
125
 
126
package body C730002_0 is
127
 
128
   procedure Routine_Maintenance (Engine     : in out Engine_Type ;
129
                                  Specialist : in     Specialist_ID := Moe) is
130
   begin
131
      Engine.Ave_Repair_Time     := 3;
132
      Engine.Personnel_Required  := 1;
133
      Engine.Specialist := Specialist;
134
   end Routine_Maintenance;
135
 
136
end C730002_0;
137
 
138
     --==================================================================--
139
 
140
with C730002_0; use C730002_0;
141
generic
142
   type T is new C730002_0.Engine_Type with private;
143
package C730002_1 is
144
 
145
   -- This generic package contains types/procedures specific to engines
146
   -- of the diesel variety.
147
 
148
   type Repair_Facility_Type is (On_Site, Repair_Shop, Factory);
149
 
150
   type Diesel_Series is new T with private;
151
 
152
   procedure Routine_Maintenance (Eng      : in out Diesel_Series;
153
                                  Spec_Req : in     Specialist_ID := Jack);
154
 
155
   -- Other diesel specific operations... (not required in this test).
156
 
157
private
158
 
159
   type Diesel_Series is new T with record
160
      Repair_Facility_Required : Repair_Facility_Type := On_Site;
161
   end record;
162
 
163
end C730002_1;
164
 
165
     --==================================================================--
166
 
167
package body C730002_1 is
168
 
169
   procedure Routine_Maintenance (Eng      : in out Diesel_Series;
170
                                  Spec_Req : in     Specialist_ID := Jack) is
171
   begin
172
      Eng.Ave_Repair_Time          := 6;
173
      Eng.Personnel_Required       := 2;
174
      Eng.Specialist               := Spec_Req;
175
      Eng.Repair_Facility_Required := On_Site;
176
   end Routine_Maintenance;
177
 
178
end C730002_1;
179
 
180
     --==================================================================--
181
 
182
with C730002_0;
183
with C730002_1;
184
pragma Elaborate (C730002_1);
185
package C730002_2 is new C730002_1 (C730002_0.Engine_Type);
186
 
187
     --==================================================================--
188
 
189
with C730002_0; use C730002_0;
190
with C730002_2; use C730002_2;
191
generic
192
  type T is new C730002_2.Diesel_Series with private;
193
package C730002_3 is
194
 
195
   type Time_Of_Operation_Type is range 0..100_000;
196
 
197
   type Electric_Series is new T with private;
198
 
199
   procedure Routine_Maintenance (E  : in out Electric_Series;
200
                                  SR : in     Specialist_ID := Curly);
201
 
202
   -- Other electric specific operations... (not required in this test).
203
 
204
private
205
 
206
   type Electric_Series is new T with record
207
      Mean_Time_Between_Repair : Time_Of_Operation_Type := 0;
208
   end record;
209
 
210
end C730002_3;
211
 
212
     --==================================================================--
213
 
214
package body C730002_3 is
215
 
216
   procedure Routine_Maintenance (E  : in out Electric_Series;
217
                                  SR : in     Specialist_ID := Curly) is
218
   begin
219
      E.Ave_Repair_Time          := 9;
220
      E.Personnel_Required       := 3;
221
      E.Specialist               := SR;
222
      E.Mean_Time_Between_Repair := 1000;
223
   end Routine_Maintenance;
224
 
225
end C730002_3;
226
 
227
     --==================================================================--
228
 
229
with C730002_2;
230
with C730002_3;
231
pragma Elaborate (C730002_3);
232
package C730002_4 is new C730002_3 (C730002_2.Diesel_Series);
233
 
234
     --==================================================================--
235
 
236
with C730002_0;  use C730002_0;
237
with C730002_4;  use C730002_4;
238
 
239
package C730002_5 is
240
 
241
   type Inspection_Type is (AAA, MIL_STD, NRC);
242
 
243
   type Nuclear_Series is new Engine_Type with private;              -- (A)
244
 
245
   -- Inherits procedure Routine_Maintenance from ancestor; does not override.
246
   --                      (Engine     : in out Nuclear_Series;
247
   --                       Specialist : in     Specialist_ID := Moe);
248
   -- But body executed will be that of C730002_4.Routine_Maintenance,
249
   -- the parent type.
250
 
251
   function TC_Specialist         (E : Nuclear_Series) return Specialist_ID;
252
   function TC_Personnel_Required (E : Nuclear_Series) return Personnel_Type;
253
   function TC_Time_Required      (E : Nuclear_Series) return Hours_Type;
254
 
255
   -- Dispatching subprogram.
256
   procedure Maintain_The_Engine (The_Engine : in out Engine_Type'Class);
257
 
258
private
259
 
260
   type Nuclear_Series is new Electric_Series with record           -- (B)
261
      Inspector_Rep : Inspection_Type := NRC;
262
   end record;
263
 
264
   -- The ancestor type is used in the type extension (A), while the parent
265
   -- of the full type (B) is a descendent of the ancestor type, through a
266
   -- series of types produced by generic instantiation.
267
 
268
end C730002_5;
269
 
270
     --==================================================================--
271
 
272
package body C730002_5 is
273
 
274
   function TC_Specialist (E : Nuclear_Series) return Specialist_ID is
275
   begin
276
      return E.Specialist;
277
   end TC_Specialist;
278
 
279
   function TC_Personnel_Required (E : Nuclear_Series)
280
     return Personnel_Type is
281
   begin
282
      return E.Personnel_Required;
283
   end TC_Personnel_Required;
284
 
285
   function TC_Time_Required (E : Nuclear_Series) return Hours_Type is
286
   begin
287
      return E.Ave_Repair_Time;
288
   end TC_Time_Required;
289
 
290
   -- Dispatching subprogram.
291
   procedure Maintain_The_Engine (The_Engine : in out Engine_Type'Class) is
292
   begin
293
      Routine_Maintenance (The_Engine);
294
   end Maintain_The_Engine;
295
 
296
 
297
end C730002_5;
298
 
299
     --==================================================================--
300
 
301
with Report;
302
with C730002_0;  use C730002_0;
303
with C730002_2;  use C730002_2;
304
with C730002_4;  use C730002_4;
305
with C730002_5;  use C730002_5;
306
 
307
procedure C730002 is
308
begin
309
 
310
   Report.Test ("C730002", "Check that the full view of a private "        &
311
                           "extension may be derived indirectly from "     &
312
                           "the ancestor type.  Check for a case where "   &
313
                           "the parent type is derived from the ancestor " &
314
                           "type through a series of types produced by "   &
315
                           "generic instantiations");
316
 
317
   Test_Block:
318
   declare
319
      Nuclear_Drive : Nuclear_Series;
320
      Warp_Drive    : Nuclear_Series;
321
   begin
322
 
323
      -- Non-Dispatching Case:
324
      -- Call Routine_Maintenance using formal parameter name from
325
      -- C730002_0.Routine_Maintenance (ancestor version).
326
      -- Give no second parameter so that the default expression must be
327
      -- used.
328
 
329
      Routine_Maintenance (Engine => Nuclear_Drive);
330
 
331
      -- The value of the Specialist component should equal "Moe",
332
      -- which is the default value from the ancestor's version of
333
      -- Routine_Maintenance, and not the default value from the parent's
334
      -- version of Routine_Maintenance.
335
 
336
      if TC_Specialist (Nuclear_Drive) /= Moe then
337
         Report.Failed
338
           ("Default expression for ancestor op not used " &
339
            " - non-dispatching case");
340
      end if;
341
 
342
      -- However the value of the Ave_Repair_Time and Personnel_Required
343
      -- components should be those assigned in the parent type's version
344
      -- of the body of Routine_Maintenance.
345
      -- Note: Only components associated with the ancestor type are
346
      --       evaluated for the purposes of this test.
347
 
348
      if TC_Personnel_Required (Nuclear_Drive) /= 3  or
349
         TC_Time_Required (Nuclear_Drive)      /= 9
350
      then
351
         Report.Failed("Wrong body was executed - non-dispatching case");
352
      end if;
353
 
354
      -- Dispatching Case:
355
      -- Use a dispatching subprogram to ensure that the correct body is
356
      -- used at runtime.
357
 
358
      Maintain_The_Engine (Warp_Drive);
359
 
360
      -- The resulting assignments to the fields of the Warp_Drive variable
361
      -- should be the same as those of the Nuclear_Drive above, indicating
362
      -- that the body of the parent version of the inherited subprogram
363
      -- was used.
364
 
365
      if TC_Specialist (Warp_Drive) /= Moe then
366
         Report.Failed
367
           ("Default expression for ancestor op not used - dispatching case");
368
      end if;
369
 
370
      if TC_Personnel_Required (Nuclear_Drive) /= 3  or
371
         TC_Time_Required (Nuclear_Drive)      /= 9
372
      then
373
         Report.Failed("Wrong body was executed - dispatching case");
374
      end if;
375
 
376
 
377
   exception
378
      when others => Report.Failed("Exception raised in Test_Block");
379
   end Test_Block;
380
 
381
   Report.Result;
382
 
383
end C730002;

powered by: WebSVN 2.1.0

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