|
111
|
1 -- C3A0009.A
|
|
|
2 --
|
|
|
3 -- Grant of Unlimited Rights
|
|
|
4 --
|
|
|
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
|
|
|
14 -- to do so.
|
|
|
15 --
|
|
|
16 -- DISCLAIMER
|
|
|
17 --
|
|
|
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.
|
|
|
24 --*
|
|
|
25 --
|
|
|
26 -- OBJECTIVE:
|
|
|
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.
|
|
|
30 --
|
|
|
31 -- TEST DESCRIPTION:
|
|
|
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.
|
|
|
37 --
|
|
|
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).
|
|
|
41 --
|
|
|
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.
|
|
|
48 --
|
|
|
49 --
|
|
|
50 -- CHANGE HISTORY:
|
|
|
51 -- 06 Dec 94 SAIC ACVC 2.0
|
|
|
52 --
|
|
|
53 --!
|
|
|
54
|
|
|
55 package C3A0009_0 is -- Push_Buttons
|
|
|
56
|
|
|
57 type Button is tagged private;
|
|
|
58
|
|
|
59 -- Type accesses to procedures Push and Default_Response
|
|
|
60 type Button_Response_Ptr is access procedure
|
|
|
61 (B : in out Button);
|
|
|
62
|
|
|
63 procedure Push (B : in out Button); -- to be inherited
|
|
|
64
|
|
|
65 procedure Set_Response (B : in out Button; -- to be inherited
|
|
|
66 R : in Button_Response_Ptr);
|
|
|
67
|
|
|
68 procedure Default_Response (B : in out Button); -- to be inherited
|
|
|
69
|
|
|
70 type Alert_Button is new Button with private; -- private extension of
|
|
|
71 -- root tagged type
|
|
|
72 -- Inherits procedure Push from Button
|
|
|
73 -- Inherits procedure Set_Response from Button
|
|
|
74 -- Inherits procedure Default_Response from Button
|
|
|
75
|
|
|
76 procedure Replace_Action( B: in out Alert_Button );
|
|
|
77
|
|
|
78 -- type accesses to procedure Default_Action
|
|
|
79 type Button_Action_Ptr is access procedure;
|
|
|
80
|
|
|
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;
|
|
|
84
|
|
|
85 private
|
|
|
86
|
|
|
87 type Button is tagged -- root tagged type
|
|
|
88 record
|
|
|
89 Response : Button_Response_Ptr
|
|
|
90 := Default_Response'Access;
|
|
|
91 end record;
|
|
|
92
|
|
|
93 procedure Default_Action;
|
|
|
94
|
|
|
95 type Alert_Button is new Button with record
|
|
|
96 Action : Button_Action_Ptr
|
|
|
97 := Default_Action'Access;
|
|
|
98 end record;
|
|
|
99
|
|
|
100 end C3A0009_0;
|
|
|
101
|
|
|
102
|
|
|
103 -----------------------------------------------------------------------------
|
|
|
104
|
|
|
105
|
|
|
106 with TCTouch;
|
|
|
107 package body C3A0009_0 is
|
|
|
108
|
|
|
109 procedure Push (B : in out Button) is
|
|
|
110 begin
|
|
|
111 TCTouch.Touch( 'P' ); --------------------------------------------- P
|
|
|
112 -- Invoking subprogram designated by access value
|
|
|
113 B.Response (B);
|
|
|
114 end Push;
|
|
|
115
|
|
|
116
|
|
|
117 procedure Set_Response (B : in out Button;
|
|
|
118 R : in Button_Response_Ptr) is
|
|
|
119 begin
|
|
|
120 TCTouch.Touch( 'S' ); --------------------------------------------- S
|
|
|
121 -- Set procedure value in record
|
|
|
122 B.Response := R;
|
|
|
123 end Set_Response;
|
|
|
124
|
|
|
125
|
|
|
126 procedure Default_Response (B : in out Button) is
|
|
|
127 begin
|
|
|
128 TCTouch.Touch( 'D' ); --------------------------------------------- D
|
|
|
129 end Default_Response;
|
|
|
130
|
|
|
131
|
|
|
132 procedure Default_Action is
|
|
|
133 begin
|
|
|
134 TCTouch.Touch( 'd' ); --------------------------------------------- d
|
|
|
135 end Default_Action;
|
|
|
136
|
|
|
137 procedure Replacement_Action is
|
|
|
138 begin
|
|
|
139 TCTouch.Touch( 'r' ); --------------------------------------------- r
|
|
|
140 end Replacement_Action;
|
|
|
141
|
|
|
142 procedure Replace_Action( B: in out Alert_Button ) is
|
|
|
143 begin
|
|
|
144 TCTouch.Touch( 'R' ); --------------------------------------------- R
|
|
|
145 B.Action := Replacement_Action'Access;
|
|
|
146 end Replace_Action;
|
|
|
147
|
|
|
148 function Alert (B : in Alert_Button) return Button_Action_Ptr is
|
|
|
149 begin
|
|
|
150 TCTouch.Touch( 'A' ); --------------------------------------------- A
|
|
|
151 return (B.Action);
|
|
|
152 end Alert;
|
|
|
153
|
|
|
154 end C3A0009_0;
|
|
|
155
|
|
|
156 -----------------------------------------------------------------------------
|
|
|
157
|
|
|
158 with C3A0009_0;
|
|
|
159 package C3A0009_1 is -- Emergency_Items
|
|
|
160 package Push_Buttons renames C3A0009_0;
|
|
|
161
|
|
|
162 procedure Emergency (B : in out Push_Buttons.Button);
|
|
|
163 end C3A0009_1;
|
|
|
164
|
|
|
165 with TCTouch;
|
|
|
166 package body C3A0009_1 is -- Emergency_Items
|
|
|
167 procedure Emergency (B : in out Push_Buttons.Button) is
|
|
|
168 begin
|
|
|
169 TCTouch.Touch( 'E' ); ------------------------------------------- E
|
|
|
170 end Emergency;
|
|
|
171 end C3A0009_1;
|
|
|
172 -----------------------------------------------------------------------------
|
|
|
173
|
|
|
174 with Report;
|
|
|
175
|
|
|
176 with C3A0009_0, C3A0009_1;
|
|
|
177 with TCTouch;
|
|
|
178 procedure C3A0009 is
|
|
|
179
|
|
|
180 package Push_Buttons renames C3A0009_0;
|
|
|
181 package Emergency_Items renames C3A0009_1;
|
|
|
182
|
|
|
183 Black_Button : Push_Buttons.Alert_Button;
|
|
|
184 Alert_Ptr : Push_Buttons.Button_Action_Ptr;
|
|
|
185
|
|
|
186 begin
|
|
|
187
|
|
|
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");
|
|
|
192
|
|
|
193
|
|
|
194 Push_Buttons.Push( Black_Button );
|
|
|
195 Push_Buttons.Alert( Black_Button ).all;
|
|
|
196
|
|
|
197 TCTouch.Validate( "PDAd", "Default operation set" );
|
|
|
198
|
|
|
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);
|
|
|
202
|
|
|
203
|
|
|
204 Push_Buttons.Push( Black_Button );
|
|
|
205 Push_Buttons.Alert( Black_Button ).all;
|
|
|
206
|
|
|
207 TCTouch.Validate( "SPEAd", "Altered Response set" );
|
|
|
208
|
|
|
209 -- Call primitive operation to set action value in the extension.
|
|
|
210 Push_Buttons.Replace_Action( Black_Button );
|
|
|
211
|
|
|
212
|
|
|
213 Push_Buttons.Push( Black_Button );
|
|
|
214 Push_Buttons.Alert( Black_Button ).all;
|
|
|
215
|
|
|
216 TCTouch.Validate( "RPEAr", "Altered Action set" );
|
|
|
217
|
|
|
218 Report.Result;
|
|
|
219 end C3A0009;
|
