URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c7/] [c730001.a] - Rev 149
Go to most recent revision | Compare with Previous | Blame | View Log
-- C730001.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 the full view of a private extension may be derived
-- indirectly from the ancestor type (i.e., the parent type of the full
-- type may be any descendant of the ancestor type). Check that, for
-- a primitive subprogram of the private extension that is inherited from
-- the ancestor type and not overridden, the formal parameter names and
-- default expressions come from the corresponding primitive subprogram
-- of the ancestor type, while the body comes from that of the parent
-- type. Check both dispatching and non-dispatching cases.
--
-- TEST DESCRIPTION:
-- Consider:
--
-- package P is
-- type Ancestor is tagged ...
-- procedure Op (P1: Ancestor; P2: Boolean := True);
-- end P;
--
-- with P;
-- package Q is
-- type Derived is new P.Ancestor with ...
-- procedure Op (X: Ancestor; Y: Boolean := False);
-- end Q;
--
-- with P, Q;
-- package R is
-- type Priv_Ext is new P.Ancestor with private; -- (A)
-- -- Inherits procedure Op (P1: Priv_Ext; P2: Boolean := True);
-- -- But body executed is that of Q.Op.
-- private
-- type Priv_Ext is new Q.Derived with record ... -- (B)
-- end R;
--
-- The ancestor type in (A) differs from the parent type in (B); the
-- parent of the full type is descended from the ancestor type of the
-- private extension. For a call to Op (from outside the scope of the
-- full view) with an operand of type Priv_Ext, the formal parameter
-- names and default expression come from that of P.Op (the ancestor
-- type's version), but the body executed will be that of
-- Q.Op (the parent type's version)
--
-- One half of the test mirrors the above template, where an inherited
-- subprogram (Set_Display) is called using the formal parameter
-- name (C) and default parameter expression of the ancestor type's
-- version (type Clock), but the version of the body executed is from
-- the parent type.
--
-- The test also includes an examination of the dynamic evaluation
-- case, where correct body associations are required through dispatching
-- calls. As described for the non-dispatching case above, the formal
-- parameter name and default values of the ancestor type's (Phone)
-- version of the inherited subprogram (Answer) are used in the
-- dispatching call, but the body executed is from the parent type.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
--
--!
package C730001_0 is
type Display_Kind is (None, Analog, Digital);
type Illumination_Type is (None, Light, Phosphorescence);
type Capability_Type is (Available, In_Use, Call_Waiting, Conference);
type Indicator_Type is (None, Light, Bell, Buzzer, Click, Modem);
type Clock is abstract tagged record -- ancestor type associated
Display : Display_Kind := None; -- with non-dispatching case.
Illumination : Illumination_Type := None;
end record;
type Phone is tagged record -- ancestor type associated
Status : Capability_Type := Available; -- with dispatching case.
Indicator : Indicator_Type := None;
end record;
-- The Set_Display procedure for type Clock implements a basic, no-frills
-- clock display.
procedure Set_Display (C : in out Clock;
Disp: in Display_Kind := Digital);
-- The Answer procedure for type Phone implements a phone status change
-- operation.
procedure Answer (The_Phone : in out Phone;
Ind : in Indicator_Type := Light);
-- ...Other general clock and/or phone operations (not specified in this
-- test scenario).
end C730001_0;
--==================================================================--
package body C730001_0 is
procedure Set_Display (C : in out Clock;
Disp: in Display_Kind := Digital) is
begin
C.Display := Disp;
C.Illumination := Light;
end Set_Display;
procedure Answer (The_Phone : in out Phone;
Ind : in Indicator_Type := Light) is
begin
The_Phone.Status := In_Use;
The_Phone.Indicator := Ind;
end Answer;
end C730001_0;
--==================================================================--
with C730001_0; use C730001_0;
package C730001_1 is
type Power_Supply_Type is (Spring, Battery, AC_Current);
type Speaker_Type is (None, Present, Adjustable, Stereo);
type Wall_Clock is new Clock with record
Power_Source : Power_Supply_Type := Spring;
end record;
type Office_Phone is new Phone with record
Speaker : Speaker_Type := Present;
end record;
-- Note: Both procedures below, parameter names and defaults differ from
-- parent's version.
-- The Set_Display procedure for type Wall_Clock improves upon the
-- basic Set_Display procedure of type Clock.
procedure Set_Display (WC: in out Wall_Clock;
D : in Display_Kind := Analog);
procedure Answer (OP : in out Office_Phone;
OI : in Indicator_Type := Buzzer);
-- ...Other wall clock and/or Office_Phone operations (not specified in
-- this test scenario).
end C730001_1;
--==================================================================--
package body C730001_1 is
-- Note: This body is the one that should be executed in the test block
-- below, not the version of the body corresponding to type Clock.
procedure Set_Display (WC: in out Wall_Clock;
D : in Display_Kind := Analog) is
begin
WC.Display := D;
WC.Illumination := Phosphorescence;
end Set_Display;
procedure Answer (OP : in out Office_Phone;
OI : in Indicator_Type := Buzzer) is
begin
OP.Status := Call_Waiting;
OP.Indicator := OI;
end Answer;
end C730001_1;
--==================================================================--
with C730001_0; use C730001_0;
with C730001_1; use C730001_1;
package C730001_2 is
type Alarm_Type is (Buzzer, Radio, Both);
type Video_Type is (None, TV_Monitor, Wall_Projection);
type Alarm_Clock is new Clock with private;
-- Inherits proc Set_Display (C : in out Clock;
-- Disp: in Display_Kind := Digital); -- (A)
--
-- Would also inherit other general clock operations (if present).
type Conference_Room_Phone is new Office_Phone with record
Display : Video_Type := TV_Monitor;
end record;
procedure Answer (CP : in out Conference_Room_Phone;
CI : in Indicator_Type := Modem);
function TC_Get_Display (C: Alarm_Clock) return Display_Kind;
function TC_Get_Display_Illumination (C: Alarm_Clock)
return Illumination_Type;
private
-- ...however, certain of the wall clock's operations (Set_Display, in
-- this example) improve on the implementations provided for the general
-- clock. We want to call the improved implementations, so we
-- derive from Wall_Clock in the private part.
type Alarm_Clock is new Wall_Clock with record
Alarm : Alarm_Type := Buzzer;
end record;
-- Inherits proc Set_Display (WC: in out Wall_Clock;
-- D : in Display_Kind := Analog); -- (B)
-- The implicit Set_Display at (B) overrides the implicit Set_Display at
-- (A), but only within the scope of the full view.
--
-- Outside the scope of the full view, only (A) is visible, so calls
-- from outside the scope will get the formal parameter names and default
-- from (A). Both inside and outside the scope, however, the body executed
-- will be that corresponding to Set_Display of the parent type.
end C730001_2;
--==================================================================--
package body C730001_2 is
procedure Answer (CP : in out Conference_Room_Phone;
CI : in Indicator_Type := Modem)is
begin
CP.Status := Conference;
CP.Indicator := CI;
end Answer;
function TC_Get_Display (C: Alarm_Clock) return Display_Kind is
begin
return C.Display;
end TC_Get_Display;
function TC_Get_Display_Illumination (C: Alarm_Clock)
return Illumination_Type is
begin
return C.Illumination;
end TC_Get_Display_Illumination;
end C730001_2;
--==================================================================--
with C730001_0; use C730001_0;
with C730001_1; use C730001_1;
with C730001_2; use C730001_2;
package C730001_3 is
-- Types extended from the ancestor (Phone) type in the specification.
type Secure_Phone_Type is new Phone with private;
type Auditorium_Phone_Type is new Phone with private;
-- Inherit versions of Answer from ancestor (Phone).
function TC_Get_Phone_Status (P : Phone'Class) return Capability_Type;
function TC_Get_Indicator (P : Phone'Class) return Indicator_Type;
private
-- Types extended from descendents of Phone_Type in the private part.
type Secure_Phone_Type is new Office_Phone with record
Scrambled_Communication : Boolean := True;
end record;
type Auditorium_Phone_Type is new Conference_Room_Phone with record
Volume_Control : Boolean := True;
end record;
end C730001_3;
--==================================================================--
package body C730001_3 is
function TC_Get_Phone_Status (P : Phone'Class) return Capability_Type is
begin
return P.Status;
end TC_Get_Phone_Status;
function TC_Get_Indicator (P : Phone'Class) return Indicator_Type is
begin
return P.Indicator;
end TC_Get_Indicator;
end C730001_3;
--==================================================================--
with C730001_0; use C730001_0;
with C730001_1; use C730001_1;
with C730001_2; use C730001_2;
with C730001_3; use C730001_3;
with Report;
procedure C730001 is
begin
Report.Test ("C730001","Check that the full view of a private extension " &
"may be derived indirectly from the ancestor " &
"type. Check that, for a primitive subprogram " &
"of the private extension that is inherited from " &
"the ancestor type and not overridden, the " &
"formal parameter names and default expressions " &
"come from the corresponding primitive " &
"subprogram of the ancestor type, while the body " &
"comes from that of the parent type");
Test_Block:
declare
Alarm : Alarm_Clock;
Hot_Line : Secure_Phone_Type;
TeleConference_Phone : Auditorium_Phone_Type;
begin
-- Evaluate non-dispatching case:
-- Call Set_Display using formal parameter name from
-- C730001_0.Set_Display.
-- Give no 2nd parameter so that default expression must be used.
Set_Display (C => Alarm);
-- The value of the Display component should equal Digital, which is
-- the default value from the ancestor's version of Set_Display,
-- and not the default value from the parent's version of Set_Display.
if TC_Get_Display (Alarm) /= Digital then
Report.Failed ("Default expression for ancestor op not used " &
"in non-dispatching case");
end if;
-- However, the value of the Illumination component should equal
-- Phosphorescence, which is assigned in the parent type's version of
-- the body of Set_Display.
if TC_Get_Display_Illumination (Alarm) /= Phosphorescence then
Report.Failed ("Wrong body was executed in non-dispatching case");
end if;
-- Evaluate dispatching case:
declare
Hot_Line : Secure_Phone_Type;
TeleConference_Phone : Auditorium_Phone_Type;
procedure Answer_The_Phone (P : in out Phone'Class) is
begin
-- Give no 2nd parameter so that default expression must be used.
Answer (P);
end Answer_The_Phone;
begin
Answer_The_Phone (Hot_Line);
Answer_The_Phone (TeleConference_Phone);
-- The value of the Indicator field shold equal "Light", the default
-- value from the ancestor's version of Answer, and not the default
-- from either of the parent versions of Answer.
if TC_Get_Indicator(Hot_Line) /= Light or
TC_Get_Indicator(TeleConference_Phone) /= Light
then
Report.Failed("Default expression from ancestor operation " &
"not used in dispatching case");
end if;
-- However, the value of the Status component should equal
-- Call_Waiting or Conference respectively, based on the assignment
-- in the parent type's version of the body of Answer.
if TC_Get_Phone_Status(Hot_Line) /= Call_Waiting then
Report.Failed("Wrong body executed in dispatching case - 1");
end if;
if TC_Get_Phone_Status(TeleConference_Phone) /= Conference then
Report.Failed("Wrong body executed in dispatching case - 2");
end if;
end;
exception
when others => Report.Failed ("Exception raised in Test_Block");
end Test_Block;
Report.Result;
end C730001;
Go to most recent revision | Compare with Previous | Blame | View Log