1-- C390003.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 for a subtype S of a tagged type T, S'Class denotes a 28-- class-wide subtype. Check that T'Tag denotes the tag of the type T, 29-- and that, for a class-wide tagged type X, X'Tag denotes the tag of X. 30-- Check that the tags of stand alone objects, record and array 31-- components, aggregates, and formal parameters identify their type. 32-- Check that the tag of a value of a formal parameter is that of the 33-- actual parameter, even if the actual is passed by a view conversion. 34-- 35-- TEST DESCRIPTION: 36-- This test defines a class hierarchy (based on C390002) and 37-- uses it to determine the correctness of the resulting tag 38-- information generated by the compiler. A type is defined in the 39-- class which contains components of the class as part of its 40-- definition. This is to reduce the overall number of types 41-- required, and to achieve the required nesting to accomplish 42-- this test. The model is that of a car carrier truck; both car 43-- and truck being in the class of Vehicle. 44-- 45-- Class Hierarchy: 46-- Vehicle - - - - - - - (Bicycle) 47-- / | \ / \ 48-- Truck Car Q_Machine Tandem Motorcycle 49-- | 50-- Auto_Carrier 51-- Contains: 52-- Auto_Carrier( Car ) 53-- Q_Machine( Car, Motorcycle ) 54-- 55-- 56-- 57-- CHANGE HISTORY: 58-- 06 Dec 94 SAIC ACVC 2.0 59-- 19 Dec 94 SAIC Removed ARM references from objective text. 60-- 20 Dec 94 SAIC Replaced three unnecessary extension 61-- aggregates with simple aggregates. 62-- 16 Oct 95 SAIC Fixed bugs for ACVC 2.0.1 63-- 64--! 65 66----------------------------------------------------------------- C390003_1 67 68with Ada.Tags; 69package C390003_1 is -- Vehicle 70 71 type TC_Keys is (Veh, MC, Tand, Car, Q, Truk, Heavy); 72 type States is (Good, Flat, Worn); 73 74 type Wheel_List is array(Positive range <>) of States; 75 76 type Object(Wheels: Positive) is tagged record 77 Wheel_State : Wheel_List(1..Wheels); 78 end record; 79 80 procedure TC_Validate( It: Object; Key: TC_Keys ); 81 procedure TC_Validate( It: Object'Class; The_Tag: Ada.Tags.Tag ); 82 83 procedure Create( The_Vehicle : in out Object; Tyres : in States ); 84 procedure Rotate( The_Vehicle : in out Object ); 85 function Wheels( The_Vehicle : Object ) return Positive; 86 87end C390003_1; -- Vehicle; 88 89----------------------------------------------------------------- C390003_2 90 91with C390003_1; 92package C390003_2 is -- Motivators 93 94 package Vehicle renames C390003_1; 95 subtype Bicycle is Vehicle.Object(2); -- constrained subtype 96 97 type Motorcycle is new Bicycle with record 98 Displacement : Natural; 99 end record; 100 procedure TC_Validate( It: Motorcycle; Key: Vehicle.TC_Keys ); 101 102 type Tandem is new Bicycle with null record; 103 procedure TC_Validate( It: Tandem; Key: Vehicle.TC_Keys ); 104 105 type Car is new Vehicle.Object(4) with -- extended, constrained 106 record 107 Displacement : Natural; 108 end record; 109 procedure TC_Validate( It: Car; Key: Vehicle.TC_Keys ); 110 111 type Truck is new Vehicle.Object with -- extended, unconstrained 112 record 113 Tare : Natural; 114 end record; 115 procedure TC_Validate( It: Truck; Key: Vehicle.TC_Keys ); 116 117end C390003_2; -- Motivators; 118 119----------------------------------------------------------------- C390003_3 120 121with C390003_1; 122with C390003_2; 123package C390003_3 is -- Special_Trucks 124 package Vehicle renames C390003_1; 125 package Motivators renames C390003_2; 126 Max_Cars_On_Vehicle : constant := 6; 127 type Cargo_Index is range 0..Max_Cars_On_Vehicle; 128 type Cargo is array(Cargo_Index range 1..Max_Cars_On_Vehicle) 129 of Motivators.Car; 130 type Auto_Carrier is new Motivators.Truck(18) with 131 record 132 Load_Count : Cargo_Index := 0; 133 Payload : Cargo; 134 end record; 135 procedure TC_Validate( It: Auto_Carrier; Key: Vehicle.TC_Keys ); 136 procedure Load ( The_Car : in Motivators.Car; 137 Onto : in out Auto_Carrier); 138 procedure Unload( The_Car : out Motivators.Car; 139 Off_of : in out Auto_Carrier); 140end C390003_3; 141 142----------------------------------------------------------------- C390003_4 143 144with C390003_1; 145with C390003_2; 146package C390003_4 is -- James_Bond 147 148 package Vehicle renames C390003_1; 149 package Motivators renames C390003_2; 150 151 type Q_Machine is new Vehicle.Object(4) with record 152 Car_Part : Motivators.Car; 153 Bike_Part : Motivators.Motorcycle; 154 end record; 155 procedure TC_Validate( It: Q_Machine; Key: Vehicle.TC_Keys ); 156 157end C390003_4; 158 159----------------------------------------------------------------- C390003_1 160 161with Report; 162with Ada.Tags; 163package body C390003_1 is -- Vehicle 164 165 function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."="; 166 167 procedure TC_Validate( It: Object; Key: TC_Keys ) is 168 begin 169 if Key /= Veh then 170 Report.Failed("Expected Veh Key"); 171 end if; 172 end TC_Validate; 173 174 procedure TC_Validate( It: Object'Class; The_Tag: Ada.Tags.Tag ) is 175 begin 176 if It'Tag /= The_Tag then 177 Report.Failed("Unexpected Tag for classwide formal"); 178 end if; 179 end TC_Validate; 180 181 procedure Create( The_Vehicle : in out Object; Tyres : in States ) is 182 begin 183 The_Vehicle.Wheel_State := ( others => Tyres ); 184 end Create; 185 186 function Wheels( The_Vehicle : Object ) return Positive is 187 begin 188 return The_Vehicle.Wheels; 189 end Wheels; 190 191 procedure Rotate( The_Vehicle : in out Object ) is 192 Push : States; 193 Pulled : States 194 := The_Vehicle.Wheel_State(The_Vehicle.Wheel_State'Last); 195 begin 196 for Finger in 197 The_Vehicle.Wheel_State'First..The_Vehicle.Wheel_State'Last loop 198 Push := The_Vehicle.Wheel_State(Finger); 199 The_Vehicle.Wheel_State(Finger) := Pulled; 200 Pulled := Push; 201 end loop; 202 end Rotate; 203 204end C390003_1; -- Vehicle; 205 206----------------------------------------------------------------- C390003_2 207 208with Ada.Tags; 209with Report; 210package body C390003_2 is -- Motivators 211 212 function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."="; 213 function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."="; 214 215 procedure TC_Validate( It: Motorcycle; Key: Vehicle.TC_Keys ) is 216 begin 217 if Key /= Vehicle.MC then 218 Report.Failed("Expected MC Key"); 219 end if; 220 end TC_Validate; 221 222 procedure TC_Validate( It: Tandem; Key: Vehicle.TC_Keys ) is 223 begin 224 if Key /= Vehicle.Tand then 225 Report.Failed("Expected Tand Key"); 226 end if; 227 end TC_Validate; 228 229 procedure TC_Validate( It: Car; Key: Vehicle.TC_Keys ) is 230 begin 231 if Key /= Vehicle.Car then 232 Report.Failed("Expected Car Key"); 233 end if; 234 end TC_Validate; 235 236 procedure TC_Validate( It: Truck; Key: Vehicle.TC_Keys ) is 237 begin 238 if Key /= Vehicle.Truk then 239 Report.Failed("Expected Truk Key"); 240 end if; 241 end TC_Validate; 242end C390003_2; -- Motivators; 243 244----------------------------------------------------------------- C390003_3 245 246with Ada.Tags; 247with Report; 248package body C390003_3 is -- Special_Trucks 249 250 function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."="; 251 function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."="; 252 253 procedure TC_Validate( It: Auto_Carrier; Key: Vehicle.TC_Keys ) is 254 begin 255 if Key /= Vehicle.Heavy then 256 Report.Failed("Expected Heavy Key"); 257 end if; 258 end TC_Validate; 259 260 procedure Load ( The_Car : in Motivators.Car; 261 Onto : in out Auto_Carrier) is 262 begin 263 Onto.Load_Count := Onto.Load_Count +1; 264 Onto.Payload(Onto.Load_Count) := The_Car; 265 end Load; 266 procedure Unload( The_Car : out Motivators.Car; 267 Off_of : in out Auto_Carrier) is 268 begin 269 The_Car := Off_of.Payload(Off_of.Load_Count); 270 Off_of.Load_Count := Off_of.Load_Count -1; 271 end Unload; 272 273end C390003_3; 274 275----------------------------------------------------------------- C390003_4 276 277with Report, Ada.Tags; 278package body C390003_4 is -- James_Bond 279 280 function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."="; 281 function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."="; 282 283 procedure TC_Validate( It: Q_Machine; Key: Vehicle.TC_Keys ) is 284 begin 285 if Key /= Vehicle.Q then 286 Report.Failed("Expected Q Key"); 287 end if; 288 end TC_Validate; 289 290end C390003_4; 291 292------------------------------------------------------------------- C390003 293 294with Report; 295with C390003_1; 296with C390003_2; 297with C390003_3; 298with C390003_4; 299procedure C390003 is 300 301 package Vehicle renames C390003_1; use Vehicle; 302 package Motivators renames C390003_2; 303 package Special_Trucks renames C390003_3; 304 package James_Bond renames C390003_4; 305 306 -- The cast, in order of complexity: 307 308 Pennys_Bike : Motivators.Bicycle; 309 Weekender : Motivators.Tandem; 310 Qs_Moped : Motivators.Motorcycle; 311 Ms_Limo : Motivators.Car; 312 Yard_Van : Motivators.Truck(8); 313 Specter_X : Special_Trucks.Auto_Carrier; 314 Gen_II : James_Bond.Q_Machine; 315 316 317 -- Check compatibility with the corresponding class wide type. 318 319 procedure Vehicle_Shop( It : in out Vehicle.Object'Class; 320 Key : in Vehicle.TC_Keys ) is 321 322 -- Check that Subtype'Class is defined for tagged subtypes. 323 procedure Bike_Shop( Bike: in out Motivators.Bicycle'Class ) is 324 begin 325 -- Dispatch to appropriate TC_Validate 326 Vehicle.TC_Validate( Bike, Key ); 327 end Bike_Shop; 328 329 begin 330 Vehicle.TC_Validate( It, Key ); 331 if Vehicle.Wheels( It ) = 2 then 332 Bike_Shop( It ); -- only call Bike_Shop when It has 2 wheels 333 end if; 334 end Vehicle_Shop; 335 336begin -- Main test procedure. 337 338 Report.Test ("C390003", "Check that for a subtype S of a tagged type " & 339 "T, S'Class denotes a class-wide subtype. Check that " & 340 "T'Tag denotes the tag of the type T, and that, for a " & 341 "class-wide tagged type X, X'Tag denotes the tag of X. " & 342 "Check that the tags of stand alone objects, record and " & 343 "array components, aggregates, and formal parameters " & 344 "identify their type. Check that the tag of a value of a " & 345 "formal parameter is that of the actual parameter, even " & 346 "if the actual is passed by a view conversion" ); 347 348-- Check that the tags of stand alone objects, record and array 349-- components, aggregates, and formal parameters identify their type. 350-- Check that the tag of a value of a formal parameter is that of the 351-- actual parameter, even if the actual is passed by a view conversion. 352 353 Vehicle_Shop( Pennys_Bike, Veh ); 354 Vehicle_Shop( Weekender, Tand ); 355 Vehicle_Shop( Qs_Moped, MC ); 356 Vehicle_Shop( Ms_Limo, Car ); 357 Vehicle_Shop( Yard_Van, Truk ); 358 Vehicle_Shop( Specter_X, Heavy ); 359 Vehicle_Shop( Specter_X.Payload(1), Car ); 360 Vehicle_Shop( Gen_II, Q ); 361 Vehicle_Shop( Gen_II.Car_Part, Car ); 362 Vehicle_Shop( Gen_II.Bike_Part, MC ); 363 364 Vehicle.TC_Validate( Pennys_Bike, Vehicle.Object'Tag ); 365 Vehicle.TC_Validate( Weekender, Motivators.Tandem'Tag ); 366 Vehicle.TC_Validate( Qs_Moped, Motivators.Motorcycle'Tag ); 367 Vehicle.TC_Validate( Ms_Limo, Motivators.Car'Tag ); 368 Vehicle.TC_Validate( Yard_Van, Motivators.Truck'Tag ); 369 Vehicle.TC_Validate( Specter_X, Special_Trucks.Auto_Carrier'Tag ); 370 Vehicle.TC_Validate( Specter_X.Payload(1), Motivators.Car'Tag ); 371 Vehicle.TC_Validate( Gen_II, James_Bond.Q_Machine'Tag ); 372 Vehicle.TC_Validate( Gen_II.Car_Part, Motivators.Car'Tag ); 373 Vehicle.TC_Validate( Gen_II.Bike_Part, Motivators.Motorcycle'Tag ); 374 375-- Check the tag generated for an aggregate. 376 377 Rentals: declare 378 Mikes_Rental : Vehicle.Object'Class := 379 Vehicle.Object'( 3, (Good, Flat, Worn)); 380 Diannes_Car : Vehicle.Object'Class := 381 Motivators.Tandem'( Wheels => 2, 382 Wheel_State => (Good, Good) ); 383 Jims_Bike : Vehicle.Object'Class := 384 Motivators.Motorcycle'( Pennys_Bike 385 with Displacement => 350 ); 386 Bills_Limo : Vehicle.Object'Class := 387 Motivators.Car'( Wheels => 4, 388 Wheel_State => (others => Good), 389 Displacement => 282 ); 390 Alans_Car : Vehicle.Object'Class := 391 Motivators.Truck'( 18, (others => Worn), 392 Tare => 5_500 ); 393 Pats_Truck : Vehicle.Object'Class := Specter_X; 394 Keiths_Car : Vehicle.Object'Class := Gen_II; 395 Isaacs_Bus : Vehicle.Object'Class := Keiths_Car; 396 397 begin 398 Vehicle.TC_Validate( Mikes_Rental, Vehicle.Object'Tag ); 399 Vehicle.TC_Validate( Diannes_Car, Motivators.Tandem'Tag ); 400 Vehicle.TC_Validate( Jims_Bike, Motivators.Motorcycle'Tag ); 401 Vehicle.TC_Validate( Bills_Limo, Motivators.Car'Tag ); 402 Vehicle.TC_Validate( Alans_Car, Motivators.Truck'Tag ); 403 Vehicle.TC_Validate( Pats_Truck, Special_Trucks.Auto_Carrier'Tag ); 404 Vehicle.TC_Validate( Keiths_Car, James_Bond.Q_Machine'Tag ); 405 end Rentals; 406 407-- Check the tag of parameters. 408-- Check that the tag is not affected by view conversion. 409 410 Vehicle.TC_Validate( Vehicle.Object( Gen_II ), James_Bond.Q_Machine'Tag ); 411 Vehicle.TC_Validate( Vehicle.Object( Ms_Limo ), Motivators.Car'Tag ); 412 Vehicle.TC_Validate( Motivators.Bicycle( Weekender ), 413 Motivators.Tandem'Tag ); 414 Vehicle.TC_Validate( Motivators.Bicycle( Gen_II.Bike_Part ), 415 Motivators.Motorcycle'Tag ); 416 417 Report.Result; 418 419end C390003; 420