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