-- C3A0013.A
|
-- C3A0013.A
|
--
|
--
|
-- Grant of Unlimited Rights
|
-- Grant of Unlimited Rights
|
--
|
--
|
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
|
-- 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
|
-- 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 in the software and documentation contained herein.
|
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
|
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
|
-- this public release, the Government intends to confer upon all
|
-- this public release, the Government intends to confer upon all
|
-- recipients unlimited rights equal to those held by the Government.
|
-- recipients unlimited rights equal to those held by the Government.
|
-- These rights include rights to use, duplicate, release or disclose the
|
-- These rights include rights to use, duplicate, release or disclose the
|
-- released technical data and computer software in whole or in part, in
|
-- 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
|
-- any manner and for any purpose whatsoever, and to have or permit others
|
-- to do so.
|
-- to do so.
|
--
|
--
|
-- DISCLAIMER
|
-- DISCLAIMER
|
--
|
--
|
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
|
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
|
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
|
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
|
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
|
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
|
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
|
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
|
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
|
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
|
-- PARTICULAR PURPOSE OF SAID MATERIAL.
|
-- PARTICULAR PURPOSE OF SAID MATERIAL.
|
--*
|
--*
|
--
|
--
|
-- OBJECTIVE:
|
-- OBJECTIVE:
|
-- Check that a general access type object may reference allocated
|
-- Check that a general access type object may reference allocated
|
-- pool objects as well as aliased objects. (3,4)
|
-- pool objects as well as aliased objects. (3,4)
|
-- Check that formal parameters of tagged types are implicitly
|
-- Check that formal parameters of tagged types are implicitly
|
-- defined as aliased; check that the 'Access of these formal
|
-- defined as aliased; check that the 'Access of these formal
|
-- parameters designates the correct object with the correct
|
-- parameters designates the correct object with the correct
|
-- tag. (5)
|
-- tag. (5)
|
-- Check that the current instance of a limited type is defined as
|
-- Check that the current instance of a limited type is defined as
|
-- aliased. (5)
|
-- aliased. (5)
|
--
|
--
|
-- TEST DESCRIPTION:
|
-- TEST DESCRIPTION:
|
-- This test takes from the hierarchy defined in C390003; making
|
-- This test takes from the hierarchy defined in C390003; making
|
-- the root type Vehicle limited private. It also shifts the
|
-- the root type Vehicle limited private. It also shifts the
|
-- abstraction to include the notion of a transmission, an object
|
-- abstraction to include the notion of a transmission, an object
|
-- which is contained within any vehicle. Using an access
|
-- which is contained within any vehicle. Using an access
|
-- discriminant, any subprogram which operates on a transmission
|
-- discriminant, any subprogram which operates on a transmission
|
-- may also reference the vehicle in which it is installed.
|
-- may also reference the vehicle in which it is installed.
|
--
|
--
|
-- Class Hierarchy:
|
-- Class Hierarchy:
|
-- Vehicle Transmission
|
-- Vehicle Transmission
|
-- / \
|
-- / \
|
-- Truck Car
|
-- Truck Car
|
--
|
--
|
-- Contains:
|
-- Contains:
|
-- Vehicle( Transmission )
|
-- Vehicle( Transmission )
|
--
|
--
|
--
|
--
|
--
|
--
|
-- CHANGE HISTORY:
|
-- CHANGE HISTORY:
|
-- 06 Dec 94 SAIC ACVC 2.0
|
-- 06 Dec 94 SAIC ACVC 2.0
|
-- 16 Dec 94 SAIC Fixed accessibility problems
|
-- 16 Dec 94 SAIC Fixed accessibility problems
|
--
|
--
|
--!
|
--!
|
|
|
package C3A0013_1 is
|
package C3A0013_1 is
|
type Vehicle is tagged limited private;
|
type Vehicle is tagged limited private;
|
type Vehicle_ID is access all Vehicle'Class;
|
type Vehicle_ID is access all Vehicle'Class;
|
|
|
-- Constructors
|
-- Constructors
|
procedure Create ( It : in out Vehicle;
|
procedure Create ( It : in out Vehicle;
|
Wheels : Natural := 4 );
|
Wheels : Natural := 4 );
|
-- Modifiers
|
-- Modifiers
|
procedure Accelerate ( It : in out Vehicle );
|
procedure Accelerate ( It : in out Vehicle );
|
procedure Decelerate ( It : in out Vehicle );
|
procedure Decelerate ( It : in out Vehicle );
|
procedure Up_Shift ( It : in out Vehicle );
|
procedure Up_Shift ( It : in out Vehicle );
|
procedure Stop ( It : in out Vehicle );
|
procedure Stop ( It : in out Vehicle );
|
|
|
-- Selectors
|
-- Selectors
|
function Speed ( It : Vehicle ) return Natural;
|
function Speed ( It : Vehicle ) return Natural;
|
function Wheels ( It : Vehicle ) return Natural;
|
function Wheels ( It : Vehicle ) return Natural;
|
function Gear_Factor( It : Vehicle ) return Natural;
|
function Gear_Factor( It : Vehicle ) return Natural;
|
|
|
-- TC_Ops
|
-- TC_Ops
|
procedure TC_Validate( It : in out Vehicle; Speed_Trap : Natural );
|
procedure TC_Validate( It : in out Vehicle; Speed_Trap : Natural );
|
|
|
-- dispatching procedure used to check tag correctness
|
-- dispatching procedure used to check tag correctness
|
procedure TC_Validate( It : Vehicle;
|
procedure TC_Validate( It : Vehicle;
|
TC_ID : Character);
|
TC_ID : Character);
|
|
|
private
|
private
|
|
|
type Transmission(Within: access Vehicle'Class) is limited record
|
type Transmission(Within: access Vehicle'Class) is limited record
|
Engaged : Boolean := False;
|
Engaged : Boolean := False;
|
Gear : Integer range -1..5 := 0;
|
Gear : Integer range -1..5 := 0;
|
end record;
|
end record;
|
|
|
-- Current instance of a limited type is defined as aliased
|
-- Current instance of a limited type is defined as aliased
|
|
|
type Vehicle is tagged limited record
|
type Vehicle is tagged limited record
|
Wheels: Natural;
|
Wheels: Natural;
|
Speed : Natural;
|
Speed : Natural;
|
Power_Train: Transmission( Vehicle'Access );
|
Power_Train: Transmission( Vehicle'Access );
|
end record;
|
end record;
|
end C3A0013_1;
|
end C3A0013_1;
|
|
|
with C3A0013_1;
|
with C3A0013_1;
|
package C3A0013_2 is
|
package C3A0013_2 is
|
type Car is new C3A0013_1.Vehicle with private;
|
type Car is new C3A0013_1.Vehicle with private;
|
procedure TC_Validate( It : Car;
|
procedure TC_Validate( It : Car;
|
TC_ID : Character);
|
TC_ID : Character);
|
function Gear_Factor( It : Car ) return Natural;
|
function Gear_Factor( It : Car ) return Natural;
|
private
|
private
|
type Car is new C3A0013_1.Vehicle with record
|
type Car is new C3A0013_1.Vehicle with record
|
Displacement : Natural;
|
Displacement : Natural;
|
end record;
|
end record;
|
end C3A0013_2;
|
end C3A0013_2;
|
|
|
with C3A0013_1;
|
with C3A0013_1;
|
package C3A0013_3 is
|
package C3A0013_3 is
|
type Truck is new C3A0013_1.Vehicle with private;
|
type Truck is new C3A0013_1.Vehicle with private;
|
procedure TC_Validate( It : Truck;
|
procedure TC_Validate( It : Truck;
|
TC_ID : Character);
|
TC_ID : Character);
|
function Gear_Factor( It : Truck ) return Natural;
|
function Gear_Factor( It : Truck ) return Natural;
|
private
|
private
|
type Truck is new C3A0013_1.Vehicle with record
|
type Truck is new C3A0013_1.Vehicle with record
|
Displacement : Natural;
|
Displacement : Natural;
|
end record;
|
end record;
|
end C3A0013_3;
|
end C3A0013_3;
|
|
|
with Report;
|
with Report;
|
package body C3A0013_1 is
|
package body C3A0013_1 is
|
|
|
procedure Create ( It : in out Vehicle;
|
procedure Create ( It : in out Vehicle;
|
Wheels : Natural := 4 ) is
|
Wheels : Natural := 4 ) is
|
begin
|
begin
|
It.Wheels := Wheels;
|
It.Wheels := Wheels;
|
It.Speed := 0;
|
It.Speed := 0;
|
end Create;
|
end Create;
|
|
|
procedure Accelerate( It : in out Vehicle ) is
|
procedure Accelerate( It : in out Vehicle ) is
|
begin
|
begin
|
It.Speed := It.Speed + Gear_Factor( It.Power_Train.Within.all );
|
It.Speed := It.Speed + Gear_Factor( It.Power_Train.Within.all );
|
end Accelerate;
|
end Accelerate;
|
|
|
procedure Decelerate( It : in out Vehicle ) is
|
procedure Decelerate( It : in out Vehicle ) is
|
begin
|
begin
|
It.Speed := It.Speed - Gear_Factor( It.Power_Train.Within.all );
|
It.Speed := It.Speed - Gear_Factor( It.Power_Train.Within.all );
|
end Decelerate;
|
end Decelerate;
|
|
|
procedure Stop ( It : in out Vehicle ) is
|
procedure Stop ( It : in out Vehicle ) is
|
begin
|
begin
|
It.Speed := 0;
|
It.Speed := 0;
|
It.Power_Train.Engaged := False;
|
It.Power_Train.Engaged := False;
|
end Stop;
|
end Stop;
|
|
|
function Gear_Factor( It : Vehicle ) return Natural is
|
function Gear_Factor( It : Vehicle ) return Natural is
|
begin
|
begin
|
return It.Power_Train.Gear;
|
return It.Power_Train.Gear;
|
end Gear_Factor;
|
end Gear_Factor;
|
|
|
function Speed ( It : Vehicle ) return Natural is
|
function Speed ( It : Vehicle ) return Natural is
|
begin
|
begin
|
return It.Speed;
|
return It.Speed;
|
end Speed;
|
end Speed;
|
|
|
function Wheels ( It : Vehicle ) return Natural is
|
function Wheels ( It : Vehicle ) return Natural is
|
begin
|
begin
|
return It.Wheels;
|
return It.Wheels;
|
end Wheels;
|
end Wheels;
|
|
|
-- formal tagged parameters are implicitly aliased
|
-- formal tagged parameters are implicitly aliased
|
|
|
procedure TC_Validate( It : in out Vehicle; Speed_Trap : Natural ) is
|
procedure TC_Validate( It : in out Vehicle; Speed_Trap : Natural ) is
|
License: Vehicle_ID := It'Unchecked_Access;
|
License: Vehicle_ID := It'Unchecked_Access;
|
begin
|
begin
|
if Speed( License.all ) /= Speed_Trap then
|
if Speed( License.all ) /= Speed_Trap then
|
Report.Failed("Speed Trap: expected: " & Natural'Image(Speed_Trap));
|
Report.Failed("Speed Trap: expected: " & Natural'Image(Speed_Trap));
|
end if;
|
end if;
|
end TC_Validate;
|
end TC_Validate;
|
|
|
procedure TC_Validate( It : Vehicle;
|
procedure TC_Validate( It : Vehicle;
|
TC_ID : Character) is
|
TC_ID : Character) is
|
begin
|
begin
|
if TC_ID /= 'V' then
|
if TC_ID /= 'V' then
|
Report.Failed("Dispatched to Vehicle");
|
Report.Failed("Dispatched to Vehicle");
|
end if;
|
end if;
|
if Wheels( It ) /= 1 then
|
if Wheels( It ) /= 1 then
|
Report.Failed("Not a Vehicle");
|
Report.Failed("Not a Vehicle");
|
end if;
|
end if;
|
end TC_Validate;
|
end TC_Validate;
|
|
|
procedure Up_Shift( It: in out Vehicle ) is
|
procedure Up_Shift( It: in out Vehicle ) is
|
begin
|
begin
|
It.Power_Train.Gear := It.Power_Train.Gear +1;
|
It.Power_Train.Gear := It.Power_Train.Gear +1;
|
It.Power_Train.Engaged := True;
|
It.Power_Train.Engaged := True;
|
Accelerate( It );
|
Accelerate( It );
|
end Up_Shift;
|
end Up_Shift;
|
end C3A0013_1;
|
end C3A0013_1;
|
|
|
with Report;
|
with Report;
|
package body C3A0013_2 is
|
package body C3A0013_2 is
|
|
|
procedure TC_Validate( It : Car;
|
procedure TC_Validate( It : Car;
|
TC_ID : Character ) is
|
TC_ID : Character ) is
|
begin
|
begin
|
if TC_ID /= 'C' then
|
if TC_ID /= 'C' then
|
Report.Failed("Dispatched to Car");
|
Report.Failed("Dispatched to Car");
|
end if;
|
end if;
|
if Wheels( It ) /= 4 then
|
if Wheels( It ) /= 4 then
|
Report.Failed("Not a Car");
|
Report.Failed("Not a Car");
|
end if;
|
end if;
|
end TC_Validate;
|
end TC_Validate;
|
|
|
function Gear_Factor( It : Car ) return Natural is
|
function Gear_Factor( It : Car ) return Natural is
|
begin
|
begin
|
return C3A0013_1.Gear_Factor( C3A0013_1.Vehicle( It ) )*2;
|
return C3A0013_1.Gear_Factor( C3A0013_1.Vehicle( It ) )*2;
|
end Gear_Factor;
|
end Gear_Factor;
|
|
|
end C3A0013_2;
|
end C3A0013_2;
|
|
|
with Report;
|
with Report;
|
package body C3A0013_3 is
|
package body C3A0013_3 is
|
|
|
procedure TC_Validate( It : Truck;
|
procedure TC_Validate( It : Truck;
|
TC_ID : Character) is
|
TC_ID : Character) is
|
begin
|
begin
|
if TC_ID /= 'T' then
|
if TC_ID /= 'T' then
|
Report.Failed("Dispatched to Truck");
|
Report.Failed("Dispatched to Truck");
|
end if;
|
end if;
|
if Wheels( It ) /= 3 then
|
if Wheels( It ) /= 3 then
|
Report.Failed("Not a Truck");
|
Report.Failed("Not a Truck");
|
end if;
|
end if;
|
end TC_Validate;
|
end TC_Validate;
|
|
|
function Gear_Factor( It : Truck ) return Natural is
|
function Gear_Factor( It : Truck ) return Natural is
|
begin
|
begin
|
return C3A0013_1.Gear_Factor( C3A0013_1.Vehicle( It ) )*3;
|
return C3A0013_1.Gear_Factor( C3A0013_1.Vehicle( It ) )*3;
|
end Gear_Factor;
|
end Gear_Factor;
|
|
|
end C3A0013_3;
|
end C3A0013_3;
|
|
|
package C3A0013_4 is
|
package C3A0013_4 is
|
procedure Perform_Tests;
|
procedure Perform_Tests;
|
end C3A0013_4;
|
end C3A0013_4;
|
|
|
with Report;
|
with Report;
|
with C3A0013_1;
|
with C3A0013_1;
|
with C3A0013_2;
|
with C3A0013_2;
|
with C3A0013_3;
|
with C3A0013_3;
|
package body C3A0013_4 is
|
package body C3A0013_4 is
|
package Root renames C3A0013_1;
|
package Root renames C3A0013_1;
|
package Cars renames C3A0013_2;
|
package Cars renames C3A0013_2;
|
package Trucks renames C3A0013_3;
|
package Trucks renames C3A0013_3;
|
|
|
type Car_Pool is array(1..4) of aliased Cars.Car;
|
type Car_Pool is array(1..4) of aliased Cars.Car;
|
Commuters : Car_Pool;
|
Commuters : Car_Pool;
|
|
|
My_Car : aliased Cars.Car;
|
My_Car : aliased Cars.Car;
|
Company_Car : Root.Vehicle_ID;
|
Company_Car : Root.Vehicle_ID;
|
Repair_Shop : Root.Vehicle_ID;
|
Repair_Shop : Root.Vehicle_ID;
|
|
|
The_Vehicle : Root.Vehicle;
|
The_Vehicle : Root.Vehicle;
|
The_Car : Cars.Car;
|
The_Car : Cars.Car;
|
The_Truck : Trucks.Truck;
|
The_Truck : Trucks.Truck;
|
|
|
procedure TC_Dispatch( Ptr : Root.Vehicle_ID;
|
procedure TC_Dispatch( Ptr : Root.Vehicle_ID;
|
Char : Character ) is
|
Char : Character ) is
|
begin
|
begin
|
Root.TC_Validate( Ptr.all, Char );
|
Root.TC_Validate( Ptr.all, Char );
|
end TC_Dispatch;
|
end TC_Dispatch;
|
|
|
procedure TC_Check_Formal_Access( Item: in out Root.Vehicle'Class;
|
procedure TC_Check_Formal_Access( Item: in out Root.Vehicle'Class;
|
Char: Character) is
|
Char: Character) is
|
begin
|
begin
|
TC_Dispatch( Item'Unchecked_Access, Char );
|
TC_Dispatch( Item'Unchecked_Access, Char );
|
end TC_Check_Formal_Access;
|
end TC_Check_Formal_Access;
|
|
|
procedure Perform_Tests is
|
procedure Perform_Tests is
|
begin -- Main test procedure.
|
begin -- Main test procedure.
|
|
|
for Lane in Commuters'Range loop
|
for Lane in Commuters'Range loop
|
Cars.Create( Commuters(Lane) );
|
Cars.Create( Commuters(Lane) );
|
for Excitement in 1..Lane loop
|
for Excitement in 1..Lane loop
|
Cars.Up_Shift( Commuters(Lane) );
|
Cars.Up_Shift( Commuters(Lane) );
|
end loop;
|
end loop;
|
end loop;
|
end loop;
|
|
|
Cars.Create( My_Car );
|
Cars.Create( My_Car );
|
Cars.Up_Shift( My_Car );
|
Cars.Up_Shift( My_Car );
|
Cars.TC_Validate( My_Car, 2 );
|
Cars.TC_Validate( My_Car, 2 );
|
|
|
Root.Create( The_Vehicle, 1 );
|
Root.Create( The_Vehicle, 1 );
|
Cars.Create( The_Car , 4 );
|
Cars.Create( The_Car , 4 );
|
Trucks.Create( The_Truck, 3 );
|
Trucks.Create( The_Truck, 3 );
|
|
|
TC_Check_Formal_Access( The_Vehicle, 'V' );
|
TC_Check_Formal_Access( The_Vehicle, 'V' );
|
TC_Check_Formal_Access( The_Car, 'C' );
|
TC_Check_Formal_Access( The_Car, 'C' );
|
TC_Check_Formal_Access( The_Truck, 'T' );
|
TC_Check_Formal_Access( The_Truck, 'T' );
|
|
|
Root.Up_Shift( The_Vehicle );
|
Root.Up_Shift( The_Vehicle );
|
Cars.Up_Shift( The_Car );
|
Cars.Up_Shift( The_Car );
|
Trucks.Up_Shift( The_Truck );
|
Trucks.Up_Shift( The_Truck );
|
|
|
Root.TC_Validate( The_Vehicle, 1 );
|
Root.TC_Validate( The_Vehicle, 1 );
|
Cars.TC_Validate( The_Car, 2 );
|
Cars.TC_Validate( The_Car, 2 );
|
Trucks.TC_Validate( The_Truck, 3 );
|
Trucks.TC_Validate( The_Truck, 3 );
|
|
|
-- general access type may reference allocated objects
|
-- general access type may reference allocated objects
|
|
|
Company_Car := new Cars.Car;
|
Company_Car := new Cars.Car;
|
Root.Create( Company_Car.all );
|
Root.Create( Company_Car.all );
|
Root.Up_Shift( Company_Car.all );
|
Root.Up_Shift( Company_Car.all );
|
Root.Up_Shift( Company_Car.all );
|
Root.Up_Shift( Company_Car.all );
|
Root.TC_Validate( Company_Car.all, 6 );
|
Root.TC_Validate( Company_Car.all, 6 );
|
|
|
-- general access type may reference aliased objects
|
-- general access type may reference aliased objects
|
|
|
Repair_Shop := My_Car'Access;
|
Repair_Shop := My_Car'Access;
|
Root.TC_Validate( Repair_Shop.all, 2 );
|
Root.TC_Validate( Repair_Shop.all, 2 );
|
|
|
-- general access type may reference aliased objects
|
-- general access type may reference aliased objects
|
|
|
Construction: declare
|
Construction: declare
|
type Speed_List is array(Commuters'Range) of Natural;
|
type Speed_List is array(Commuters'Range) of Natural;
|
Accelerations : constant Speed_List := (2, 6, 12, 20);
|
Accelerations : constant Speed_List := (2, 6, 12, 20);
|
begin
|
begin
|
for Rotation in Commuters'Range loop
|
for Rotation in Commuters'Range loop
|
Repair_Shop := Commuters(Rotation)'Access;
|
Repair_Shop := Commuters(Rotation)'Access;
|
Root.TC_Validate( Repair_Shop.all, Accelerations(Rotation) );
|
Root.TC_Validate( Repair_Shop.all, Accelerations(Rotation) );
|
end loop;
|
end loop;
|
end Construction;
|
end Construction;
|
|
|
end Perform_Tests;
|
end Perform_Tests;
|
|
|
end C3A0013_4;
|
end C3A0013_4;
|
|
|
with C3A0013_4;
|
with C3A0013_4;
|
with Report;
|
with Report;
|
procedure C3A0013 is
|
procedure C3A0013 is
|
begin
|
begin
|
|
|
Report.Test ("C3A0013", "Check general access types. Check aliased "
|
Report.Test ("C3A0013", "Check general access types. Check aliased "
|
& "nature of formal tagged type parameters. "
|
& "nature of formal tagged type parameters. "
|
& "Check aliased nature of the current "
|
& "Check aliased nature of the current "
|
& "instance of a limited type. Check the "
|
& "instance of a limited type. Check the "
|
& "constraining of actual subtypes for "
|
& "constraining of actual subtypes for "
|
& "discriminated objects" );
|
& "discriminated objects" );
|
|
|
C3A0013_4.Perform_Tests;
|
C3A0013_4.Perform_Tests;
|
|
|
Report.Result;
|
Report.Result;
|
end C3A0013;
|
end C3A0013;
|
|
|
