1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
|
-- CC50A02.A
--
-- Grant of Unlimited Rights
--
-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
-- unlimited rights in the software and documentation contained herein.
-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making
-- this public release, the Government intends to confer upon all
-- recipients unlimited rights equal to those held by the Government.
-- These rights include rights to use, duplicate, release or disclose the
-- released technical data and computer software in whole or in part, in
-- any manner and for any purpose whatsoever, and to have or permit others
-- to do so.
--
-- DISCLAIMER
--
-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
-- PARTICULAR PURPOSE OF SAID MATERIAL.
--*
--
-- OBJECTIVE:
-- Check that a nonlimited tagged type may be passed as an actual to a
-- formal (non-tagged) private type. Check that if the formal type has
-- an unknown discriminant part, a class-wide type may also be passed as
-- an actual.
--
-- TEST DESCRIPTION:
-- A generic package declares a formal private type and defines a
-- stack abstraction. Stacks are modeled as singly linked lists of
-- pointers to elements. Pointers are used because the elements may
-- be unconstrained.
--
-- A generic testing procedure pushes an item onto a stack, then views
-- the item on top of the stack.
--
-- The formal private type has an unknown discriminant part, and
-- is thus indefinite. This allows both definite and indefinite types
-- (including class-wide types) to be passed as actuals. For tagged types,
-- definite implies nondiscriminated, and indefinite implies discriminated
-- (with known/unknown discriminants).
--
-- TEST FILES:
-- The following files comprise this test:
--
-- FC50A00.A
-- -> CC50A02.A
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 10 Nov 95 SAIC ACVC 2.0.1 fixes: Removed use of formal package
-- exception name in exception choice.
--
--!
generic -- Generic stack abstraction.
type Item (<>) is private; -- Formal private type.
package CC50A02_0 is
type Stack is private;
procedure Push (I : in Item; S : in out Stack);
function View_Top (S : Stack) return Item;
-- ...Other stack operations...
Stack_Empty : exception;
private
type Item_Ptr is access Item;
type Stack_Item;
type Stack_Ptr is access Stack_Item;
type Stack_Item is record
Item : Item_Ptr;
Next : Stack_Ptr;
end record;
type Stack is record
Top : Stack_Ptr := null;
Size : Natural := 0;
end record;
end CC50A02_0;
--==================================================================--
package body CC50A02_0 is
-- Link NewItem in at the top of the stack.
procedure Push (I : in Item; S : in out Stack) is
NewItem : Item_Ptr := new Item'(I);
Element : Stack_Ptr := new Stack_Item'(Item => NewItem, Next => S.Top);
begin
S.Top := Element;
S.Size := S.Size + 1;
end Push;
-- Return (copy) of top item on stack. Do NOT remove from stack.
function View_Top (S : Stack) return Item is
begin
if S.Top = null then
raise Stack_Empty;
else
return S.Top.Item.all;
end if;
end View_Top;
end CC50A02_0;
--==================================================================--
-- The formal package Stacker below is needed to gain access to the
-- appropriate version of the "generic" type Stack. It is provided with an
-- explicit actual part in order to restrict the packages that can be passed
-- as actuals to those which have been instantiated with the same actuals
-- which this generic procedure has been instantiated with.
with CC50A02_0; -- Generic stack abstraction.
generic
type Item_Type (<>) is private; -- Formal private type.
with package Stacker is new CC50A02_0 (Item_Type);
procedure CC50A02_1 (S : in out Stacker.Stack; I : in Item_Type);
--==================================================================--
--
-- This generic procedure performs all of the testing of the
-- stack abstraction.
--
with Report;
procedure CC50A02_1 (S : in out Stacker.Stack; I : in Item_Type) is
begin
Stacker.Push (I, S); -- Push onto empty stack.
-- Calls to View_Top must initialize a declared object of type Item_Type
-- because the type may be unconstrained.
declare
Buffer : Item_Type := Stacker.View_Top (S);
begin
if Buffer /= I then
Report.Failed (" Expected item not on stack");
end if;
exception
when Constraint_Error =>
Report.Failed (" Unexpected error: Tags of pushed and popped " &
"items don't match");
end;
exception
when others =>
Report.Failed (" Unexpected error: Item not pushed onto stack");
end CC50A02_1;
--==================================================================--
with FC50A00; -- Tagged (actual) type declarations.
with CC50A02_0; -- Generic stack abstraction.
with CC50A02_1; -- Generic stack testing procedure.
with Report;
procedure CC50A02 is
--
-- Pass a nondiscriminated tagged actual:
--
package Count_Stacks is new CC50A02_0 (FC50A00.Count_Type);
procedure TC_Count_Test is new CC50A02_1 (FC50A00.Count_Type,
Count_Stacks);
Count_Stack : Count_Stacks.Stack;
--
-- Pass a discriminated tagged actual:
--
package Person_Stacks is new CC50A02_0 (FC50A00.Person_Type);
procedure TC_Person_Test is new CC50A02_1 (FC50A00.Person_Type,
Person_Stacks);
Person_Stack : Person_Stacks.Stack;
--
-- Pass a class-wide actual:
--
package People_Stacks is new CC50A02_0 (FC50A00.Person_Type'Class);
procedure TC_People_Test is new CC50A02_1 (FC50A00.Person_Type'Class,
People_Stacks);
People_Stack : People_Stacks.Stack;
begin
Report.Test ("CC50A02", "Check that tagged actuals may be passed " &
"to a formal (nontagged) private type");
Report.Comment ("Testing definite tagged type..");
TC_Count_Test (Count_Stack, FC50A00.TC_Count_Item);
Report.Comment ("Testing indefinite tagged type..");
TC_Person_Test (Person_Stack, FC50A00.TC_Person_Item);
Report.Comment ("Testing class-wide type..");
TC_People_Test (People_Stack, FC50A00.TC_VIPerson_Item);
Report.Result;
end CC50A02;
|
