1-- 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
49package 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
92end C390004_1;
93
94with Report;
95package 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;
207end C390004_1;
208
209with Report;
210with Ada.Tags;
211with C390004_1;
212procedure 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
292begin
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;
404end C390004;
405