diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c3/c390003.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c3/c390003.a | 419 |
1 files changed, 0 insertions, 419 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c3/c390003.a b/gcc/testsuite/ada/acats/tests/c3/c390003.a deleted file mode 100644 index 643aad1cd18..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c390003.a +++ /dev/null @@ -1,419 +0,0 @@ --- 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; |