-- C3A0007.A
|
-- C3A0007.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 call to a subprogram via an access-to-subprogram value
|
-- Check that a call to a subprogram via an access-to-subprogram value
|
-- stored in a data structure will correctly dispatch according to the
|
-- stored in a data structure will correctly dispatch according to the
|
-- tag of the class-wide parameter passed via that call.
|
-- tag of the class-wide parameter passed via that call.
|
--
|
--
|
-- TEST DESCRIPTION:
|
-- TEST DESCRIPTION:
|
-- Declare an access to procedure type in a package specification.
|
-- Declare an access to procedure type in a package specification.
|
-- Declare a root tagged type with the access to procedure type as a
|
-- Declare a root tagged type with the access to procedure type as a
|
-- component. Declare three primitive procedures for the type that
|
-- component. Declare three primitive procedures for the type that
|
-- can be referred to by the access to procedure type. Use the access
|
-- can be referred to by the access to procedure type. Use the access
|
-- to procedure type to initialize the component of a record.
|
-- to procedure type to initialize the component of a record.
|
--
|
--
|
-- Extend the root type with a record extension in another package
|
-- Extend the root type with a record extension in another package
|
-- specification. Declare a new primitive procedure for the extension
|
-- specification. Declare a new primitive procedure for the extension
|
-- (in addition to its three inherited subprograms).
|
-- (in addition to its three inherited subprograms).
|
--
|
--
|
-- In the main program, declare an operation for the root tagged type
|
-- In the main program, declare an operation for the root tagged type
|
-- which can be passed as an access value to change the initial value
|
-- which can be passed as an access value to change the initial value
|
-- of the component. Call the inherited operation indirectly by
|
-- of the component. Call the inherited operation indirectly by
|
-- dereferencing the access value to check on the initial value of the
|
-- dereferencing the access value to check on the initial value of the
|
-- extension. Call inherited operations indirectly by dereferencing
|
-- extension. Call inherited operations indirectly by dereferencing
|
-- the access value to replace the initial value. Call the primitive
|
-- the access value to replace the initial value. Call the primitive
|
-- procedure indirectly by dereferencing the access value to modify the
|
-- procedure indirectly by dereferencing the access value to modify the
|
-- extension.
|
-- extension.
|
--
|
--
|
-- type Button
|
-- type Button
|
-- procedure Push(Button)
|
-- procedure Push(Button)
|
-- procedure Set_Response(Button,Button_Response_Ptr)
|
-- procedure Set_Response(Button,Button_Response_Ptr)
|
-- procedure Default_Response(Button)
|
-- procedure Default_Response(Button)
|
--
|
--
|
-- type Priority_Button (new Button)
|
-- type Priority_Button (new Button)
|
-- procedures Push, Set_Response inherited
|
-- procedures Push, Set_Response inherited
|
-- procedure Default_Response
|
-- procedure Default_Response
|
-- procedure Set_Priority
|
-- procedure Set_Priority
|
--
|
--
|
--
|
--
|
-- CHANGE HISTORY:
|
-- CHANGE HISTORY:
|
-- 06 Dec 94 SAIC ACVC 2.0
|
-- 06 Dec 94 SAIC ACVC 2.0
|
--
|
--
|
--!
|
--!
|
|
|
package C3A0007_0 is
|
package C3A0007_0 is
|
|
|
Default_Call : Boolean := False;
|
Default_Call : Boolean := False;
|
|
|
type Button is tagged private;
|
type Button is tagged private;
|
|
|
type Button_Response_Ptr is access procedure
|
type Button_Response_Ptr is access procedure
|
(B : in out Button'Class);
|
(B : in out Button'Class);
|
|
|
procedure Push (B : in out Button); -- to be inherited
|
procedure Push (B : in out Button); -- to be inherited
|
|
|
procedure Set_Response (B : in out Button; -- to be inherited
|
procedure Set_Response (B : in out Button; -- to be inherited
|
R : in Button_Response_Ptr);
|
R : in Button_Response_Ptr);
|
|
|
procedure Response (B : in out Button); -- to be inherited
|
procedure Response (B : in out Button); -- to be inherited
|
|
|
private
|
private
|
procedure Default_Response(B: in out Button'Class);
|
procedure Default_Response(B: in out Button'Class);
|
type Button is tagged -- root tagged type
|
type Button is tagged -- root tagged type
|
record
|
record
|
Action : Button_Response_Ptr
|
Action : Button_Response_Ptr
|
:= Default_Response'Access;
|
:= Default_Response'Access;
|
end record;
|
end record;
|
end C3A0007_0;
|
end C3A0007_0;
|
|
|
with C3A0007_0;
|
with C3A0007_0;
|
package C3A0007_1 is
|
package C3A0007_1 is
|
|
|
type Priority_Button is new C3A0007_0.Button
|
type Priority_Button is new C3A0007_0.Button
|
with record
|
with record
|
Priority : Integer := 0;
|
Priority : Integer := 0;
|
end record;
|
end record;
|
|
|
-- Inherits procedure Push from Button
|
-- Inherits procedure Push from Button
|
-- Inherits procedure Set_Response from Button
|
-- Inherits procedure Set_Response from Button
|
|
|
-- Override procedure Response from Button
|
-- Override procedure Response from Button
|
procedure Response (B : in out Priority_Button);
|
procedure Response (B : in out Priority_Button);
|
|
|
-- Primitive operation of the extension
|
-- Primitive operation of the extension
|
procedure Set_Priority (B : in out Priority_Button);
|
procedure Set_Priority (B : in out Priority_Button);
|
|
|
end C3A0007_1;
|
end C3A0007_1;
|
|
|
with C3A0007_0;
|
with C3A0007_0;
|
package C3A0007_2 is
|
package C3A0007_2 is
|
|
|
Emergency_Call : Boolean := False;
|
Emergency_Call : Boolean := False;
|
|
|
procedure Emergency (B : in out C3A0007_0.Button'Class);
|
procedure Emergency (B : in out C3A0007_0.Button'Class);
|
end C3A0007_2;
|
end C3A0007_2;
|
|
|
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
|
|
with TCTouch;
|
with TCTouch;
|
package body C3A0007_0 is
|
package body C3A0007_0 is
|
|
|
procedure Push (B : in out Button) is
|
procedure Push (B : in out Button) is
|
begin
|
begin
|
TCTouch.Touch( 'P' ); --------------------------------------------- P
|
TCTouch.Touch( 'P' ); --------------------------------------------- P
|
-- Invoking subprogram designated by access value
|
-- Invoking subprogram designated by access value
|
B.Action (B);
|
B.Action (B);
|
end Push;
|
end Push;
|
|
|
|
|
procedure Set_Response (B : in out Button;
|
procedure Set_Response (B : in out Button;
|
R : in Button_Response_Ptr) is
|
R : in Button_Response_Ptr) is
|
begin
|
begin
|
TCTouch.Touch( 'S' ); --------------------------------------------- S
|
TCTouch.Touch( 'S' ); --------------------------------------------- S
|
-- Set procedure value in record
|
-- Set procedure value in record
|
B.Action := R;
|
B.Action := R;
|
end Set_Response;
|
end Set_Response;
|
|
|
|
|
procedure Response (B : in out Button) is
|
procedure Response (B : in out Button) is
|
begin
|
begin
|
TCTouch.Touch( 'D' ); --------------------------------------------- D
|
TCTouch.Touch( 'D' ); --------------------------------------------- D
|
Default_Call := True;
|
Default_Call := True;
|
end Response;
|
end Response;
|
|
|
procedure Default_Response (B : in out Button'Class) is
|
procedure Default_Response (B : in out Button'Class) is
|
begin
|
begin
|
TCTouch.Touch( 'C' ); --------------------------------------------- C
|
TCTouch.Touch( 'C' ); --------------------------------------------- C
|
Response(B);
|
Response(B);
|
end Default_Response;
|
end Default_Response;
|
|
|
end C3A0007_0;
|
end C3A0007_0;
|
|
|
with TCTouch;
|
with TCTouch;
|
package body C3A0007_1 is
|
package body C3A0007_1 is
|
|
|
procedure Set_Priority (B : in out Priority_Button) is
|
procedure Set_Priority (B : in out Priority_Button) is
|
begin
|
begin
|
TCTouch.Touch( 's' ); --------------------------------------------- s
|
TCTouch.Touch( 's' ); --------------------------------------------- s
|
B.Priority := 1;
|
B.Priority := 1;
|
end Set_Priority;
|
end Set_Priority;
|
|
|
procedure Response (B : in out Priority_Button) is
|
procedure Response (B : in out Priority_Button) is
|
begin
|
begin
|
TCTouch.Touch( 'd' ); --------------------------------------------- d
|
TCTouch.Touch( 'd' ); --------------------------------------------- d
|
end Response;
|
end Response;
|
|
|
end C3A0007_1;
|
end C3A0007_1;
|
|
|
with TCTouch;
|
with TCTouch;
|
package body C3A0007_2 is
|
package body C3A0007_2 is
|
procedure Emergency (B : in out C3A0007_0.Button'Class) is
|
procedure Emergency (B : in out C3A0007_0.Button'Class) is
|
begin
|
begin
|
TCTouch.Touch( 'E' ); ------------------------------------------- E
|
TCTouch.Touch( 'E' ); ------------------------------------------- E
|
Emergency_Call := True;
|
Emergency_Call := True;
|
end Emergency;
|
end Emergency;
|
end C3A0007_2;
|
end C3A0007_2;
|
|
|
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
|
|
with Report;
|
with Report;
|
with TCTouch;
|
with TCTouch;
|
|
|
with C3A0007_0;
|
with C3A0007_0;
|
with C3A0007_1;
|
with C3A0007_1;
|
with C3A0007_2;
|
with C3A0007_2;
|
procedure C3A0007 is
|
procedure C3A0007 is
|
|
|
Pink_Button : C3A0007_0.Button;
|
Pink_Button : C3A0007_0.Button;
|
Green_Button : C3A0007_1.Priority_Button;
|
Green_Button : C3A0007_1.Priority_Button;
|
|
|
begin
|
begin
|
|
|
Report.Test ("C3A0007", "Check that a call to a subprogram via an "
|
Report.Test ("C3A0007", "Check that a call to a subprogram via an "
|
& "access-to-subprogram value stored in a data "
|
& "access-to-subprogram value stored in a data "
|
& "structure will correctly dispatch according to "
|
& "structure will correctly dispatch according to "
|
& "the tag of the class-wide parameter passed "
|
& "the tag of the class-wide parameter passed "
|
& "via that call" );
|
& "via that call" );
|
|
|
-- Call inherited operation Push to set Default_Response value
|
-- Call inherited operation Push to set Default_Response value
|
-- in the extension.
|
-- in the extension.
|
|
|
C3A0007_1.Push (Green_Button);
|
C3A0007_1.Push (Green_Button);
|
TCTouch.Validate("PCd", "First Green Button Push");
|
TCTouch.Validate("PCd", "First Green Button Push");
|
|
|
TCTouch.Assert_Not(C3A0007_0.Default_Call,
|
TCTouch.Assert_Not(C3A0007_0.Default_Call,
|
"Incorrect Green Default_Response");
|
"Incorrect Green Default_Response");
|
|
|
C3A0007_0.Push (Pink_Button);
|
C3A0007_0.Push (Pink_Button);
|
TCTouch.Validate("PCD", "First Pink Button Push");
|
TCTouch.Validate("PCD", "First Pink Button Push");
|
|
|
-- Call inherited operations Set_Response and Push to set
|
-- Call inherited operations Set_Response and Push to set
|
-- Emergency value in the extension.
|
-- Emergency value in the extension.
|
C3A0007_1.Set_Response (Green_Button, C3A0007_2.Emergency'Access);
|
C3A0007_1.Set_Response (Green_Button, C3A0007_2.Emergency'Access);
|
C3A0007_1.Push (Green_Button);
|
C3A0007_1.Push (Green_Button);
|
TCTouch.Validate("SPE", "Second Green Button Push");
|
TCTouch.Validate("SPE", "Second Green Button Push");
|
|
|
TCTouch.Assert(C3A0007_2.Emergency_Call, "Incorrect Green Emergency");
|
TCTouch.Assert(C3A0007_2.Emergency_Call, "Incorrect Green Emergency");
|
|
|
C3A0007_0.Set_Response (Pink_Button, C3A0007_2.Emergency'Access);
|
C3A0007_0.Set_Response (Pink_Button, C3A0007_2.Emergency'Access);
|
C3A0007_0.Push (Pink_Button);
|
C3A0007_0.Push (Pink_Button);
|
TCTouch.Validate("SPE", "Second Pink Button Push");
|
TCTouch.Validate("SPE", "Second Pink Button Push");
|
|
|
-- Call primitive operation to set priority value
|
-- Call primitive operation to set priority value
|
-- in the extension.
|
-- in the extension.
|
C3A0007_1.Set_Priority (Green_Button);
|
C3A0007_1.Set_Priority (Green_Button);
|
TCTouch.Validate("s", "Green Button Priority");
|
TCTouch.Validate("s", "Green Button Priority");
|
|
|
TCTouch.Assert(Green_Button.Priority = 1, "Incorrect Set_Priority");
|
TCTouch.Assert(Green_Button.Priority = 1, "Incorrect Set_Priority");
|
|
|
Report.Result;
|
Report.Result;
|
|
|
end C3A0007;
|
end C3A0007;
|
|
|
