|
111
|
1 -- C3A0007.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 a call to a subprogram via an access-to-subprogram value
|
|
|
28 -- stored in a data structure will correctly dispatch according to the
|
|
|
29 -- tag of the class-wide parameter passed via that call.
|
|
|
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 record extension in another package
|
|
|
39 -- specification. Declare a new primitive procedure 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 operation indirectly by
|
|
|
45 -- dereferencing the access value to check on the initial value of the
|
|
|
46 -- extension. Call inherited operations indirectly by dereferencing
|
|
|
47 -- the access value to replace the initial value. Call the primitive
|
|
|
48 -- procedure indirectly by dereferencing the access value to modify the
|
|
|
49 -- extension.
|
|
|
50 --
|
|
|
51 -- type Button
|
|
|
52 -- procedure Push(Button)
|
|
|
53 -- procedure Set_Response(Button,Button_Response_Ptr)
|
|
|
54 -- procedure Default_Response(Button)
|
|
|
55 --
|
|
|
56 -- type Priority_Button (new Button)
|
|
|
57 -- procedures Push, Set_Response inherited
|
|
|
58 -- procedure Default_Response
|
|
|
59 -- procedure Set_Priority
|
|
|
60 --
|
|
|
61 --
|
|
|
62 -- CHANGE HISTORY:
|
|
|
63 -- 06 Dec 94 SAIC ACVC 2.0
|
|
|
64 --
|
|
|
65 --!
|
|
|
66
|
|
|
67 package C3A0007_0 is
|
|
|
68
|
|
|
69 Default_Call : Boolean := False;
|
|
|
70
|
|
|
71 type Button is tagged private;
|
|
|
72
|
|
|
73 type Button_Response_Ptr is access procedure
|
|
|
74 (B : in out Button'Class);
|
|
|
75
|
|
|
76 procedure Push (B : in out Button); -- to be inherited
|
|
|
77
|
|
|
78 procedure Set_Response (B : in out Button; -- to be inherited
|
|
|
79 R : in Button_Response_Ptr);
|
|
|
80
|
|
|
81 procedure Response (B : in out Button); -- to be inherited
|
|
|
82
|
|
|
83 private
|
|
|
84 procedure Default_Response(B: in out Button'Class);
|
|
|
85 type Button is tagged -- root tagged type
|
|
|
86 record
|
|
|
87 Action : Button_Response_Ptr
|
|
|
88 := Default_Response'Access;
|
|
|
89 end record;
|
|
|
90 end C3A0007_0;
|
|
|
91
|
|
|
92 with C3A0007_0;
|
|
|
93 package C3A0007_1 is
|
|
|
94
|
|
|
95 type Priority_Button is new C3A0007_0.Button
|
|
|
96 with record
|
|
|
97 Priority : Integer := 0;
|
|
|
98 end record;
|
|
|
99
|
|
|
100 -- Inherits procedure Push from Button
|
|
|
101 -- Inherits procedure Set_Response from Button
|
|
|
102
|
|
|
103 -- Override procedure Response from Button
|
|
|
104 procedure Response (B : in out Priority_Button);
|
|
|
105
|
|
|
106 -- Primitive operation of the extension
|
|
|
107 procedure Set_Priority (B : in out Priority_Button);
|
|
|
108
|
|
|
109 end C3A0007_1;
|
|
|
110
|
|
|
111 with C3A0007_0;
|
|
|
112 package C3A0007_2 is
|
|
|
113
|
|
|
114 Emergency_Call : Boolean := False;
|
|
|
115
|
|
|
116 procedure Emergency (B : in out C3A0007_0.Button'Class);
|
|
|
117 end C3A0007_2;
|
|
|
118
|
|
|
119 -----------------------------------------------------------------------------
|
|
|
120
|
|
|
121 with TCTouch;
|
|
|
122 package body C3A0007_0 is
|
|
|
123
|
|
|
124 procedure Push (B : in out Button) is
|
|
|
125 begin
|
|
|
126 TCTouch.Touch( 'P' ); --------------------------------------------- P
|
|
|
127 -- Invoking subprogram designated by access value
|
|
|
128 B.Action (B);
|
|
|
129 end Push;
|
|
|
130
|
|
|
131
|
|
|
132 procedure Set_Response (B : in out Button;
|
|
|
133 R : in Button_Response_Ptr) is
|
|
|
134 begin
|
|
|
135 TCTouch.Touch( 'S' ); --------------------------------------------- S
|
|
|
136 -- Set procedure value in record
|
|
|
137 B.Action := R;
|
|
|
138 end Set_Response;
|
|
|
139
|
|
|
140
|
|
|
141 procedure Response (B : in out Button) is
|
|
|
142 begin
|
|
|
143 TCTouch.Touch( 'D' ); --------------------------------------------- D
|
|
|
144 Default_Call := True;
|
|
|
145 end Response;
|
|
|
146
|
|
|
147 procedure Default_Response (B : in out Button'Class) is
|
|
|
148 begin
|
|
|
149 TCTouch.Touch( 'C' ); --------------------------------------------- C
|
|
|
150 Response(B);
|
|
|
151 end Default_Response;
|
|
|
152
|
|
|
153 end C3A0007_0;
|
|
|
154
|
|
|
155 with TCTouch;
|
|
|
156 package body C3A0007_1 is
|
|
|
157
|
|
|
158 procedure Set_Priority (B : in out Priority_Button) is
|
|
|
159 begin
|
|
|
160 TCTouch.Touch( 's' ); --------------------------------------------- s
|
|
|
161 B.Priority := 1;
|
|
|
162 end Set_Priority;
|
|
|
163
|
|
|
164 procedure Response (B : in out Priority_Button) is
|
|
|
165 begin
|
|
|
166 TCTouch.Touch( 'd' ); --------------------------------------------- d
|
|
|
167 end Response;
|
|
|
168
|
|
|
169 end C3A0007_1;
|
|
|
170
|
|
|
171 with TCTouch;
|
|
|
172 package body C3A0007_2 is
|
|
|
173 procedure Emergency (B : in out C3A0007_0.Button'Class) is
|
|
|
174 begin
|
|
|
175 TCTouch.Touch( 'E' ); ------------------------------------------- E
|
|
|
176 Emergency_Call := True;
|
|
|
177 end Emergency;
|
|
|
178 end C3A0007_2;
|
|
|
179
|
|
|
180 -----------------------------------------------------------------------------
|
|
|
181
|
|
|
182 with Report;
|
|
|
183 with TCTouch;
|
|
|
184
|
|
|
185 with C3A0007_0;
|
|
|
186 with C3A0007_1;
|
|
|
187 with C3A0007_2;
|
|
|
188 procedure C3A0007 is
|
|
|
189
|
|
|
190 Pink_Button : C3A0007_0.Button;
|
|
|
191 Green_Button : C3A0007_1.Priority_Button;
|
|
|
192
|
|
|
193 begin
|
|
|
194
|
|
|
195 Report.Test ("C3A0007", "Check that a call to a subprogram via an "
|
|
|
196 & "access-to-subprogram value stored in a data "
|
|
|
197 & "structure will correctly dispatch according to "
|
|
|
198 & "the tag of the class-wide parameter passed "
|
|
|
199 & "via that call" );
|
|
|
200
|
|
|
201 -- Call inherited operation Push to set Default_Response value
|
|
|
202 -- in the extension.
|
|
|
203
|
|
|
204 C3A0007_1.Push (Green_Button);
|
|
|
205 TCTouch.Validate("PCd", "First Green Button Push");
|
|
|
206
|
|
|
207 TCTouch.Assert_Not(C3A0007_0.Default_Call,
|
|
|
208 "Incorrect Green Default_Response");
|
|
|
209
|
|
|
210 C3A0007_0.Push (Pink_Button);
|
|
|
211 TCTouch.Validate("PCD", "First Pink Button Push");
|
|
|
212
|
|
|
213 -- Call inherited operations Set_Response and Push to set
|
|
|
214 -- Emergency value in the extension.
|
|
|
215 C3A0007_1.Set_Response (Green_Button, C3A0007_2.Emergency'Access);
|
|
|
216 C3A0007_1.Push (Green_Button);
|
|
|
217 TCTouch.Validate("SPE", "Second Green Button Push");
|
|
|
218
|
|
|
219 TCTouch.Assert(C3A0007_2.Emergency_Call, "Incorrect Green Emergency");
|
|
|
220
|
|
|
221 C3A0007_0.Set_Response (Pink_Button, C3A0007_2.Emergency'Access);
|
|
|
222 C3A0007_0.Push (Pink_Button);
|
|
|
223 TCTouch.Validate("SPE", "Second Pink Button Push");
|
|
|
224
|
|
|
225 -- Call primitive operation to set priority value
|
|
|
226 -- in the extension.
|
|
|
227 C3A0007_1.Set_Priority (Green_Button);
|
|
|
228 TCTouch.Validate("s", "Green Button Priority");
|
|
|
229
|
|
|
230 TCTouch.Assert(Green_Button.Priority = 1, "Incorrect Set_Priority");
|
|
|
231
|
|
|
232 Report.Result;
|
|
|
233
|
|
|
234 end C3A0007;
|
