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 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.
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.
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.
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).
52 -- This test consists of the following files:
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.
67 with FC50A00
; -- Tagged (actual) type declarations.
68 generic -- Generic stack abstraction.
70 type Item
(<>) is tagged private; -- Formal tagged private type.
71 TC_Default_Value
: Item
; -- Needed in View_Top (see
75 type Stack
is private;
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.
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
;
89 function Size_Of
(S
: Stack
) return Natural;
94 type Stack_Ptr
is access Stack_Item
;
96 type Stack_Item
is new Item
with record -- Extends formal type.
97 Next
: Stack_Ptr
:= null;
101 Top
: Stack_Ptr
:= null;
108 --==================================================================--
111 package body CC50A01_0
is
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).
117 procedure Push
(I
: in Item
; S
: in out Stack
) is
120 NewItem
:= new Stack_Item
'(I with S.Top); -- Extension aggregate.
122 S.Size := S.Size + 1;
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
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).
134 procedure Pop (S : in out Stack) is
136 if S.Top = null then -- Stack is empty.
141 S.Size := S.Size - 1;
142 -- Deallocate discarded node.
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.
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.
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).
159 function View_Top (S : Stack) return Item is
161 if S.Top = null then -- Stack is empty.
162 return TC_Default_Value; -- Testing artifice.
165 return Item(S.Top.all); -- Type conversion.
170 function Size_Of (S : Stack) return Natural is
179 --==================================================================--
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.
188 with CC50A01_0; -- Generic stack abstraction.
190 type Item_Type (<>) is tagged private; -- Formal tagged private 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);
196 --==================================================================--
199 -- This generic procedure performs all of the testing of the
200 -- stack abstraction.
204 procedure CC50A01_1 (S : in out Stacker.Stack; I : in Item_Type) is
206 Stacker.Push (I, S); -- Push onto empty stack.
207 Stacker.Push (I, S); -- Push onto nonempty stack.
209 if Stacker.Size_Of (S) /= 2 then
210 Report.Failed (" Wrong stack size after 2 Pushes");
213 -- Calls to View_Top must initialize a declared object of type Item_Type
214 -- because the type may be unconstrained.
217 Buffer1 : Item_Type := Stacker.View_Top (S);
219 Stacker.Pop (S); -- Pop item off nonempty stack.
221 Report.Failed (" Wrong stack item value after 1st Pop");
226 Buffer2 : Item_Type := Stacker.View_Top (S);
228 Stacker.Pop (S); -- Pop last item off stack.
230 Report.Failed (" Wrong stack item value after 2nd Pop");
234 if Stacker.Size_Of (S) /= 0 then
235 Report.Failed (" Wrong stack size after 2 Pops");
239 Buffer3 : Item_Type := Stacker.View_Top (S);
241 if Buffer3 /= Default then
242 Report.Failed (" Wrong result after Pop of empty stack");
244 Stacker.Pop (S); -- Pop off empty stack.
250 --==================================================================--
256 pragma Elaborate (CC50A01_0);
258 package CC50A01_2 is new CC50A01_0 (FC50A00.Count_Type,
259 FC50A00.TC_Default_Count);
262 --==================================================================--
268 pragma Elaborate (CC50A01_0);
270 package CC50A01_3 is new CC50A01_0 (FC50A00.Person_Type,
271 FC50A00.TC_Default_Person);
274 --==================================================================--
277 with FC50A00; -- Tagged (actual) type declarations.
278 with CC50A01_0; -- Generic stack abstraction.
279 with CC50A01_1; -- Generic stack testing procedure.
286 package Count_Stacks renames CC50A01_2;
287 package Person_Stacks renames CC50A01_3;
290 procedure TC_Count_Test is new CC50A01_1 (FC50A00.Count_Type,
291 FC50A00.TC_Default_Count,
293 Count_Stack : Count_Stacks.Stack;
296 procedure TC_Person_Test is new CC50A01_1 (FC50A00.Person_Type,
297 FC50A00.TC_Default_Person,
299 Person_Stack : Person_Stacks.Stack;
302 Report.Test ("CC50A01", "Check that a formal parameter of a " &
303 "library-level generic unit may be a formal tagged " &
306 Report.Comment ("Testing definite tagged type..");
307 TC_Count_Test (Count_Stack, FC50A00.TC_Count_Item);
309 Report.Comment ("Testing indefinite tagged type..");
310 TC_Person_Test (Person_Stack, FC50A00.TC_Person_Item);