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 the use of a class-wide formal parameter allows for the
28 -- proper dispatching of objects to the appropriate implementation of
29 -- a primitive operation. Check this for the case where the root tagged
30 -- type is defined in a package and the extended type is defined in a
34 -- Declare a root tagged type, and some associated primitive operations,
35 -- in a visible library package.
36 -- Extend the root type in another visible library package, and override
37 -- one or more primitive operations, inheriting the other primitive
38 -- operations from the root type.
39 -- Derive from the extended type in yet another visible library package,
40 -- again overriding some primitive operations and inheriting others
41 -- (including some that the parent inherited).
42 -- Define subprograms with class-wide parameters, inside of which is a
43 -- call on a dispatching primitive operation. These primitive
44 -- operations modify the objects of the specific class passed as actuals
45 -- to the class-wide formal parameter (class-wide formal parameter has
48 -- The following hierarchy of tagged types and primitive operations is
49 -- utilized in this test:
52 -- type Account (root)
58 -- | proc Service_Charge
59 -- | proc Add_Interest
63 -- type Account (extended from Bank.Account)
66 -- | proc Deposit (inherited)
67 -- | proc Withdrawal (inherited)
68 -- | func Balance (inherited)
69 -- | proc Service_Charge (inherited)
70 -- | proc Add_Interest (inherited)
71 -- | proc Open (overridden)
73 -- package Interest_Checking
74 -- type Account (extended from Checking.Account)
77 -- | proc Deposit (inherited twice - Bank.Acct.)
78 -- | proc Withdrawal (inherited twice - Bank.Acct.)
79 -- | func Balance (inherited twice - Bank.Acct.)
80 -- | proc Service_Charge (inherited twice - Bank.Acct.)
81 -- | proc Add_Interest (overridden)
82 -- | proc Open (overridden)
85 -- In this test, we are concerned with the following selection of dispatching
86 -- calls, accomplished with the use of a Bank.Account'Class IN OUT formal
90 -- Prim. Op \ Bank.Account Checking.Account Interest_Checking.Account
91 -- \---------------------------------------------------------
93 -- Service_Charge | X X X
94 -- Add_Interest | X X X
99 -- The location of the declaration of the root and derivation of extended
100 -- types will be varied over a series of tests. Locations of declaration
101 -- and derivation for a particular test are marked with an asterisk (*).
105 -- * Declared in package.
106 -- Declared in generic package.
110 -- Derived in parent location.
111 -- Derived in a nested package.
112 -- Derived in a nested subprogram.
113 -- Derived in a nested generic package.
114 -- * Derived in a separate package.
115 -- Derived in a separate visible child package.
116 -- Derived in a separate private child package.
118 -- Primitive Operations:
120 -- * Procedures with same parameter profile.
121 -- Procedures with different parameter profile.
122 -- Functions with same parameter profile.
123 -- Functions with different parameter profile.
124 -- Mixture of Procedures and Functions.
128 -- This test depends on the following foundation code:
134 -- 06 Dec 94 SAIC ACVC 2.0
135 -- 20 Nov 95 SAIC C392B04 became C392008 for ACVC 2.0.1
139 ----------------------------------------------------------------- C392008_0
141 package C392008_0
is -- package Bank
143 type Dollar_Amount
is range -30_000
..30_000
;
145 type Account
is tagged
147 Current_Balance
: Dollar_Amount
;
150 -- Primitive operations.
152 procedure Deposit
(A
: in out Account
;
153 X
: in Dollar_Amount
);
154 procedure Withdrawal
(A
: in out Account
;
155 X
: in Dollar_Amount
);
156 function Balance
(A
: in Account
) return Dollar_Amount
;
157 procedure Service_Charge
(A
: in out Account
);
158 procedure Add_Interest
(A
: in out Account
);
159 procedure Open
(A
: in out Account
);
163 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
165 package body C392008_0
is
167 -- Primitive operations for type Account.
169 procedure Deposit
(A
: in out Account
;
170 X
: in Dollar_Amount
) is
172 A
.Current_Balance
:= A
.Current_Balance
+ X
;
175 procedure Withdrawal
(A
: in out Account
;
176 X
: in Dollar_Amount
) is
178 A
.Current_Balance
:= A
.Current_Balance
- X
;
181 function Balance
(A
: in Account
) return Dollar_Amount
is
183 return (A
.Current_Balance
);
186 procedure Service_Charge
(A
: in out Account
) is
188 A
.Current_Balance
:= A
.Current_Balance
- 5_00
;
191 procedure Add_Interest
(A
: in out Account
) is
192 Interest_On_Account
: Dollar_Amount
:= 0_00
;
194 A
.Current_Balance
:= A
.Current_Balance
+ Interest_On_Account
;
197 procedure Open
(A
: in out Account
) is
198 Initial_Deposit
: Dollar_Amount
:= 10_00
;
200 A
.Current_Balance
:= Initial_Deposit
;
205 ----------------------------------------------------------------- C392008_1
207 with C392008_0
; -- package Bank
209 package C392008_1
is -- package Checking
211 package Bank
renames C392008_0
;
213 type Account
is new Bank
.Account
with
215 Overdraft_Fee
: Bank
.Dollar_Amount
;
218 -- Overridden primitive operation.
220 procedure Open
(A
: in out Account
);
222 -- Inherited primitive operations.
223 -- procedure Deposit (A : in out Account;
224 -- X : in Bank.Dollar_Amount);
225 -- procedure Withdrawal (A : in out Account;
226 -- X : in Bank.Dollar_Amount);
227 -- function Balance (A : in Account) return Bank.Dollar_Amount;
228 -- procedure Service_Charge (A : in out Account);
229 -- procedure Add_Interest (A : in out Account);
233 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
235 package body C392008_1
is
237 -- Overridden primitive operation.
239 procedure Open
(A
: in out Account
) is
240 Check_Guarantee
: Bank
.Dollar_Amount
:= 10_00
;
241 Initial_Deposit
: Bank
.Dollar_Amount
:= 20_00
;
243 A
.Current_Balance
:= Initial_Deposit
;
244 A
.Overdraft_Fee
:= Check_Guarantee
;
249 ----------------------------------------------------------------- C392008_2
251 with C392008_0
; -- with Bank;
252 with C392008_1
; -- with Checking;
254 package C392008_2
is -- package Interest_Checking
256 package Bank
renames C392008_0
;
257 package Checking
renames C392008_1
;
259 subtype Interest_Rate
is Bank
.Dollar_Amount
range 0..100; -- was digits 4;
261 Current_Rate
: Interest_Rate
:= 0_02
;
263 type Account
is new Checking
.Account
with
265 Rate
: Interest_Rate
;
268 -- Overridden primitive operations.
270 procedure Add_Interest
(A
: in out Account
);
271 procedure Open
(A
: in out Account
);
273 -- "Twice" inherited primitive operations (from Bank.Account)
274 -- procedure Deposit (A : in out Account;
275 -- X : in Bank.Dollar_Amount);
276 -- procedure Withdrawal (A : in out Account;
277 -- X : in Bank.Dollar_Amount);
278 -- function Balance (A : in Account) return Bank.Dollar_Amount;
279 -- procedure Service_Charge (A : in out Account);
283 -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
285 package body C392008_2
is
287 -- Overridden primitive operations.
289 procedure Add_Interest
(A
: in out Account
) is
290 Interest_On_Account
: Bank
.Dollar_Amount
291 := Bank
.Dollar_Amount
( Bank
."*"( A
.Current_Balance
, A
.Rate
));
293 A
.Current_Balance
:= Bank
."+"( A
.Current_Balance
, Interest_On_Account
);
296 procedure Open
(A
: in out Account
) is
297 Initial_Deposit
: Bank
.Dollar_Amount
:= 30_00
;
299 Checking
.Open
(Checking
.Account
(A
));
300 A
.Current_Balance
:= Initial_Deposit
;
301 A
.Rate
:= Current_Rate
;
306 ------------------------------------------------------------------- C392008
308 with C392008_0
; use C392008_0
; -- package Bank
309 with C392008_1
; use C392008_1
; -- package Checking;
310 with C392008_2
; use C392008_2
; -- package Interest_Checking;
315 package Bank
renames C392008_0
;
316 package Checking
renames C392008_1
;
317 package Interest_Checking
renames C392008_2
;
319 B_Acct
: Bank
.Account
;
320 C_Acct
: Checking
.Account
;
321 IC_Acct
: Interest_Checking
.Account
;
324 -- Define procedures with class-wide formal parameters of mode IN OUT.
327 -- This procedure will perform a dispatching call on the
328 -- overridden primitive operation Open.
330 procedure New_Account
(Acct
: in out Bank
.Account
'Class) is
332 Open
(Acct
); -- Dispatch according to tag of class-wide parameter.
335 -- This procedure will perform a dispatching call on the inherited
336 -- primitive operation (for all types derived from the root Bank.Account)
339 procedure Apply_Service_Charge
(Acct
: in out Bank
.Account
'Class) is
341 Service_Charge
(Acct
); -- Dispatch according to tag of class-wide parm.
342 end Apply_Service_Charge
;
344 -- This procedure will perform a dispatching call on the
345 -- inherited/overridden primitive operation Add_Interest.
347 procedure Annual_Interest
(Acct
: in out Bank
.Account
'Class) is
349 Add_Interest
(Acct
); -- Dispatch according to tag of class-wide parm.
354 Report
.Test
("C392008", "Check that the use of a class-wide formal " &
355 "parameter allows for the proper dispatching " &
356 "of objects to the appropriate implementation " &
357 "of a primitive operation");
359 -- Check the dispatch to primitive operations overridden for each
361 New_Account
(B_Acct
);
362 New_Account
(C_Acct
);
363 New_Account
(IC_Acct
);
365 if (B_Acct
.Current_Balance
/= 10_00
) or
366 (C_Acct
.Current_Balance
/= 20_00
) or
367 (IC_Acct
.Current_Balance
/= 30_00
)
369 Report
.Failed
("Failed dispatch to multiply overridden prim. oper.");
373 Annual_Interest
(B_Acct
);
374 Annual_Interest
(C_Acct
);
375 Annual_Interest
(IC_Acct
); -- Check the dispatch to primitive operation
376 -- overridden from a parent type which inherited
377 -- the operation from the root type.
378 if (B_Acct
.Current_Balance
/= 10_00
) or
379 (C_Acct
.Current_Balance
/= 20_00
) or
380 (IC_Acct
.Current_Balance
/= 90_00
)
382 Report
.Failed
("Failed dispatch to overridden primitive operation");
386 Apply_Service_Charge
(Acct
=> B_Acct
);
387 Apply_Service_Charge
(Acct
=> C_Acct
);
388 Apply_Service_Charge
(Acct
=> IC_Acct
); -- Check the dispatch to a
389 -- primitive operation twice
390 -- inherited from the root
392 if (B_Acct
.Current_Balance
/= 5_00
) or
393 (C_Acct
.Current_Balance
/= 15_00
) or
394 (IC_Acct
.Current_Balance
/= 85_00
)
396 Report
.Failed
("Failed dispatch to Apply_Service_Charge");