diff options
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0013.a')
| -rw-r--r-- | gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0013.a | 347 |
1 files changed, 347 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0013.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0013.a new file mode 100644 index 000000000..b23d4ee11 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c3a0013.a @@ -0,0 +1,347 @@ +-- C3A0013.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 a general access type object may reference allocated +-- pool objects as well as aliased objects. (3,4) +-- Check that formal parameters of tagged types are implicitly +-- defined as aliased; check that the 'Access of these formal +-- parameters designates the correct object with the correct +-- tag. (5) +-- Check that the current instance of a limited type is defined as +-- aliased. (5) +-- +-- TEST DESCRIPTION: +-- This test takes from the hierarchy defined in C390003; making +-- the root type Vehicle limited private. It also shifts the +-- abstraction to include the notion of a transmission, an object +-- which is contained within any vehicle. Using an access +-- discriminant, any subprogram which operates on a transmission +-- may also reference the vehicle in which it is installed. +-- +-- Class Hierarchy: +-- Vehicle Transmission +-- / \ +-- Truck Car +-- +-- Contains: +-- Vehicle( Transmission ) +-- +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- 16 Dec 94 SAIC Fixed accessibility problems +-- +--! + +package C3A0013_1 is + type Vehicle is tagged limited private; + type Vehicle_ID is access all Vehicle'Class; + + -- Constructors + procedure Create ( It : in out Vehicle; + Wheels : Natural := 4 ); + -- Modifiers + procedure Accelerate ( It : in out Vehicle ); + procedure Decelerate ( It : in out Vehicle ); + procedure Up_Shift ( It : in out Vehicle ); + procedure Stop ( It : in out Vehicle ); + + -- Selectors + function Speed ( It : Vehicle ) return Natural; + function Wheels ( It : Vehicle ) return Natural; + function Gear_Factor( It : Vehicle ) return Natural; + + -- TC_Ops + procedure TC_Validate( It : in out Vehicle; Speed_Trap : Natural ); + + -- dispatching procedure used to check tag correctness + procedure TC_Validate( It : Vehicle; + TC_ID : Character); + +private + + type Transmission(Within: access Vehicle'Class) is limited record + Engaged : Boolean := False; + Gear : Integer range -1..5 := 0; + end record; + + -- Current instance of a limited type is defined as aliased + + type Vehicle is tagged limited record + Wheels: Natural; + Speed : Natural; + Power_Train: Transmission( Vehicle'Access ); + end record; +end C3A0013_1; + +with C3A0013_1; +package C3A0013_2 is + type Car is new C3A0013_1.Vehicle with private; + procedure TC_Validate( It : Car; + TC_ID : Character); + function Gear_Factor( It : Car ) return Natural; +private + type Car is new C3A0013_1.Vehicle with record + Displacement : Natural; + end record; +end C3A0013_2; + +with C3A0013_1; +package C3A0013_3 is + type Truck is new C3A0013_1.Vehicle with private; + procedure TC_Validate( It : Truck; + TC_ID : Character); + function Gear_Factor( It : Truck ) return Natural; +private + type Truck is new C3A0013_1.Vehicle with record + Displacement : Natural; + end record; +end C3A0013_3; + +with Report; +package body C3A0013_1 is + + procedure Create ( It : in out Vehicle; + Wheels : Natural := 4 ) is + begin + It.Wheels := Wheels; + It.Speed := 0; + end Create; + + procedure Accelerate( It : in out Vehicle ) is + begin + It.Speed := It.Speed + Gear_Factor( It.Power_Train.Within.all ); + end Accelerate; + + procedure Decelerate( It : in out Vehicle ) is + begin + It.Speed := It.Speed - Gear_Factor( It.Power_Train.Within.all ); + end Decelerate; + + procedure Stop ( It : in out Vehicle ) is + begin + It.Speed := 0; + It.Power_Train.Engaged := False; + end Stop; + + function Gear_Factor( It : Vehicle ) return Natural is + begin + return It.Power_Train.Gear; + end Gear_Factor; + + function Speed ( It : Vehicle ) return Natural is + begin + return It.Speed; + end Speed; + + function Wheels ( It : Vehicle ) return Natural is + begin + return It.Wheels; + end Wheels; + + -- formal tagged parameters are implicitly aliased + + procedure TC_Validate( It : in out Vehicle; Speed_Trap : Natural ) is + License: Vehicle_ID := It'Unchecked_Access; + begin + if Speed( License.all ) /= Speed_Trap then + Report.Failed("Speed Trap: expected: " & Natural'Image(Speed_Trap)); + end if; + end TC_Validate; + + procedure TC_Validate( It : Vehicle; + TC_ID : Character) is + begin + if TC_ID /= 'V' then + Report.Failed("Dispatched to Vehicle"); + end if; + if Wheels( It ) /= 1 then + Report.Failed("Not a Vehicle"); + end if; + end TC_Validate; + + procedure Up_Shift( It: in out Vehicle ) is + begin + It.Power_Train.Gear := It.Power_Train.Gear +1; + It.Power_Train.Engaged := True; + Accelerate( It ); + end Up_Shift; +end C3A0013_1; + +with Report; +package body C3A0013_2 is + + procedure TC_Validate( It : Car; + TC_ID : Character ) is + begin + if TC_ID /= 'C' then + Report.Failed("Dispatched to Car"); + end if; + if Wheels( It ) /= 4 then + Report.Failed("Not a Car"); + end if; + end TC_Validate; + + function Gear_Factor( It : Car ) return Natural is + begin + return C3A0013_1.Gear_Factor( C3A0013_1.Vehicle( It ) )*2; + end Gear_Factor; + +end C3A0013_2; + +with Report; +package body C3A0013_3 is + + procedure TC_Validate( It : Truck; + TC_ID : Character) is + begin + if TC_ID /= 'T' then + Report.Failed("Dispatched to Truck"); + end if; + if Wheels( It ) /= 3 then + Report.Failed("Not a Truck"); + end if; + end TC_Validate; + + function Gear_Factor( It : Truck ) return Natural is + begin + return C3A0013_1.Gear_Factor( C3A0013_1.Vehicle( It ) )*3; + end Gear_Factor; + +end C3A0013_3; + +package C3A0013_4 is + procedure Perform_Tests; +end C3A0013_4; + +with Report; +with C3A0013_1; +with C3A0013_2; +with C3A0013_3; +package body C3A0013_4 is + package Root renames C3A0013_1; + package Cars renames C3A0013_2; + package Trucks renames C3A0013_3; + + type Car_Pool is array(1..4) of aliased Cars.Car; + Commuters : Car_Pool; + + My_Car : aliased Cars.Car; + Company_Car : Root.Vehicle_ID; + Repair_Shop : Root.Vehicle_ID; + + The_Vehicle : Root.Vehicle; + The_Car : Cars.Car; + The_Truck : Trucks.Truck; + + procedure TC_Dispatch( Ptr : Root.Vehicle_ID; + Char : Character ) is + begin + Root.TC_Validate( Ptr.all, Char ); + end TC_Dispatch; + + procedure TC_Check_Formal_Access( Item: in out Root.Vehicle'Class; + Char: Character) is + begin + TC_Dispatch( Item'Unchecked_Access, Char ); + end TC_Check_Formal_Access; + + procedure Perform_Tests is + begin -- Main test procedure. + + for Lane in Commuters'Range loop + Cars.Create( Commuters(Lane) ); + for Excitement in 1..Lane loop + Cars.Up_Shift( Commuters(Lane) ); + end loop; + end loop; + + Cars.Create( My_Car ); + Cars.Up_Shift( My_Car ); + Cars.TC_Validate( My_Car, 2 ); + + Root.Create( The_Vehicle, 1 ); + Cars.Create( The_Car , 4 ); + Trucks.Create( The_Truck, 3 ); + + TC_Check_Formal_Access( The_Vehicle, 'V' ); + TC_Check_Formal_Access( The_Car, 'C' ); + TC_Check_Formal_Access( The_Truck, 'T' ); + + Root.Up_Shift( The_Vehicle ); + Cars.Up_Shift( The_Car ); + Trucks.Up_Shift( The_Truck ); + + Root.TC_Validate( The_Vehicle, 1 ); + Cars.TC_Validate( The_Car, 2 ); + Trucks.TC_Validate( The_Truck, 3 ); + + -- general access type may reference allocated objects + + Company_Car := new Cars.Car; + Root.Create( Company_Car.all ); + Root.Up_Shift( Company_Car.all ); + Root.Up_Shift( Company_Car.all ); + Root.TC_Validate( Company_Car.all, 6 ); + + -- general access type may reference aliased objects + + Repair_Shop := My_Car'Access; + Root.TC_Validate( Repair_Shop.all, 2 ); + + -- general access type may reference aliased objects + + Construction: declare + type Speed_List is array(Commuters'Range) of Natural; + Accelerations : constant Speed_List := (2, 6, 12, 20); + begin + for Rotation in Commuters'Range loop + Repair_Shop := Commuters(Rotation)'Access; + Root.TC_Validate( Repair_Shop.all, Accelerations(Rotation) ); + end loop; + end Construction; + +end Perform_Tests; + +end C3A0013_4; + +with C3A0013_4; +with Report; +procedure C3A0013 is +begin + + Report.Test ("C3A0013", "Check general access types. Check aliased " + & "nature of formal tagged type parameters. " + & "Check aliased nature of the current " + & "instance of a limited type. Check the " + & "constraining of actual subtypes for " + & "discriminated objects" ); + + C3A0013_4.Perform_Tests; + + Report.Result; +end C3A0013; |