|
111
|
1 -- CC54003.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 general access-to-subprogram type may be passed as an
|
|
|
28 -- actual to a generic formal access-to-subprogram type. Check that
|
|
|
29 -- designated subprograms may be called by dereferencing the access
|
|
|
30 -- values.
|
|
|
31 --
|
|
|
32 -- TEST DESCRIPTION:
|
|
|
33 -- The generic implements a stack of access-to-subprogram objects as an
|
|
|
34 -- array. The profile of the access-to-subprogram formal corresponds to
|
|
|
35 -- a function which accepts a parameter of some type and returns an
|
|
|
36 -- object of the same type.
|
|
|
37 --
|
|
|
38 -- For this test, the functions for which access values will be pushed
|
|
|
39 -- onto the stack accept a parameter of type access-to-string, lengthen
|
|
|
40 -- the pointed-to string, then return an access object pointing to this
|
|
|
41 -- lengthened string.
|
|
|
42 --
|
|
|
43 -- The instance declares a function Execute_Stack which executes each
|
|
|
44 -- subprogram on the stack in sequence. This function accepts some initial
|
|
|
45 -- access-to-string, then returns an access object pointing to the
|
|
|
46 -- lengthened string resulting from the execution of the stacked
|
|
|
47 -- subprograms. Access-to-string objects are used rather than strings
|
|
|
48 -- themselves because the initial string "grows" during each iteration.
|
|
|
49 --
|
|
|
50 --
|
|
|
51 -- CHANGE HISTORY:
|
|
|
52 -- 06 Dec 94 SAIC ACVC 2.0
|
|
|
53 -- 10 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate to context clause
|
|
|
54 -- preceding CC54003_2.
|
|
|
55 --
|
|
|
56 --!
|
|
|
57
|
|
|
58 generic
|
|
|
59
|
|
|
60 Size : in Positive;
|
|
|
61
|
|
|
62 type Item_Type (<>) is private;
|
|
|
63 type Item_Ptr is access Item_Type;
|
|
|
64
|
|
|
65 type Function_Ptr is access function (Item : Item_Ptr)
|
|
|
66 return Item_Ptr;
|
|
|
67
|
|
|
68 package CC54003_0 is -- Generic stack of pointers.
|
|
|
69
|
|
|
70 type Stack_Type is private;
|
|
|
71
|
|
|
72 procedure Push (Stack : in out Stack_Type;
|
|
|
73 Func_Ptr : in Function_Ptr);
|
|
|
74
|
|
|
75 function Execute_Stack (Stack : Stack_Type;
|
|
|
76 Initial_Input : Item_Ptr) return Item_Ptr;
|
|
|
77
|
|
|
78 -- ... Other operations.
|
|
|
79
|
|
|
80 private
|
|
|
81
|
|
|
82 subtype Index is Positive range 1 .. (Size + 1);
|
|
|
83 type Stack_Type is array (Index) of Function_Ptr; -- Last slot unused.
|
|
|
84
|
|
|
85 Top : Index := 1; -- Top refers to the next available slot.
|
|
|
86
|
|
|
87 end CC54003_0;
|
|
|
88
|
|
|
89
|
|
|
90 --===================================================================--
|
|
|
91
|
|
|
92
|
|
|
93 package body CC54003_0 is
|
|
|
94
|
|
|
95 procedure Push (Stack : in out Stack_Type;
|
|
|
96 Func_Ptr : in Function_Ptr) is
|
|
|
97 begin
|
|
|
98 Stack(Top) := Func_Ptr;
|
|
|
99 Top := Top + 1; -- Artificial: no Constraint_Error protection.
|
|
|
100 end Push;
|
|
|
101
|
|
|
102
|
|
|
103 -- Call each subprogram on the stack in sequence. For the first call, pass
|
|
|
104 -- Initial_Input. For succeeding calls, pass the result of the previous
|
|
|
105 -- call.
|
|
|
106
|
|
|
107 function Execute_Stack (Stack : Stack_Type;
|
|
|
108 Initial_Input : Item_Ptr) return Item_Ptr is
|
|
|
109 Result : Item_Ptr := Initial_Input;
|
|
|
110 begin
|
|
|
111 for I in reverse Index'First .. (Top - 1) loop -- Artificial: no C_E
|
|
|
112 Result := Stack(I)(Result); -- protection.
|
|
|
113 end loop;
|
|
|
114 return Result;
|
|
|
115 end Execute_Stack;
|
|
|
116
|
|
|
117 end CC54003_0;
|
|
|
118
|
|
|
119
|
|
|
120 --===================================================================--
|
|
|
121
|
|
|
122
|
|
|
123 package CC54003_1 is
|
|
|
124
|
|
|
125 subtype Message is String;
|
|
|
126 type Message_Ptr is access Message;
|
|
|
127
|
|
|
128 function Add_Prefix (Msg_Ptr : Message_Ptr) return Message_Ptr;
|
|
|
129 function Add_Suffix (Msg_Ptr : Message_Ptr) return Message_Ptr;
|
|
|
130
|
|
|
131 -- ...Other operations.
|
|
|
132
|
|
|
133 end CC54003_1;
|
|
|
134
|
|
|
135
|
|
|
136 --===================================================================--
|
|
|
137
|
|
|
138
|
|
|
139 package body CC54003_1 is
|
|
|
140
|
|
|
141 function Add_Prefix (Msg_Ptr : Message_Ptr) return Message_Ptr is
|
|
|
142 Sender : constant String := "Dummy: "; -- Artificial; in a real
|
|
|
143 -- application Sender might
|
|
|
144 New_Msg : Message := Sender & Msg_Ptr.all; -- be a call to a function.
|
|
|
145 begin
|
|
|
146 return new Message'(New_Msg);
|
|
|
147 end Add_Prefix;
|
|
|
148
|
|
|
149
|
|
|
150 function Add_Suffix (Msg_Ptr : Message_Ptr) return Message_Ptr is
|
|
|
151 Time : constant String := " (12:03pm)"; -- Artificial; in a real
|
|
|
152 -- application Time might be a
|
|
|
153 New_Msg : Message := Msg_Ptr.all & Time; -- be a call to a function.
|
|
|
154 begin
|
|
|
155 return new Message'(New_Msg);
|
|
|
156 end Add_Suffix;
|
|
|
157
|
|
|
158 end CC54003_1;
|
|
|
159
|
|
|
160
|
|
|
161 --===================================================================--
|
|
|
162
|
|
|
163
|
|
|
164 with CC54003_0; -- Generic stack of pointers.
|
|
|
165 pragma Elaborate (CC54003_0);
|
|
|
166
|
|
|
167 with CC54003_1; -- Message abstraction.
|
|
|
168
|
|
|
169 package CC54003_2 is
|
|
|
170
|
|
|
171 type Operation_Ptr is access function (Msg_Ptr : CC54003_1.Message_Ptr)
|
|
|
172 return CC54003_1.Message_Ptr;
|
|
|
173
|
|
|
174 Maximum_Ops : constant := 4; -- Arbitrary.
|
|
|
175
|
|
|
176 package Stack_of_Ops is new CC54003_0
|
|
|
177 (Item_Type => CC54003_1.Message,
|
|
|
178 Item_Ptr => CC54003_1.Message_Ptr,
|
|
|
179 Function_Ptr => Operation_Ptr,
|
|
|
180 Size => Maximum_Ops);
|
|
|
181
|
|
|
182 Operation_Stack : Stack_Of_Ops.Stack_Type;
|
|
|
183
|
|
|
184
|
|
|
185 procedure Create_Operation_Stack;
|
|
|
186
|
|
|
187 end CC54003_2;
|
|
|
188
|
|
|
189 --===================================================================--
|
|
|
190
|
|
|
191
|
|
|
192 package body CC54003_2 is
|
|
|
193
|
|
|
194 procedure Create_Operation_Stack is
|
|
|
195 begin
|
|
|
196 Stack_Of_Ops.Push (Operation_Stack, CC54003_1.Add_Prefix'Access);
|
|
|
197 Stack_Of_Ops.Push (Operation_Stack, CC54003_1.Add_Suffix'Access);
|
|
|
198 end Create_Operation_Stack;
|
|
|
199
|
|
|
200 end CC54003_2;
|
|
|
201
|
|
|
202
|
|
|
203 --===================================================================--
|
|
|
204
|
|
|
205
|
|
|
206 with CC54003_1; -- Message abstraction.
|
|
|
207 with CC54003_2; -- Message-operation stack.
|
|
|
208
|
|
|
209 with Report;
|
|
|
210 procedure CC54003 is
|
|
|
211
|
|
|
212 package Msg_Ops renames CC54003_2.Stack_Of_Ops;
|
|
|
213
|
|
|
214 Msg : CC54003_1.Message_Ptr := new CC54003_1.Message'("Hello there");
|
|
|
215 Expected : CC54003_1.Message := "Dummy: Hello there (12:03pm)";
|
|
|
216
|
|
|
217 begin
|
|
|
218 Report.Test ("CC54003", "Check that a general access-to-subprogram type " &
|
|
|
219 "may be passed as an actual to a generic formal " &
|
|
|
220 "access-to-subprogram type");
|
|
|
221
|
|
|
222 CC54003_2.Create_Operation_Stack;
|
|
|
223
|
|
|
224 declare
|
|
|
225 Actual : CC54003_1.Message_Ptr :=
|
|
|
226 Msg_Ops.Execute_Stack (CC54003_2.Operation_Stack, Msg);
|
|
|
227 begin
|
|
|
228 if Actual.all /= Expected then
|
|
|
229 Report.Failed ("Wrong result from dereferenced subprogram execution");
|
|
|
230 end if;
|
|
|
231 end;
|
|
|
232
|
|
|
233 Report.Result;
|
|
|
234 end CC54003;
|
