| -- 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; |
