-- CC51002.A
|
-- CC51002.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, for formal derived tagged types, the formal parameter
|
-- Check that, for formal derived tagged types, the formal parameter
|
-- names and default expressions for a primitive subprogram in an
|
-- names and default expressions for a primitive subprogram in an
|
-- instance are determined by the primitive subprogram of the ancestor
|
-- instance are determined by the primitive subprogram of the ancestor
|
-- type, but that the primitive subprogram body executed is that of the
|
-- type, but that the primitive subprogram body executed is that of the
|
-- actual type.
|
-- actual type.
|
--
|
--
|
-- TEST DESCRIPTION:
|
-- TEST DESCRIPTION:
|
-- Define a root tagged type in a library-level package and give it a
|
-- Define a root tagged type in a library-level package and give it a
|
-- primitive subprogram. Provide a default expression for a non-tagged
|
-- primitive subprogram. Provide a default expression for a non-tagged
|
-- parameter of the subprogram. Declare a library-level generic subprogram
|
-- parameter of the subprogram. Declare a library-level generic subprogram
|
-- with a formal derived type using the root type as ancestor. Call
|
-- with a formal derived type using the root type as ancestor. Call
|
-- the primitive subprogram of the root type using named association for
|
-- the primitive subprogram of the root type using named association for
|
-- the tagged parameter, and provide no actual for the defaulted
|
-- the tagged parameter, and provide no actual for the defaulted
|
-- parameter. Extend the root type in a second package and override the
|
-- parameter. Extend the root type in a second package and override the
|
-- root type's subprogram with one which has different parameter names
|
-- root type's subprogram with one which has different parameter names
|
-- and no default expression for the non-tagged parameter. Instantiate
|
-- and no default expression for the non-tagged parameter. Instantiate
|
-- the generic subprogram for each of the tagged types in the class and
|
-- the generic subprogram for each of the tagged types in the class and
|
-- call the instances.
|
-- call the instances.
|
--
|
--
|
--
|
--
|
-- CHANGE HISTORY:
|
-- CHANGE HISTORY:
|
-- 06 Dec 94 SAIC ACVC 2.0
|
-- 06 Dec 94 SAIC ACVC 2.0
|
--
|
--
|
--!
|
--!
|
|
|
package CC51002_0 is -- Root message type and operations.
|
package CC51002_0 is -- Root message type and operations.
|
|
|
type Recipients is (None, Root, Sysop, Local, Remote);
|
type Recipients is (None, Root, Sysop, Local, Remote);
|
|
|
type Msg_Type is tagged record -- Root type of
|
type Msg_Type is tagged record -- Root type of
|
Text : String (1 .. 10); -- class.
|
Text : String (1 .. 10); -- class.
|
end record;
|
end record;
|
|
|
function Send (Msg : in Msg_Type; -- Primitive
|
function Send (Msg : in Msg_Type; -- Primitive
|
To : Recipients := Local) return Boolean; -- subprogram.
|
To : Recipients := Local) return Boolean; -- subprogram.
|
|
|
-- ...Other message operations.
|
-- ...Other message operations.
|
|
|
end CC51002_0;
|
end CC51002_0;
|
|
|
|
|
--==================================================================--
|
--==================================================================--
|
|
|
|
|
package body CC51002_0 is
|
package body CC51002_0 is
|
|
|
-- The implementation of Send is purely artificial; the validity of
|
-- The implementation of Send is purely artificial; the validity of
|
-- its implementation in the context of the abstraction is irrelevant to
|
-- its implementation in the context of the abstraction is irrelevant to
|
-- the feature being tested.
|
-- the feature being tested.
|
|
|
function Send (Msg : in Msg_Type;
|
function Send (Msg : in Msg_Type;
|
To : Recipients := Local) return Boolean is
|
To : Recipients := Local) return Boolean is
|
begin
|
begin
|
return (Msg.Text = "Greetings!" and To = Local);
|
return (Msg.Text = "Greetings!" and To = Local);
|
end Send;
|
end Send;
|
|
|
end CC51002_0;
|
end CC51002_0;
|
|
|
|
|
--==================================================================--
|
--==================================================================--
|
|
|
|
|
with CC51002_0; -- Root message type and operations.
|
with CC51002_0; -- Root message type and operations.
|
generic -- Message class function.
|
generic -- Message class function.
|
type Msg_Block is new CC51002_0.Msg_Type with private;
|
type Msg_Block is new CC51002_0.Msg_Type with private;
|
function CC51002_1 (M : in Msg_Block) return Boolean;
|
function CC51002_1 (M : in Msg_Block) return Boolean;
|
|
|
|
|
--==================================================================--
|
--==================================================================--
|
|
|
|
|
function CC51002_1 (M : in Msg_Block) return Boolean is
|
function CC51002_1 (M : in Msg_Block) return Boolean is
|
Okay : Boolean := False;
|
Okay : Boolean := False;
|
begin
|
begin
|
|
|
-- The call to Send below uses the ancestor type's parameter name, which
|
-- The call to Send below uses the ancestor type's parameter name, which
|
-- should be legal even if the actual subprogram called does not have a
|
-- should be legal even if the actual subprogram called does not have a
|
-- parameter of that name. Furthermore, it uses the ancestor type's default
|
-- parameter of that name. Furthermore, it uses the ancestor type's default
|
-- expression for the second parameter, which should be legal even if the
|
-- expression for the second parameter, which should be legal even if the
|
-- the actual subprogram called has no such default expression.
|
-- the actual subprogram called has no such default expression.
|
|
|
Okay := Send (Msg => M);
|
Okay := Send (Msg => M);
|
-- ...Other processing.
|
-- ...Other processing.
|
return Okay;
|
return Okay;
|
|
|
end CC51002_1;
|
end CC51002_1;
|
|
|
|
|
--==================================================================--
|
--==================================================================--
|
|
|
|
|
with CC51002_0; -- Root message type and operations.
|
with CC51002_0; -- Root message type and operations.
|
package CC51002_2 is -- Extended message type and operations.
|
package CC51002_2 is -- Extended message type and operations.
|
|
|
type Sender_Type is (Inside, Outside);
|
type Sender_Type is (Inside, Outside);
|
|
|
type Who_Msg_Type is new CC51002_0.Msg_Type with record -- Derivative of
|
type Who_Msg_Type is new CC51002_0.Msg_Type with record -- Derivative of
|
From : Sender_Type; -- root type of
|
From : Sender_Type; -- root type of
|
end record; -- class.
|
end record; -- class.
|
|
|
|
|
-- Note: this overriding version of Send has different parameter names
|
-- Note: this overriding version of Send has different parameter names
|
-- from the root type's function. It also has no default expression.
|
-- from the root type's function. It also has no default expression.
|
|
|
function Send (M : Who_Msg_Type; -- Overrides
|
function Send (M : Who_Msg_Type; -- Overrides
|
R : CC51002_0.Recipients) return Boolean; -- root type's
|
R : CC51002_0.Recipients) return Boolean; -- root type's
|
-- operation.
|
-- operation.
|
-- ...Other extended message operations.
|
-- ...Other extended message operations.
|
|
|
end CC51002_2;
|
end CC51002_2;
|
|
|
|
|
--==================================================================--
|
--==================================================================--
|
|
|
|
|
package body CC51002_2 is
|
package body CC51002_2 is
|
|
|
-- The implementation of Send is purely artificial; the validity of
|
-- The implementation of Send is purely artificial; the validity of
|
-- its implementation in the context of the abstraction is irrelevant to
|
-- its implementation in the context of the abstraction is irrelevant to
|
-- the feature being tested.
|
-- the feature being tested.
|
|
|
function Send (M : Who_Msg_Type; R : CC51002_0.Recipients) return Boolean is
|
function Send (M : Who_Msg_Type; R : CC51002_0.Recipients) return Boolean is
|
use type CC51002_0.Recipients;
|
use type CC51002_0.Recipients;
|
begin
|
begin
|
return (M.Text = "Willkommen" and
|
return (M.Text = "Willkommen" and
|
M.From = Outside and
|
M.From = Outside and
|
R = CC51002_0.Local);
|
R = CC51002_0.Local);
|
end Send;
|
end Send;
|
|
|
end CC51002_2;
|
end CC51002_2;
|
|
|
|
|
--==================================================================--
|
--==================================================================--
|
|
|
|
|
with CC51002_0; -- Root message type and operations.
|
with CC51002_0; -- Root message type and operations.
|
with CC51002_1; -- Message class function.
|
with CC51002_1; -- Message class function.
|
with CC51002_2; -- Extended message type and operations.
|
with CC51002_2; -- Extended message type and operations.
|
|
|
with Report;
|
with Report;
|
procedure CC51002 is
|
procedure CC51002 is
|
|
|
function Send_Msg is new CC51002_1 (CC51002_0.Msg_Type);
|
function Send_Msg is new CC51002_1 (CC51002_0.Msg_Type);
|
function Send_WMsg is new CC51002_1 (CC51002_2.Who_Msg_Type);
|
function Send_WMsg is new CC51002_1 (CC51002_2.Who_Msg_Type);
|
|
|
Mess : CC51002_0.Msg_Type := (Text => "Greetings!");
|
Mess : CC51002_0.Msg_Type := (Text => "Greetings!");
|
WMess : CC51002_2.Who_Msg_Type := (Text => "Willkommen",
|
WMess : CC51002_2.Who_Msg_Type := (Text => "Willkommen",
|
From => CC51002_2.Outside);
|
From => CC51002_2.Outside);
|
|
|
TC_Okay_MStatus : Boolean := False;
|
TC_Okay_MStatus : Boolean := False;
|
TC_Okay_WMStatus : Boolean := False;
|
TC_Okay_WMStatus : Boolean := False;
|
|
|
begin
|
begin
|
Report.Test ("CC51002", "Check that, for formal derived tagged types, " &
|
Report.Test ("CC51002", "Check that, for formal derived tagged types, " &
|
"the formal parameter names and default expressions for " &
|
"the formal parameter names and default expressions for " &
|
"a primitive subprogram in an instance are determined by " &
|
"a primitive subprogram in an instance are determined by " &
|
"the primitive subprogram of the ancestor type, but that " &
|
"the primitive subprogram of the ancestor type, but that " &
|
"the primitive subprogram body executed is that of the" &
|
"the primitive subprogram body executed is that of the" &
|
"actual type");
|
"actual type");
|
|
|
TC_Okay_MStatus := Send_Msg (Mess);
|
TC_Okay_MStatus := Send_Msg (Mess);
|
if not TC_Okay_MStatus then
|
if not TC_Okay_MStatus then
|
Report.Failed ("Wrong result from call to root type's operation");
|
Report.Failed ("Wrong result from call to root type's operation");
|
end if;
|
end if;
|
|
|
TC_Okay_WMStatus := Send_WMsg (WMess);
|
TC_Okay_WMStatus := Send_WMsg (WMess);
|
if not TC_Okay_WMStatus then
|
if not TC_Okay_WMStatus then
|
Report.Failed ("Wrong result from call to derived type's operation");
|
Report.Failed ("Wrong result from call to derived type's operation");
|
end if;
|
end if;
|
|
|
Report.Result;
|
Report.Result;
|
end CC51002;
|
end CC51002;
|
|
|
