-- C390002.A
|
-- C390002.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 tagged base type may be declared, and derived
|
-- Check that a tagged base type may be declared, and derived
|
-- from in simple, private and extended forms. (Overlaps with C390B04)
|
-- from in simple, private and extended forms. (Overlaps with C390B04)
|
-- Check that the package Ada.Tags is present and correctly implemented.
|
-- Check that the package Ada.Tags is present and correctly implemented.
|
-- Check for the correct operation of Expanded_Name, External_Tag and
|
-- Check for the correct operation of Expanded_Name, External_Tag and
|
-- Internal_Tag within that package. Check that the exception Tag_Error
|
-- Internal_Tag within that package. Check that the exception Tag_Error
|
-- is correctly raised on calling Internal_Tag with bad input.
|
-- is correctly raised on calling Internal_Tag with bad input.
|
--
|
--
|
-- TEST DESCRIPTION:
|
-- TEST DESCRIPTION:
|
-- This test declares a tagged type, and derives three types from it.
|
-- This test declares a tagged type, and derives three types from it.
|
-- These types are then used to test the presence and function of the
|
-- These types are then used to test the presence and function of the
|
-- package Ada.Tags.
|
-- package Ada.Tags.
|
--
|
--
|
--
|
--
|
-- CHANGE HISTORY:
|
-- CHANGE HISTORY:
|
-- 06 Dec 94 SAIC ACVC 2.0
|
-- 06 Dec 94 SAIC ACVC 2.0
|
-- 19 Dec 94 SAIC Removed RM references from objective text.
|
-- 19 Dec 94 SAIC Removed RM references from objective text.
|
-- 27 Jan 96 SAIC Update RM references for 2.1
|
-- 27 Jan 96 SAIC Update RM references for 2.1
|
--
|
--
|
--!
|
--!
|
|
|
with Report;
|
with Report;
|
with Ada.Tags;
|
with Ada.Tags;
|
|
|
procedure C390002 is
|
procedure C390002 is
|
|
|
package Vehicle is
|
package Vehicle is
|
|
|
type Object is tagged limited private; -- ancestor type
|
type Object is tagged limited private; -- ancestor type
|
procedure Create( The_Vehicle : in out Object; Wheels : in Natural );
|
procedure Create( The_Vehicle : in out Object; Wheels : in Natural );
|
function Wheels( The_Vehicle : Object ) return Natural;
|
function Wheels( The_Vehicle : Object ) return Natural;
|
|
|
private
|
private
|
|
|
type Object is tagged limited record
|
type Object is tagged limited record
|
Wheel_Count : Natural := 0;
|
Wheel_Count : Natural := 0;
|
end record;
|
end record;
|
|
|
end Vehicle;
|
end Vehicle;
|
|
|
package Motivators is
|
package Motivators is
|
|
|
type Bicycle is new Vehicle.Object with null record; -- simple
|
type Bicycle is new Vehicle.Object with null record; -- simple
|
|
|
type Car is new Vehicle.Object with record -- extended
|
type Car is new Vehicle.Object with record -- extended
|
Convertible : Boolean;
|
Convertible : Boolean;
|
end record;
|
end record;
|
|
|
type Truck is new Vehicle.Object with private; -- private
|
type Truck is new Vehicle.Object with private; -- private
|
|
|
private
|
private
|
|
|
type Truck is new Vehicle.Object with record
|
type Truck is new Vehicle.Object with record
|
Air_Horn : Boolean;
|
Air_Horn : Boolean;
|
end record;
|
end record;
|
|
|
end Motivators;
|
end Motivators;
|
|
|
package body Vehicle is
|
package body Vehicle is
|
|
|
procedure Create( The_Vehicle : in out Object; Wheels : in Natural ) is
|
procedure Create( The_Vehicle : in out Object; Wheels : in Natural ) is
|
begin
|
begin
|
The_Vehicle.Wheel_Count := Wheels;
|
The_Vehicle.Wheel_Count := Wheels;
|
end Create;
|
end Create;
|
|
|
function Wheels( The_Vehicle : Object ) return Natural is
|
function Wheels( The_Vehicle : Object ) return Natural is
|
begin
|
begin
|
return The_Vehicle.Wheel_Count;
|
return The_Vehicle.Wheel_Count;
|
end Wheels;
|
end Wheels;
|
|
|
end Vehicle;
|
end Vehicle;
|
|
|
function TC_ID_Tag( Tag : in Ada.Tags.Tag ) return Ada.Tags.Tag is
|
function TC_ID_Tag( Tag : in Ada.Tags.Tag ) return Ada.Tags.Tag is
|
begin
|
begin
|
return Ada.Tags.Internal_Tag( Ada.Tags.External_Tag( Tag ) );
|
return Ada.Tags.Internal_Tag( Ada.Tags.External_Tag( Tag ) );
|
Report.Comment("This message intentionally blank.");
|
Report.Comment("This message intentionally blank.");
|
end TC_ID_Tag;
|
end TC_ID_Tag;
|
|
|
procedure Check_Tags( Machine : in Vehicle.Object'Class;
|
procedure Check_Tags( Machine : in Vehicle.Object'Class;
|
Expected_Name : in String;
|
Expected_Name : in String;
|
External_Tag : in String ) is
|
External_Tag : in String ) is
|
The_Tag : constant Ada.Tags.Tag := Machine'Tag;
|
The_Tag : constant Ada.Tags.Tag := Machine'Tag;
|
use type Ada.Tags.Tag;
|
use type Ada.Tags.Tag;
|
begin
|
begin
|
if Ada.Tags.Expanded_Name(The_Tag) /= Expected_Name then
|
if Ada.Tags.Expanded_Name(The_Tag) /= Expected_Name then
|
Report.Failed ("Failed in Check_Tags, Expanded_Name "
|
Report.Failed ("Failed in Check_Tags, Expanded_Name "
|
& Expected_Name);
|
& Expected_Name);
|
end if;
|
end if;
|
if Ada.Tags.External_Tag(The_Tag) /= External_Tag then
|
if Ada.Tags.External_Tag(The_Tag) /= External_Tag then
|
Report.Failed ("Failed in Check_Tags, External_Tag "
|
Report.Failed ("Failed in Check_Tags, External_Tag "
|
& Expected_Name);
|
& Expected_Name);
|
end if;
|
end if;
|
if Ada.Tags.Internal_Tag(External_Tag) /= The_Tag then
|
if Ada.Tags.Internal_Tag(External_Tag) /= The_Tag then
|
Report.Failed ("Failed in Check_Tags, Internal_Tag "
|
Report.Failed ("Failed in Check_Tags, Internal_Tag "
|
& Expected_Name);
|
& Expected_Name);
|
end if;
|
end if;
|
end Check_Tags;
|
end Check_Tags;
|
|
|
procedure Check_Exception is
|
procedure Check_Exception is
|
Boeing_777_Id : Ada.Tags.Tag;
|
Boeing_777_Id : Ada.Tags.Tag;
|
begin
|
begin
|
Boeing_777_Id := Ada.Tags.Internal_Tag("!@#$%^:*\/?"" not a tag!");
|
Boeing_777_Id := Ada.Tags.Internal_Tag("!@#$%^:*\/?"" not a tag!");
|
Report.Failed ("Failed in Check_Exception, no exception");
|
Report.Failed ("Failed in Check_Exception, no exception");
|
Boeing_777_Id := TC_ID_Tag( Boeing_777_Id );
|
Boeing_777_Id := TC_ID_Tag( Boeing_777_Id );
|
exception
|
exception
|
when Ada.Tags.Tag_Error => null;
|
when Ada.Tags.Tag_Error => null;
|
when others =>
|
when others =>
|
Report.Failed ("Failed in Check_Exception, wrong exception");
|
Report.Failed ("Failed in Check_Exception, wrong exception");
|
end Check_Exception;
|
end Check_Exception;
|
|
|
use Motivators;
|
use Motivators;
|
Two_Wheeler : Bicycle;
|
Two_Wheeler : Bicycle;
|
Four_Wheeler : Car;
|
Four_Wheeler : Car;
|
Eighteen_Wheeler : Truck;
|
Eighteen_Wheeler : Truck;
|
|
|
begin -- Main test procedure.
|
begin -- Main test procedure.
|
|
|
Report.Test ("C390002", "Check that a tagged type may be declared and " &
|
Report.Test ("C390002", "Check that a tagged type may be declared and " &
|
"derived from in simple, private and extended forms. " &
|
"derived from in simple, private and extended forms. " &
|
"Check package Ada.Tags" );
|
"Check package Ada.Tags" );
|
|
|
Create( Two_Wheeler, 2 );
|
Create( Two_Wheeler, 2 );
|
Create( Four_Wheeler, 4 );
|
Create( Four_Wheeler, 4 );
|
Create( Eighteen_Wheeler, 18 );
|
Create( Eighteen_Wheeler, 18 );
|
|
|
Check_Tags( Machine => Two_Wheeler,
|
Check_Tags( Machine => Two_Wheeler,
|
Expected_Name => "C390002.MOTIVATORS.BICYCLE",
|
Expected_Name => "C390002.MOTIVATORS.BICYCLE",
|
External_Tag => Bicycle'External_Tag );
|
External_Tag => Bicycle'External_Tag );
|
Check_Tags( Machine => Four_Wheeler,
|
Check_Tags( Machine => Four_Wheeler,
|
Expected_Name => "C390002.MOTIVATORS.CAR",
|
Expected_Name => "C390002.MOTIVATORS.CAR",
|
External_Tag => Car'External_Tag );
|
External_Tag => Car'External_Tag );
|
Check_Tags( Machine => Eighteen_Wheeler,
|
Check_Tags( Machine => Eighteen_Wheeler,
|
Expected_Name => "C390002.MOTIVATORS.TRUCK",
|
Expected_Name => "C390002.MOTIVATORS.TRUCK",
|
External_Tag => Truck'External_Tag );
|
External_Tag => Truck'External_Tag );
|
|
|
Check_Exception;
|
Check_Exception;
|
|
|
Report.Result;
|
Report.Result;
|
|
|
end C390002;
|
end C390002;
|
|
|