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

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 294 jeremybenn
-- C390004.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 tags of allocated objects correctly identify the
28
--     type of the allocated object.  Check that the tag corresponds
29
--     correctly to the value resulting from both normal and view
30
--     conversion.  Check that the tags of accessed values designating
31
--     aliased objects correctly identify the type of the object.  Check
32
--     that the tag of a function result correctly evaluates.  Check this
33
--     for class-wide functions.  The tag of a class-wide function result
34
--     should be the tag appropriate to the actual value returned, not the
35
--     tag of the ancestor type.
36
--
37
-- TEST DESCRIPTION:
38
--     This test defines a class hierarchy of types, with reference
39
--     semantics (an access type to the class-wide type).  Similar in
40
--     structure to C392005, this test checks that dynamic allocation does
41
--     not adversely impact the tagging of types.
42
--
43
--
44
-- CHANGE HISTORY:
45
--      06 Dec 94   SAIC    ACVC 2.0
46
--
47
--!
48
 
49
package C390004_1 is -- DMV
50
  type Equipment is ( T_Veh, T_Car, T_Con, T_Jep );
51
 
52
  type Vehicle is tagged record
53
    Wheels : Natural := 4;
54
    Parked : Boolean := False;
55
  end record;
56
 
57
  function  Wheels    ( It: Vehicle ) return Natural;
58
  procedure Park      ( It: in out Vehicle );
59
  procedure UnPark    ( It: in out Vehicle );
60
  procedure Set_Wheels( It: in out Vehicle; To_Count: in Natural );
61
  procedure TC_Check  ( It: in Vehicle; To_Equip: in Equipment );
62
 
63
  type Car is new Vehicle with record
64
    Passengers : Natural := 0;
65
  end record;
66
 
67
  function  Passengers     ( It: Car ) return Natural;
68
  procedure Load_Passengers( It: in out Car; To_Count: in Natural );
69
  procedure Park           ( It: in out Car );
70
  procedure TC_Check       ( It: in Car; To_Equip: in Equipment );
71
 
72
  type Convertible is new Car with record
73
    Top_Up : Boolean := True;
74
  end record;
75
 
76
  function  Top_Up   ( It: Convertible ) return Boolean;
77
  procedure Lower_Top( It: in out Convertible );
78
  procedure Park     ( It: in out Convertible );
79
  procedure Raise_Top( It: in out Convertible );
80
  procedure TC_Check ( It: in Convertible; To_Equip: in Equipment );
81
 
82
  type Jeep is new Convertible with record
83
    Windshield_Up : Boolean := True;
84
  end record;
85
 
86
  function  Windshield_Up   ( It: Jeep ) return Boolean;
87
  procedure Lower_Windshield( It: in out Jeep );
88
  procedure Park            ( It: in out Jeep );
89
  procedure Raise_Windshield( It: in out Jeep );
90
  procedure TC_Check        ( It: in Jeep; To_Equip: in Equipment );
91
 
92
end C390004_1;
93
 
94
with Report;
95
package body C390004_1 is
96
 
97
  procedure Set_Wheels( It: in out Vehicle; To_Count: in Natural ) is
98
  begin
99
    It.Wheels := To_Count;
100
  end Set_Wheels;
101
 
102
  function  Wheels( It: Vehicle ) return Natural is
103
  begin
104
    return It.Wheels;
105
  end Wheels;
106
 
107
  procedure Park      ( It: in out Vehicle ) is
108
  begin
109
    It.Parked := True;
110
  end Park;
111
 
112
  procedure UnPark    ( It: in out Vehicle ) is
113
  begin
114
    It.Parked := False;
115
  end UnPark;
116
 
117
  procedure TC_Check  ( It: in Vehicle; To_Equip: in Equipment ) is
118
  begin
119
    if To_Equip /= T_Veh then
120
      Report.Failed ("Failed, called Vehicle for "
121
                     & Equipment'Image(To_Equip));
122
    end if;
123
  end TC_Check;
124
 
125
  procedure TC_Check  ( It: in Car; To_Equip: in Equipment ) is
126
  begin
127
    if To_Equip /= T_Car then
128
      Report.Failed ("Failed, called Car for "
129
                     & Equipment'Image(To_Equip));
130
    end if;
131
  end TC_Check;
132
 
133
  procedure TC_Check  ( It: in Convertible; To_Equip: in Equipment ) is
134
  begin
135
    if To_Equip /= T_Con then
136
      Report.Failed ("Failed, called Convertible for "
137
                     & Equipment'Image(To_Equip));
138
    end if;
139
  end TC_Check;
140
 
141
  procedure TC_Check  ( It: in Jeep; To_Equip: in Equipment ) is
142
  begin
143
    if To_Equip /= T_Jep then
144
      Report.Failed ("Failed, called Jeep for "
145
                     & Equipment'Image(To_Equip));
146
    end if;
147
  end TC_Check;
148
 
149
  procedure Load_Passengers( It: in out Car; To_Count: in Natural ) is
150
  begin
151
    It.Passengers := To_Count;
152
    UnPark( It );
153
  end Load_Passengers;
154
 
155
  procedure Park( It: in out Car ) is
156
  begin
157
    It.Passengers := 0;
158
    Park( Vehicle( It ) );
159
  end Park;
160
 
161
  function  Passengers( It: Car ) return Natural is
162
  begin
163
    return It.Passengers;
164
  end Passengers;
165
 
166
  procedure Raise_Top( It: in out Convertible ) is
167
  begin
168
    It.Top_Up := True;
169
  end Raise_Top;
170
 
171
  procedure Lower_Top( It: in out Convertible ) is
172
  begin
173
    It.Top_Up := False;
174
  end Lower_Top;
175
 
176
  function  Top_Up   ( It: Convertible ) return Boolean is
177
  begin
178
    return It.Top_Up;
179
  end Top_Up;
180
 
181
  procedure Park     ( It: in out Convertible ) is
182
  begin
183
    It.Top_Up := True;
184
    Park( Car( It ) );
185
  end Park;
186
 
187
  procedure Raise_Windshield( It: in out Jeep ) is
188
  begin
189
    It.Windshield_Up := True;
190
  end Raise_Windshield;
191
 
192
  procedure Lower_Windshield( It: in out Jeep ) is
193
  begin
194
    It.Windshield_Up := False;
195
  end Lower_Windshield;
196
 
197
  function  Windshield_Up( It: Jeep ) return Boolean is
198
  begin
199
    return It.Windshield_Up;
200
  end Windshield_Up;
201
 
202
  procedure Park( It: in out Jeep ) is
203
  begin
204
    It.Windshield_Up := True;
205
    Park( Convertible( It ) );
206
  end Park;
207
end C390004_1;
208
 
209
with Report;
210
with Ada.Tags;
211
with C390004_1;
212
procedure C390004 is
213
  package DMV renames C390004_1;
214
 
215
  The_Vehicle     : aliased DMV.Vehicle;
216
  The_Car         : aliased DMV.Car;
217
  The_Convertible : aliased DMV.Convertible;
218
  The_Jeep        : aliased DMV.Jeep;
219
 
220
  type C_Reference is access all DMV.Car'Class;
221
  type V_Reference is access all DMV.Vehicle'Class;
222
 
223
  Designator : V_Reference;
224
  Storage    : Natural;
225
 
226
  procedure Valet( It: in out DMV.Vehicle'Class ) is
227
  begin
228
    DMV.Park( It );
229
  end Valet;
230
 
231
  procedure TC_Match( Object: DMV.Vehicle'Class;
232
                      Taglet: Ada.Tags.Tag;
233
                      Where : String ) is
234
    use Ada.Tags;
235
  begin
236
    if Object'Tag /= Taglet then
237
      Report.Failed("Tag mismatch: " & Where);
238
    end if;
239
  end TC_Match;
240
 
241
  procedure Parking_Validation( It: DMV.Vehicle; TC_Message: String ) is
242
  begin
243
    if DMV.Wheels( It ) /= 1  or not It.Parked then
244
      Report.Failed ("Failed Vehicle " & TC_Message);
245
    end if;
246
  end Parking_Validation;
247
 
248
  procedure Parking_Validation( It: DMV.Car; TC_Message: String ) is
249
  begin
250
    if DMV.Wheels( It ) /= 2 or DMV.Passengers( It ) /= 0
251
       or not It.Parked then
252
      Report.Failed ("Failed Car " & TC_Message);
253
    end if;
254
  end Parking_Validation;
255
 
256
  procedure Parking_Validation( It: DMV.Convertible;
257
                                TC_Message: String ) is
258
  begin
259
    if DMV.Wheels( It ) /= 3 or DMV.Passengers( It ) /= 0
260
       or not DMV.Top_Up( It ) or not It.Parked then
261
      Report.Failed ("Failed Convertible " & TC_Message);
262
    end if;
263
  end Parking_Validation;
264
 
265
  procedure Parking_Validation( It: DMV.Jeep; TC_Message: String ) is
266
  begin
267
    if DMV.Wheels( It ) /= 4 or DMV.Passengers( It ) /= 0
268
       or not DMV.Top_Up( It ) or not DMV.Windshield_Up( It )
269
       or not It.Parked then
270
      Report.Failed ("Failed Jeep " & TC_Message);
271
    end if;
272
  end Parking_Validation;
273
 
274
  function Wash( It: V_Reference; TC_Expect : Ada.Tags.Tag )
275
                                    return DMV.Vehicle'Class is
276
    This_Machine : DMV.Vehicle'Class := It.all;
277
  begin
278
    TC_Match( It.all, TC_Expect, "Class-wide object in Wash" );
279
    Storage := DMV.Wheels( This_Machine );
280
    return This_Machine;
281
  end Wash;
282
 
283
  function Wash( It: C_Reference; TC_Expect : Ada.Tags.Tag )
284
                                    return DMV.Car'Class is
285
    This_Machine : DMV.Car'Class := It.all;
286
  begin
287
    TC_Match( It.all, TC_Expect, "Class-wide object in Wash" );
288
    Storage := DMV.Wheels( This_Machine );
289
    return This_Machine;
290
  end Wash;
291
 
292
begin
293
 
294
  Report.Test( "C390004", "Check that the tags of allocated objects "
295
                        & "correctly identify the type of the allocated "
296
                        & "object.  Check that tags resulting from "
297
                        & "normal and view conversions.  Check tags of "
298
                        & "accessed values designating aliased objects. "
299
                        & "Check function result tags" );
300
 
301
  DMV.Set_Wheels( The_Vehicle, 1 );
302
  DMV.Set_Wheels( The_Car, 2 );
303
  DMV.Set_Wheels( The_Convertible, 3 );
304
  DMV.Set_Wheels( The_Jeep, 4 );
305
 
306
  Valet( The_Vehicle );
307
  Valet( The_Car );
308
  Valet( The_Convertible );
309
  Valet( The_Jeep );
310
 
311
  Parking_Validation( The_Vehicle,     "setup" );
312
  Parking_Validation( The_Car,         "setup" );
313
  Parking_Validation( The_Convertible, "setup" );
314
  Parking_Validation( The_Jeep,        "setup" );
315
 
316
-- Check that the tags of allocated objects correctly identify the type
317
-- of the allocated object.
318
 
319
  Designator := new DMV.Vehicle;
320
  DMV.TC_Check( Designator.all, DMV.T_Veh );
321
  TC_Match( Designator.all, DMV.Vehicle'Tag, "allocated Vehicle" );
322
 
323
  Designator := new DMV.Car;
324
  DMV.TC_Check( Designator.all, DMV.T_Car );
325
  TC_Match( Designator.all, DMV.Car'Tag, "allocated Car");
326
 
327
  Designator := new DMV.Convertible;
328
  DMV.TC_Check( Designator.all, DMV.T_Con );
329
  TC_Match( Designator.all, DMV.Convertible'Tag, "allocated Convertible" );
330
 
331
  Designator := new DMV.Jeep;
332
  DMV.TC_Check( Designator.all, DMV.T_Jep );
333
  TC_Match( Designator.all, DMV.Jeep'Tag, "allocated Jeep" );
334
 
335
-- Check that view conversion causes the correct dispatch
336
  DMV.TC_Check( DMV.Vehicle( The_Jeep ),     DMV.T_Veh );
337
  DMV.TC_Check( DMV.Car( The_Jeep ),         DMV.T_Car );
338
  DMV.TC_Check( DMV.Convertible( The_Jeep ), DMV.T_Con );
339
 
340
-- And that view conversion does not change the tag
341
  TC_Match( DMV.Vehicle( The_Jeep ),     DMV.Jeep'Tag, "View Conv Veh" );
342
  TC_Match( DMV.Car( The_Jeep ),         DMV.Jeep'Tag, "View Conv Car" );
343
  TC_Match( DMV.Convertible( The_Jeep ), DMV.Jeep'Tag, "View Conv Jep" );
344
 
345
-- Check that the tags of accessed values designating aliased objects
346
-- correctly identify the type of the object.
347
  Designator := The_Vehicle'Access;
348
  DMV.TC_Check( Designator.all, DMV.T_Veh );
349
  TC_Match( Designator.all, DMV.Vehicle'Tag, "aliased Vehicle" );
350
 
351
  Designator := The_Car'Access;
352
  DMV.TC_Check( Designator.all, DMV.T_Car );
353
  TC_Match( Designator.all, DMV.Car'Tag, "aliased Car" );
354
 
355
  Designator := The_Convertible'Access;
356
  DMV.TC_Check( Designator.all, DMV.T_Con );
357
  TC_Match( Designator.all, DMV.Convertible'Tag, "aliased Convertible" );
358
 
359
  Designator := The_Jeep'Access;
360
  DMV.TC_Check( Designator.all, DMV.T_Jep );
361
  TC_Match( Designator.all, DMV.Jeep'Tag, "aliased Jeep" );
362
 
363
-- Check that the tag of a function result correctly evaluates.
364
-- Check this for class-wide functions.  The tag of a class-wide
365
-- function result should be the tag appropriate to the actual value
366
-- returned, not the tag of the ancestor type.
367
  Function_Check: declare
368
    A_Vehicle     : V_Reference := new DMV.Vehicle'( The_Vehicle );
369
    A_Car         : C_Reference := new DMV.Car'( The_Car );
370
    A_Convertible : C_Reference := new DMV.Convertible'( The_Convertible );
371
    A_Jeep        : C_Reference := new DMV.Jeep'( The_Jeep );
372
  begin
373
    DMV.Unpark( A_Vehicle.all );
374
    DMV.Load_Passengers( A_Car.all, 5 );
375
    DMV.Load_Passengers( A_Convertible.all, 6 );
376
    DMV.Load_Passengers( A_Jeep.all, 7 );
377
    DMV.Lower_Top( DMV.Convertible(A_Convertible.all) );
378
    DMV.Lower_Top( DMV.Jeep(A_Jeep.all) );
379
    DMV.Lower_Windshield( DMV.Jeep(A_Jeep.all) );
380
 
381
    if DMV.Wheels( Wash( A_Jeep, DMV.Jeep'Tag ) ) /= 4
382
       or Storage /= 4 then
383
      Report.Failed("Did not correctly wash Jeep");
384
    end if;
385
 
386
    if DMV.Wheels( Wash( A_Convertible, DMV.Convertible'Tag ) ) /= 3
387
       or Storage /= 3 then
388
      Report.Failed("Did not correctly wash Convertible");
389
    end if;
390
 
391
    if DMV.Wheels( Wash( A_Car, DMV.Car'Tag ) ) /= 2
392
       or Storage /= 2 then
393
      Report.Failed("Did not correctly wash Car");
394
    end if;
395
 
396
    if DMV.Wheels( Wash( A_Vehicle, DMV.Vehicle'Tag ) ) /= 1
397
       or Storage /= 1 then
398
      Report.Failed("Did not correctly wash Vehicle");
399
    end if;
400
 
401
  end Function_Check;
402
 
403
  Report.Result;
404
end C390004;

powered by: WebSVN 2.1.0

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