From 554fd8c5195424bdbcabf5de30fdc183aba391bd Mon Sep 17 00:00:00 2001 From: upstream source tree Date: Sun, 15 Mar 2015 20:14:05 -0400 Subject: obtained gcc-4.6.4.tar.bz2 from upstream website; verified gcc-4.6.4.tar.bz2.sig; imported gcc-4.6.4 source tree from verified upstream tarball. downloading a git-generated archive based on the 'upstream' tag should provide you with a source tree that is binary identical to the one extracted from the above tarball. if you have obtained the source via the command 'git clone', however, do note that line-endings of files in your working directory might differ from line-endings of the respective files in the upstream repository. --- gcc/testsuite/ada/acats/tests/c3/c390003.a | 419 +++++++++++++++++++++++++++++ 1 file changed, 419 insertions(+) create mode 100644 gcc/testsuite/ada/acats/tests/c3/c390003.a (limited to 'gcc/testsuite/ada/acats/tests/c3/c390003.a') diff --git a/gcc/testsuite/ada/acats/tests/c3/c390003.a b/gcc/testsuite/ada/acats/tests/c3/c390003.a new file mode 100644 index 000000000..643aad1cd --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c390003.a @@ -0,0 +1,419 @@ +-- 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; -- cgit v1.2.3