| -- C390003.A |
| -- |
| -- Grant of Unlimited Rights |
| -- |
| -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, |
| -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained |
| -- unlimited rights in the software and documentation contained herein. |
| -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making |
| -- this public release, the Government intends to confer upon all |
| -- recipients unlimited rights equal to those held by the Government. |
| -- These rights include rights to use, duplicate, release or disclose the |
| -- released technical data and computer software in whole or in part, in |
| -- any manner and for any purpose whatsoever, and to have or permit others |
| -- to do so. |
| -- |
| -- DISCLAIMER |
| -- |
| -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR |
| -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED |
| -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE |
| -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE |
| -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A |
| -- PARTICULAR PURPOSE OF SAID MATERIAL. |
| --* |
| -- |
| -- OBJECTIVE: |
| -- Check that for a subtype S of a tagged type T, S'Class denotes a |
| -- class-wide subtype. Check that T'Tag denotes the tag of the type T, |
| -- and that, for a class-wide tagged type X, X'Tag denotes the tag of X. |
| -- Check that the tags of stand alone objects, record and array |
| -- components, aggregates, and formal parameters identify their type. |
| -- Check that the tag of a value of a formal parameter is that of the |
| -- actual parameter, even if the actual is passed by a view conversion. |
| -- |
| -- TEST DESCRIPTION: |
| -- This test defines a class hierarchy (based on C390002) and |
| -- uses it to determine the correctness of the resulting tag |
| -- information generated by the compiler. A type is defined in the |
| -- class which contains components of the class as part of its |
| -- definition. This is to reduce the overall number of types |
| -- required, and to achieve the required nesting to accomplish |
| -- this test. The model is that of a car carrier truck; both car |
| -- and truck being in the class of Vehicle. |
| -- |
| -- Class Hierarchy: |
| -- Vehicle - - - - - - - (Bicycle) |
| -- / | \ / \ |
| -- Truck Car Q_Machine Tandem Motorcycle |
| -- | |
| -- Auto_Carrier |
| -- Contains: |
| -- Auto_Carrier( Car ) |
| -- Q_Machine( Car, Motorcycle ) |
| -- |
| -- |
| -- |
| -- CHANGE HISTORY: |
| -- 06 Dec 94 SAIC ACVC 2.0 |
| -- 19 Dec 94 SAIC Removed ARM references from objective text. |
| -- 20 Dec 94 SAIC Replaced three unnecessary extension |
| -- aggregates with simple aggregates. |
| -- 16 Oct 95 SAIC Fixed bugs for ACVC 2.0.1 |
| -- |
| --! |
| |
| ----------------------------------------------------------------- C390003_1 |
| |
| with Ada.Tags; |
| package C390003_1 is -- Vehicle |
| |
| type TC_Keys is (Veh, MC, Tand, Car, Q, Truk, Heavy); |
| type States is (Good, Flat, Worn); |
| |
| type Wheel_List is array(Positive range <>) of States; |
| |
| type Object(Wheels: Positive) is tagged record |
| Wheel_State : Wheel_List(1..Wheels); |
| end record; |
| |
| procedure TC_Validate( It: Object; Key: TC_Keys ); |
| procedure TC_Validate( It: Object'Class; The_Tag: Ada.Tags.Tag ); |
| |
| procedure Create( The_Vehicle : in out Object; Tyres : in States ); |
| procedure Rotate( The_Vehicle : in out Object ); |
| function Wheels( The_Vehicle : Object ) return Positive; |
| |
| end C390003_1; -- Vehicle; |
| |
| ----------------------------------------------------------------- C390003_2 |
| |
| with C390003_1; |
| package C390003_2 is -- Motivators |
| |
| package Vehicle renames C390003_1; |
| subtype Bicycle is Vehicle.Object(2); -- constrained subtype |
| |
| type Motorcycle is new Bicycle with record |
| Displacement : Natural; |
| end record; |
| procedure TC_Validate( It: Motorcycle; Key: Vehicle.TC_Keys ); |
| |
| type Tandem is new Bicycle with null record; |
| procedure TC_Validate( It: Tandem; Key: Vehicle.TC_Keys ); |
| |
| type Car is new Vehicle.Object(4) with -- extended, constrained |
| record |
| Displacement : Natural; |
| end record; |
| procedure TC_Validate( It: Car; Key: Vehicle.TC_Keys ); |
| |
| type Truck is new Vehicle.Object with -- extended, unconstrained |
| record |
| Tare : Natural; |
| end record; |
| procedure TC_Validate( It: Truck; Key: Vehicle.TC_Keys ); |
| |
| end C390003_2; -- Motivators; |
| |
| ----------------------------------------------------------------- C390003_3 |
| |
| with C390003_1; |
| with C390003_2; |
| package C390003_3 is -- Special_Trucks |
| package Vehicle renames C390003_1; |
| package Motivators renames C390003_2; |
| Max_Cars_On_Vehicle : constant := 6; |
| type Cargo_Index is range 0..Max_Cars_On_Vehicle; |
| type Cargo is array(Cargo_Index range 1..Max_Cars_On_Vehicle) |
| of Motivators.Car; |
| type Auto_Carrier is new Motivators.Truck(18) with |
| record |
| Load_Count : Cargo_Index := 0; |
| Payload : Cargo; |
| end record; |
| procedure TC_Validate( It: Auto_Carrier; Key: Vehicle.TC_Keys ); |
| procedure Load ( The_Car : in Motivators.Car; |
| Onto : in out Auto_Carrier); |
| procedure Unload( The_Car : out Motivators.Car; |
| Off_of : in out Auto_Carrier); |
| end C390003_3; |
| |
| ----------------------------------------------------------------- C390003_4 |
| |
| with C390003_1; |
| with C390003_2; |
| package C390003_4 is -- James_Bond |
| |
| package Vehicle renames C390003_1; |
| package Motivators renames C390003_2; |
| |
| type Q_Machine is new Vehicle.Object(4) with record |
| Car_Part : Motivators.Car; |
| Bike_Part : Motivators.Motorcycle; |
| end record; |
| procedure TC_Validate( It: Q_Machine; Key: Vehicle.TC_Keys ); |
| |
| end C390003_4; |
| |
| ----------------------------------------------------------------- C390003_1 |
| |
| with Report; |
| with Ada.Tags; |
| package body C390003_1 is -- Vehicle |
| |
| function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."="; |
| |
| procedure TC_Validate( It: Object; Key: TC_Keys ) is |
| begin |
| if Key /= Veh then |
| Report.Failed("Expected Veh Key"); |
| end if; |
| end TC_Validate; |
| |
| procedure TC_Validate( It: Object'Class; The_Tag: Ada.Tags.Tag ) is |
| begin |
| if It'Tag /= The_Tag then |
| Report.Failed("Unexpected Tag for classwide formal"); |
| end if; |
| end TC_Validate; |
| |
| procedure Create( The_Vehicle : in out Object; Tyres : in States ) is |
| begin |
| The_Vehicle.Wheel_State := ( others => Tyres ); |
| end Create; |
| |
| function Wheels( The_Vehicle : Object ) return Positive is |
| begin |
| return The_Vehicle.Wheels; |
| end Wheels; |
| |
| procedure Rotate( The_Vehicle : in out Object ) is |
| Push : States; |
| Pulled : States |
| := The_Vehicle.Wheel_State(The_Vehicle.Wheel_State'Last); |
| begin |
| for Finger in |
| The_Vehicle.Wheel_State'First..The_Vehicle.Wheel_State'Last loop |
| Push := The_Vehicle.Wheel_State(Finger); |
| The_Vehicle.Wheel_State(Finger) := Pulled; |
| Pulled := Push; |
| end loop; |
| end Rotate; |
| |
| end C390003_1; -- Vehicle; |
| |
| ----------------------------------------------------------------- C390003_2 |
| |
| with Ada.Tags; |
| with Report; |
| package body C390003_2 is -- Motivators |
| |
| function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."="; |
| function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."="; |
| |
| procedure TC_Validate( It: Motorcycle; Key: Vehicle.TC_Keys ) is |
| begin |
| if Key /= Vehicle.MC then |
| Report.Failed("Expected MC Key"); |
| end if; |
| end TC_Validate; |
| |
| procedure TC_Validate( It: Tandem; Key: Vehicle.TC_Keys ) is |
| begin |
| if Key /= Vehicle.Tand then |
| Report.Failed("Expected Tand Key"); |
| end if; |
| end TC_Validate; |
| |
| procedure TC_Validate( It: Car; Key: Vehicle.TC_Keys ) is |
| begin |
| if Key /= Vehicle.Car then |
| Report.Failed("Expected Car Key"); |
| end if; |
| end TC_Validate; |
| |
| procedure TC_Validate( It: Truck; Key: Vehicle.TC_Keys ) is |
| begin |
| if Key /= Vehicle.Truk then |
| Report.Failed("Expected Truk Key"); |
| end if; |
| end TC_Validate; |
| end C390003_2; -- Motivators; |
| |
| ----------------------------------------------------------------- C390003_3 |
| |
| with Ada.Tags; |
| with Report; |
| package body C390003_3 is -- Special_Trucks |
| |
| function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."="; |
| function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."="; |
| |
| procedure TC_Validate( It: Auto_Carrier; Key: Vehicle.TC_Keys ) is |
| begin |
| if Key /= Vehicle.Heavy then |
| Report.Failed("Expected Heavy Key"); |
| end if; |
| end TC_Validate; |
| |
| procedure Load ( The_Car : in Motivators.Car; |
| Onto : in out Auto_Carrier) is |
| begin |
| Onto.Load_Count := Onto.Load_Count +1; |
| Onto.Payload(Onto.Load_Count) := The_Car; |
| end Load; |
| procedure Unload( The_Car : out Motivators.Car; |
| Off_of : in out Auto_Carrier) is |
| begin |
| The_Car := Off_of.Payload(Off_of.Load_Count); |
| Off_of.Load_Count := Off_of.Load_Count -1; |
| end Unload; |
| |
| end C390003_3; |
| |
| ----------------------------------------------------------------- C390003_4 |
| |
| with Report, Ada.Tags; |
| package body C390003_4 is -- James_Bond |
| |
| function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."="; |
| function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."="; |
| |
| procedure TC_Validate( It: Q_Machine; Key: Vehicle.TC_Keys ) is |
| begin |
| if Key /= Vehicle.Q then |
| Report.Failed("Expected Q Key"); |
| end if; |
| end TC_Validate; |
| |
| end C390003_4; |
| |
| ------------------------------------------------------------------- C390003 |
| |
| with Report; |
| with C390003_1; |
| with C390003_2; |
| with C390003_3; |
| with C390003_4; |
| procedure C390003 is |
| |
| package Vehicle renames C390003_1; use Vehicle; |
| package Motivators renames C390003_2; |
| package Special_Trucks renames C390003_3; |
| package James_Bond renames C390003_4; |
| |
| -- The cast, in order of complexity: |
| |
| Pennys_Bike : Motivators.Bicycle; |
| Weekender : Motivators.Tandem; |
| Qs_Moped : Motivators.Motorcycle; |
| Ms_Limo : Motivators.Car; |
| Yard_Van : Motivators.Truck(8); |
| Specter_X : Special_Trucks.Auto_Carrier; |
| Gen_II : James_Bond.Q_Machine; |
| |
| |
| -- Check compatibility with the corresponding class wide type. |
| |
| procedure Vehicle_Shop( It : in out Vehicle.Object'Class; |
| Key : in Vehicle.TC_Keys ) is |
| |
| -- Check that Subtype'Class is defined for tagged subtypes. |
| procedure Bike_Shop( Bike: in out Motivators.Bicycle'Class ) is |
| begin |
| -- Dispatch to appropriate TC_Validate |
| Vehicle.TC_Validate( Bike, Key ); |
| end Bike_Shop; |
| |
| begin |
| Vehicle.TC_Validate( It, Key ); |
| if Vehicle.Wheels( It ) = 2 then |
| Bike_Shop( It ); -- only call Bike_Shop when It has 2 wheels |
| end if; |
| end Vehicle_Shop; |
| |
| begin -- Main test procedure. |
| |
| Report.Test ("C390003", "Check that for a subtype S of a tagged type " & |
| "T, S'Class denotes a class-wide subtype. Check that " & |
| "T'Tag denotes the tag of the type T, and that, for a " & |
| "class-wide tagged type X, X'Tag denotes the tag of X. " & |
| "Check that the tags of stand alone objects, record and " & |
| "array components, aggregates, and formal parameters " & |
| "identify their type. Check that the tag of a value of a " & |
| "formal parameter is that of the actual parameter, even " & |
| "if the actual is passed by a view conversion" ); |
| |
| -- Check that the tags of stand alone objects, record and array |
| -- components, aggregates, and formal parameters identify their type. |
| -- Check that the tag of a value of a formal parameter is that of the |
| -- actual parameter, even if the actual is passed by a view conversion. |
| |
| Vehicle_Shop( Pennys_Bike, Veh ); |
| Vehicle_Shop( Weekender, Tand ); |
| Vehicle_Shop( Qs_Moped, MC ); |
| Vehicle_Shop( Ms_Limo, Car ); |
| Vehicle_Shop( Yard_Van, Truk ); |
| Vehicle_Shop( Specter_X, Heavy ); |
| Vehicle_Shop( Specter_X.Payload(1), Car ); |
| Vehicle_Shop( Gen_II, Q ); |
| Vehicle_Shop( Gen_II.Car_Part, Car ); |
| Vehicle_Shop( Gen_II.Bike_Part, MC ); |
| |
| Vehicle.TC_Validate( Pennys_Bike, Vehicle.Object'Tag ); |
| Vehicle.TC_Validate( Weekender, Motivators.Tandem'Tag ); |
| Vehicle.TC_Validate( Qs_Moped, Motivators.Motorcycle'Tag ); |
| Vehicle.TC_Validate( Ms_Limo, Motivators.Car'Tag ); |
| Vehicle.TC_Validate( Yard_Van, Motivators.Truck'Tag ); |
| Vehicle.TC_Validate( Specter_X, Special_Trucks.Auto_Carrier'Tag ); |
| Vehicle.TC_Validate( Specter_X.Payload(1), Motivators.Car'Tag ); |
| Vehicle.TC_Validate( Gen_II, James_Bond.Q_Machine'Tag ); |
| Vehicle.TC_Validate( Gen_II.Car_Part, Motivators.Car'Tag ); |
| Vehicle.TC_Validate( Gen_II.Bike_Part, Motivators.Motorcycle'Tag ); |
| |
| -- Check the tag generated for an aggregate. |
| |
| Rentals: declare |
| Mikes_Rental : Vehicle.Object'Class := |
| Vehicle.Object'( 3, (Good, Flat, Worn)); |
| Diannes_Car : Vehicle.Object'Class := |
| Motivators.Tandem'( Wheels => 2, |
| Wheel_State => (Good, Good) ); |
| Jims_Bike : Vehicle.Object'Class := |
| Motivators.Motorcycle'( Pennys_Bike |
| with Displacement => 350 ); |
| Bills_Limo : Vehicle.Object'Class := |
| Motivators.Car'( Wheels => 4, |
| Wheel_State => (others => Good), |
| Displacement => 282 ); |
| Alans_Car : Vehicle.Object'Class := |
| Motivators.Truck'( 18, (others => Worn), |
| Tare => 5_500 ); |
| Pats_Truck : Vehicle.Object'Class := Specter_X; |
| Keiths_Car : Vehicle.Object'Class := Gen_II; |
| Isaacs_Bus : Vehicle.Object'Class := Keiths_Car; |
| |
| begin |
| Vehicle.TC_Validate( Mikes_Rental, Vehicle.Object'Tag ); |
| Vehicle.TC_Validate( Diannes_Car, Motivators.Tandem'Tag ); |
| Vehicle.TC_Validate( Jims_Bike, Motivators.Motorcycle'Tag ); |
| Vehicle.TC_Validate( Bills_Limo, Motivators.Car'Tag ); |
| Vehicle.TC_Validate( Alans_Car, Motivators.Truck'Tag ); |
| Vehicle.TC_Validate( Pats_Truck, Special_Trucks.Auto_Carrier'Tag ); |
| Vehicle.TC_Validate( Keiths_Car, James_Bond.Q_Machine'Tag ); |
| end Rentals; |
| |
| -- Check the tag of parameters. |
| -- Check that the tag is not affected by view conversion. |
| |
| Vehicle.TC_Validate( Vehicle.Object( Gen_II ), James_Bond.Q_Machine'Tag ); |
| Vehicle.TC_Validate( Vehicle.Object( Ms_Limo ), Motivators.Car'Tag ); |
| Vehicle.TC_Validate( Motivators.Bicycle( Weekender ), |
| Motivators.Tandem'Tag ); |
| Vehicle.TC_Validate( Motivators.Bicycle( Gen_II.Bike_Part ), |
| Motivators.Motorcycle'Tag ); |
| |
| Report.Result; |
| |
| end C390003; |
