|
111
|
1 -- CC50A01.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 formal parameter of a library-level generic unit may be
|
|
|
28 -- a formal tagged private type. Check that a nonlimited tagged type may
|
|
|
29 -- be passed as an actual. Check that if the formal type is indefinite,
|
|
|
30 -- both indefinite and definite types may be passed as actuals.
|
|
|
31 --
|
|
|
32 -- TEST DESCRIPTION:
|
|
|
33 -- The generic package declares a formal tagged private type (this can
|
|
|
34 -- be considered the parent "mixin" class). This type is extended in
|
|
|
35 -- the generic to provide support for stacks of items of any nonlimited
|
|
|
36 -- tagged type. Stacks are modeled as singly linked lists, with the list
|
|
|
37 -- nodes being objects of the extended type.
|
|
|
38 --
|
|
|
39 -- A generic testing procedure pushes items onto a stack, and pops them
|
|
|
40 -- back off, verifying the state of the stack at various points along the
|
|
|
41 -- way. The push and pop routines exercise functionality important to
|
|
|
42 -- tagged types, such as type conversion toward the root of the derivation
|
|
|
43 -- class and extension aggregates.
|
|
|
44 --
|
|
|
45 -- The formal tagged private type has an unknown discriminant part, and
|
|
|
46 -- is thus indefinite. This allows both definite and indefinite types
|
|
|
47 -- to be passed as actuals. For tagged types, definite implies
|
|
|
48 -- nondiscriminated, and indefinite implies discriminated (with known
|
|
|
49 -- or unknown discriminants).
|
|
|
50 --
|
|
|
51 -- TEST FILES:
|
|
|
52 -- This test consists of the following files:
|
|
|
53 --
|
|
|
54 -- FC50A00.A
|
|
|
55 -- -> CC50A01.A
|
|
|
56 --
|
|
|
57 --
|
|
|
58 -- CHANGE HISTORY:
|
|
|
59 -- 06 Dec 94 SAIC ACVC 2.0
|
|
|
60 -- 21 Nov 95 SAIC ACVC 2.0.1 fixes: Moved instantiations of
|
|
|
61 -- BC50A01_0 to library level.
|
|
|
62 -- 11 Aug 96 SAIC ACVC 2.1: Updated prologue. Added pragma
|
|
|
63 -- Elaborate to context clauses for CC50A01_2 & _3.
|
|
|
64 --
|
|
|
65 --!
|
|
|
66
|
|
|
67 with FC50A00; -- Tagged (actual) type declarations.
|
|
|
68 generic -- Generic stack abstraction.
|
|
|
69
|
|
|
70 type Item (<>) is tagged private; -- Formal tagged private type.
|
|
|
71 TC_Default_Value : Item; -- Needed in View_Top (see
|
|
|
72 -- below).
|
|
|
73 package CC50A01_0 is
|
|
|
74
|
|
|
75 type Stack is private;
|
|
|
76
|
|
|
77 -- Note that because the actual type corresponding to Item may be
|
|
|
78 -- unconstrained, the functions of removing the top item from the stack and
|
|
|
79 -- returning the value of the top item of the stack have been separated into
|
|
|
80 -- Pop and View_Top, respectively. This is necessary because otherwise the
|
|
|
81 -- returned value would have to be an out parameter of Pop, which would
|
|
|
82 -- require the user (in the unconstrained case) to create an uninitialized
|
|
|
83 -- unconstrained object to serve as the actual, which is illegal.
|
|
|
84
|
|
|
85 procedure Push (I : in Item; S : in out Stack);
|
|
|
86 procedure Pop (S : in out Stack);
|
|
|
87 function View_Top (S : Stack) return Item;
|
|
|
88
|
|
|
89 function Size_Of (S : Stack) return Natural;
|
|
|
90
|
|
|
91 private
|
|
|
92
|
|
|
93 type Stack_Item;
|
|
|
94 type Stack_Ptr is access Stack_Item;
|
|
|
95
|
|
|
96 type Stack_Item is new Item with record -- Extends formal type.
|
|
|
97 Next : Stack_Ptr := null;
|
|
|
98 end record;
|
|
|
99
|
|
|
100 type Stack is record
|
|
|
101 Top : Stack_Ptr := null;
|
|
|
102 Size : Natural := 0;
|
|
|
103 end record;
|
|
|
104
|
|
|
105 end CC50A01_0;
|
|
|
106
|
|
|
107
|
|
|
108 --==================================================================--
|
|
|
109
|
|
|
110
|
|
|
111 package body CC50A01_0 is
|
|
|
112
|
|
|
113 -- Link NewItem in at the top of the stack (the extension aggregate within
|
|
|
114 -- the allocator initializes the inherited portion of NewItem to equal I,
|
|
|
115 -- and NewItem.Next to point to what S.Top points to).
|
|
|
116
|
|
|
117 procedure Push (I : in Item; S : in out Stack) is
|
|
|
118 NewItem : Stack_Ptr;
|
|
|
119 begin
|
|
|
120 NewItem := new Stack_Item'(I with S.Top); -- Extension aggregate.
|
|
|
121 S.Top := NewItem;
|
|
|
122 S.Size := S.Size + 1;
|
|
|
123 end Push;
|
|
|
124
|
|
|
125
|
|
|
126 -- Remove item from top of stack. This procedure only updates the state of
|
|
|
127 -- the stack; it does not return the value of the popped item. Hence, in
|
|
|
128 -- order to accomplish a "true" pop, both View_Top and Pop must be called
|
|
|
129 -- consecutively.
|
|
|
130 --
|
|
|
131 -- If the stack is empty, the Pop is ignored (for simplicity; in a true
|
|
|
132 -- application this might be treated as an error condition).
|
|
|
133
|
|
|
134 procedure Pop (S : in out Stack) is
|
|
|
135 begin
|
|
|
136 if S.Top = null then -- Stack is empty.
|
|
|
137 null;
|
|
|
138 -- Raise exception.
|
|
|
139 else
|
|
|
140 S.Top := S.Top.Next;
|
|
|
141 S.Size := S.Size - 1;
|
|
|
142 -- Deallocate discarded node.
|
|
|
143 end if;
|
|
|
144 end Pop;
|
|
|
145
|
|
|
146
|
|
|
147 -- Return the value of the top item on the stack. This procedure only
|
|
|
148 -- returns the value; it does not remove the top item from the stack.
|
|
|
149 -- Hence, in order to accomplish a "true" pop, both View_Top and Pop must
|
|
|
150 -- be called consecutively.
|
|
|
151 --
|
|
|
152 -- Since items on the stack are of a type (Stack_Item) derived from Item,
|
|
|
153 -- which is a (tagged) private type, type conversion toward the root is the
|
|
|
154 -- only way to get a value of type Item for return to the caller.
|
|
|
155 --
|
|
|
156 -- If the stack is empty, View_Top returns a pre-specified default value.
|
|
|
157 -- (In a true application, an exception might be raised instead).
|
|
|
158
|
|
|
159 function View_Top (S : Stack) return Item is
|
|
|
160 begin
|
|
|
161 if S.Top = null then -- Stack is empty.
|
|
|
162 return TC_Default_Value; -- Testing artifice.
|
|
|
163 -- Raise exception.
|
|
|
164 else
|
|
|
165 return Item(S.Top.all); -- Type conversion.
|
|
|
166 end if;
|
|
|
167 end View_Top;
|
|
|
168
|
|
|
169
|
|
|
170 function Size_Of (S : Stack) return Natural is
|
|
|
171 begin
|
|
|
172 return (S.Size);
|
|
|
173 end Size_Of;
|
|
|
174
|
|
|
175
|
|
|
176 end CC50A01_0;
|
|
|
177
|
|
|
178
|
|
|
179 --==================================================================--
|
|
|
180
|
|
|
181
|
|
|
182 -- The formal package Stacker below is needed to gain access to the
|
|
|
183 -- appropriate version of the "generic" type Stack. It is provided with an
|
|
|
184 -- explicit actual part in order to restrict the packages that can be passed
|
|
|
185 -- as actuals to those which have been instantiated with the same actuals
|
|
|
186 -- which this generic procedure has been instantiated with.
|
|
|
187
|
|
|
188 with CC50A01_0; -- Generic stack abstraction.
|
|
|
189 generic
|
|
|
190 type Item_Type (<>) is tagged private; -- Formal tagged private type.
|
|
|
191 Default : Item_Type;
|
|
|
192 with package Stacker is new CC50A01_0 (Item_Type, Default);
|
|
|
193 procedure CC50A01_1 (S : in out Stacker.Stack; I : in Item_Type);
|
|
|
194
|
|
|
195
|
|
|
196 --==================================================================--
|
|
|
197
|
|
|
198 --
|
|
|
199 -- This generic procedure performs all of the testing of the
|
|
|
200 -- stack abstraction.
|
|
|
201 --
|
|
|
202
|
|
|
203 with Report;
|
|
|
204 procedure CC50A01_1 (S : in out Stacker.Stack; I : in Item_Type) is
|
|
|
205 begin
|
|
|
206 Stacker.Push (I, S); -- Push onto empty stack.
|
|
|
207 Stacker.Push (I, S); -- Push onto nonempty stack.
|
|
|
208
|
|
|
209 if Stacker.Size_Of (S) /= 2 then
|
|
|
210 Report.Failed (" Wrong stack size after 2 Pushes");
|
|
|
211 end if;
|
|
|
212
|
|
|
213 -- Calls to View_Top must initialize a declared object of type Item_Type
|
|
|
214 -- because the type may be unconstrained.
|
|
|
215
|
|
|
216 declare
|
|
|
217 Buffer1 : Item_Type := Stacker.View_Top (S);
|
|
|
218 begin
|
|
|
219 Stacker.Pop (S); -- Pop item off nonempty stack.
|
|
|
220 if Buffer1 /= I then
|
|
|
221 Report.Failed (" Wrong stack item value after 1st Pop");
|
|
|
222 end if;
|
|
|
223 end;
|
|
|
224
|
|
|
225 declare
|
|
|
226 Buffer2 : Item_Type := Stacker.View_Top (S);
|
|
|
227 begin
|
|
|
228 Stacker.Pop (S); -- Pop last item off stack.
|
|
|
229 if Buffer2 /= I then
|
|
|
230 Report.Failed (" Wrong stack item value after 2nd Pop");
|
|
|
231 end if;
|
|
|
232 end;
|
|
|
233
|
|
|
234 if Stacker.Size_Of (S) /= 0 then
|
|
|
235 Report.Failed (" Wrong stack size after 2 Pops");
|
|
|
236 end if;
|
|
|
237
|
|
|
238 declare
|
|
|
239 Buffer3 : Item_Type := Stacker.View_Top (S);
|
|
|
240 begin
|
|
|
241 if Buffer3 /= Default then
|
|
|
242 Report.Failed (" Wrong result after Pop of empty stack");
|
|
|
243 end if;
|
|
|
244 Stacker.Pop (S); -- Pop off empty stack.
|
|
|
245 end;
|
|
|
246
|
|
|
247 end CC50A01_1;
|
|
|
248
|
|
|
249
|
|
|
250 --==================================================================--
|
|
|
251
|
|
|
252
|
|
|
253 with FC50A00;
|
|
|
254
|
|
|
255 with CC50A01_0;
|
|
|
256 pragma Elaborate (CC50A01_0);
|
|
|
257
|
|
|
258 package CC50A01_2 is new CC50A01_0 (FC50A00.Count_Type,
|
|
|
259 FC50A00.TC_Default_Count);
|
|
|
260
|
|
|
261
|
|
|
262 --==================================================================--
|
|
|
263
|
|
|
264
|
|
|
265 with FC50A00;
|
|
|
266
|
|
|
267 with CC50A01_0;
|
|
|
268 pragma Elaborate (CC50A01_0);
|
|
|
269
|
|
|
270 package CC50A01_3 is new CC50A01_0 (FC50A00.Person_Type,
|
|
|
271 FC50A00.TC_Default_Person);
|
|
|
272
|
|
|
273
|
|
|
274 --==================================================================--
|
|
|
275
|
|
|
276
|
|
|
277 with FC50A00; -- Tagged (actual) type declarations.
|
|
|
278 with CC50A01_0; -- Generic stack abstraction.
|
|
|
279 with CC50A01_1; -- Generic stack testing procedure.
|
|
|
280 with CC50A01_2;
|
|
|
281 with CC50A01_3;
|
|
|
282
|
|
|
283 with Report;
|
|
|
284 procedure CC50A01 is
|
|
|
285
|
|
|
286 package Count_Stacks renames CC50A01_2;
|
|
|
287 package Person_Stacks renames CC50A01_3;
|
|
|
288
|
|
|
289
|
|
|
290 procedure TC_Count_Test is new CC50A01_1 (FC50A00.Count_Type,
|
|
|
291 FC50A00.TC_Default_Count,
|
|
|
292 Count_Stacks);
|
|
|
293 Count_Stack : Count_Stacks.Stack;
|
|
|
294
|
|
|
295
|
|
|
296 procedure TC_Person_Test is new CC50A01_1 (FC50A00.Person_Type,
|
|
|
297 FC50A00.TC_Default_Person,
|
|
|
298 Person_Stacks);
|
|
|
299 Person_Stack : Person_Stacks.Stack;
|
|
|
300
|
|
|
301 begin
|
|
|
302 Report.Test ("CC50A01", "Check that a formal parameter of a " &
|
|
|
303 "library-level generic unit may be a formal tagged " &
|
|
|
304 "private type");
|
|
|
305
|
|
|
306 Report.Comment ("Testing definite tagged type..");
|
|
|
307 TC_Count_Test (Count_Stack, FC50A00.TC_Count_Item);
|
|
|
308
|
|
|
309 Report.Comment ("Testing indefinite tagged type..");
|
|
|
310 TC_Person_Test (Person_Stack, FC50A00.TC_Person_Item);
|
|
|
311
|
|
|
312 Report.Result;
|
|
|
313 end CC50A01;
|
