3 -- Grant of Unlimited Rights
5 -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
6 -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
7 -- unlimited rights in the software and documentation contained herein.
8 -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
9 -- this public release, the Government intends to confer upon all
10 -- recipients unlimited rights equal to those held by the Government.
11 -- These rights include rights to use, duplicate, release or disclose the
12 -- released technical data and computer software in whole or in part, in
13 -- any manner and for any purpose whatsoever, and to have or permit others
18 -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
19 -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
20 -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
21 -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
22 -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
23 -- PARTICULAR PURPOSE OF SAID MATERIAL.
27 -- Check that subprogram references may be passed as parameters using
28 -- access-to-subprogram types. Check that the passed subprograms may
29 -- be invoked from within the called subprogram.
32 -- Declare an access to procedure type in a package specification.
33 -- Declare a root tagged type with the access to procedure type as a
34 -- component. Declare three primitive procedures for the type that
35 -- can be referred to by the access to procedure type. Use the access
36 -- to procedure type to initialize the component of a record.
38 -- Extend the root type with a private extension in the same package
39 -- specification. Declare two new primitive subprograms for the extension
40 -- (in addition to its three inherited subprograms).
42 -- In the main program, declare an operation for the root tagged type
43 -- which can be passed as an access value to change the initial value
44 -- of the component. Call the inherited operations indirectly by
45 -- de-referencing the access value to set value in the extension.
46 -- Call the primitive function to modify the extension by passing
47 -- the access value designating the primitive procedure as a parameter.
51 -- 06 Dec 94 SAIC ACVC 2.0
55 package C3A0009_0
is -- Push_Buttons
57 type Button
is tagged private;
59 -- Type accesses to procedures Push and Default_Response
60 type Button_Response_Ptr
is access procedure
63 procedure Push
(B
: in out Button
); -- to be inherited
65 procedure Set_Response
(B
: in out Button
; -- to be inherited
66 R
: in Button_Response_Ptr
);
68 procedure Default_Response
(B
: in out Button
); -- to be inherited
70 type Alert_Button
is new Button
with private; -- private extension of
72 -- Inherits procedure Push from Button
73 -- Inherits procedure Set_Response from Button
74 -- Inherits procedure Default_Response from Button
76 procedure Replace_Action
( B
: in out Alert_Button
);
78 -- type accesses to procedure Default_Action
79 type Button_Action_Ptr
is access procedure;
81 -- The following function is needed to set value in the
82 -- extension's private component.
83 function Alert
(B
: in Alert_Button
) return Button_Action_Ptr
;
87 type Button
is tagged -- root tagged type
89 Response
: Button_Response_Ptr
90 := Default_Response
'Access;
93 procedure Default_Action
;
95 type Alert_Button
is new Button
with record
96 Action
: Button_Action_Ptr
97 := Default_Action
'Access;
103 -----------------------------------------------------------------------------
107 package body C3A0009_0
is
109 procedure Push
(B
: in out Button
) is
111 TCTouch
.Touch
( 'P' ); --------------------------------------------- P
112 -- Invoking subprogram designated by access value
117 procedure Set_Response
(B
: in out Button
;
118 R
: in Button_Response_Ptr
) is
120 TCTouch
.Touch
( 'S' ); --------------------------------------------- S
121 -- Set procedure value in record
126 procedure Default_Response
(B
: in out Button
) is
128 TCTouch
.Touch
( 'D' ); --------------------------------------------- D
129 end Default_Response
;
132 procedure Default_Action
is
134 TCTouch
.Touch
( 'd' ); --------------------------------------------- d
137 procedure Replacement_Action
is
139 TCTouch
.Touch
( 'r' ); --------------------------------------------- r
140 end Replacement_Action
;
142 procedure Replace_Action
( B
: in out Alert_Button
) is
144 TCTouch
.Touch
( 'R' ); --------------------------------------------- R
145 B
.Action
:= Replacement_Action
'Access;
148 function Alert
(B
: in Alert_Button
) return Button_Action_Ptr
is
150 TCTouch
.Touch
( 'A' ); --------------------------------------------- A
156 -----------------------------------------------------------------------------
159 package C3A0009_1
is -- Emergency_Items
160 package Push_Buttons
renames C3A0009_0
;
162 procedure Emergency
(B
: in out Push_Buttons
.Button
);
166 package body C3A0009_1
is -- Emergency_Items
167 procedure Emergency
(B
: in out Push_Buttons
.Button
) is
169 TCTouch
.Touch
( 'E' ); ------------------------------------------- E
172 -----------------------------------------------------------------------------
176 with C3A0009_0
, C3A0009_1
;
180 package Push_Buttons
renames C3A0009_0
;
181 package Emergency_Items
renames C3A0009_1
;
183 Black_Button
: Push_Buttons
.Alert_Button
;
184 Alert_Ptr
: Push_Buttons
.Button_Action_Ptr
;
188 Report
.Test
("C3A0009", "Check that subprogram references may be passed "
189 & "as parameters using access-to-subprogram types. "
190 & "Check that the passed subprograms may be "
191 & "invoked from within the called subprogram");
194 Push_Buttons
.Push
( Black_Button
);
195 Push_Buttons
.Alert
( Black_Button
).all;
197 TCTouch
.Validate
( "PDAd", "Default operation set" );
199 -- Call inherited operations Set_Response and Push to set
200 -- Emergency value in the extension.
201 Push_Buttons
.Set_Response
(Black_Button
, Emergency_Items
.Emergency
'Access);
204 Push_Buttons
.Push
( Black_Button
);
205 Push_Buttons
.Alert
( Black_Button
).all;
207 TCTouch
.Validate
( "SPEAd", "Altered Response set" );
209 -- Call primitive operation to set action value in the extension.
210 Push_Buttons
.Replace_Action
( Black_Button
);
213 Push_Buttons
.Push
( Black_Button
);
214 Push_Buttons
.Alert
( Black_Button
).all;
216 TCTouch
.Validate
( "RPEAr", "Altered Action set" );