URL
https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk
Subversion Repositories openrisc_2011-10-31
[/] [openrisc/] [tags/] [gnu-src/] [gcc-4.5.1/] [gcc-4.5.1-or32-1.0rc2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c3/] [c393009.a] - Rev 294
Go to most recent revision | Compare with Previous | Blame | View Log
-- C393009.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.
--*
--
-- TEST OBJECTIVE:
-- Check that an extended type can be derived from an abstract type.
--
-- TEST DESCRIPTION:
-- Declare an abstract type in the specification of a generic package.
-- Instantiate the package and derive an extended type from the abstract
-- (instantiated) type; override all abstract operations; use all
-- inherited operations;
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 14 Oct 95 SAIC Fixed for ACVC 2.0.1
--
--!
with Report;
procedure C393009 is
package Display_Devices is
type Display_Device_Enum is (None, TTY, Console, Big_Screen);
Display : Display_Device_Enum := None;
end Display_Devices;
--=======================================================================--
generic
type Generic_Status is (<>);
type Serial_Type is (<>);
package Alert_System is
type Alert_Type (Serial : Serial_Type) is abstract tagged record
Status : Generic_Status;
end record;
Next_Serial_Number : Serial_Type := Serial_Type'First;
procedure Handle (A : in out Alert_Type) is abstract;
-- abstract operation - must be overridden after instantiation
procedure Display ( A : Alert_Type;
On : Display_Devices.Display_Device_Enum);
-- primitive operation of Alert_Type
-- not required to be overridden
function Get_Serial_Number (A : Alert_Type) return Serial_Type;
-- primitive operation of Alert_Type
-- not required to be overridden
end Alert_System;
--=======================================================================--
package body Alert_System is
procedure Display ( A : in Alert_Type;
On : Display_Devices.Display_Device_Enum) is
begin
Display_Devices.Display := On;
end Display;
function Get_Serial_Number (A : Alert_Type)
return Serial_Type is
begin
return A.Serial;
end Get_Serial_Number;
end Alert_System;
--=======================================================================--
package NCC_1701 is
type Status_Kind is (Green, Yellow, Red);
type Serial_Number_Type is new Integer range 1..Integer'Last;
subtype Msg_Str is String (1..16);
Alert_Msg : Msg_Str := "C393009 passed.";
-- 123456789A123456
package Alert_Pkg is new Alert_System (Status_Kind, Serial_Number_Type);
type New_Alert_Type(Serial : Serial_Number_Type) is
new Alert_Pkg.Alert_Type(Serial) with record
Message : Msg_Str;
end record;
-- procedure Display is inherited by New_Alert_Type
-- function Get_Serial_Number is inherited by New_Alert_Type
procedure Handle (NA : in out New_Alert_Type); -- must be overridden
procedure Init (NA : in out New_Alert_Type); -- new primitive
NA : New_Alert_Type(Alert_Pkg.Next_Serial_Number);
-- New_Alert_Type is not abstract, so an object of that
-- type may be declared
end NCC_1701;
package body NCC_1701 is
procedure Handle (NA : in out New_Alert_Type) is
begin
NA.Message := Alert_Msg;
Display (NA, On => Display_Devices.TTY);
end Handle;
procedure Init (NA : in out New_Alert_Type) is -- new primitive operation
begin -- for New_Alert_Type
NA := (Serial=> NA.Serial, Status => Green, Message => (others => ' '));
end Init;
end NCC_1701;
use NCC_1701;
use type Display_Devices.Display_Device_Enum;
begin
Report.Test ("C393009", "Check that an extended type can be derived " &
"from an abstract type");
Init (NA);
if (Get_Serial_Number (NA) /= 1)
or (NA.Status /= Green)
or (Display_Devices.Display /= Display_Devices.None) then
Report.Failed ("Wrong Initialization");
end if;
Handle (NA);
if (Get_Serial_Number (NA) /= 1)
or (NA.Status /= Green)
or (NA.Message /= Alert_Msg)
or (Display_Devices.Display /= Display_Devices.TTY) then
Report.Failed ("Wrong results from Handle");
end if;
Report.Result;
end C393009;
Go to most recent revision | Compare with Previous | Blame | View Log