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 root tagged type defined
30 -- in a package, and the extended type is defined in that same package.
33 -- Declare a root tagged type, and some associated primitive operations.
34 -- Extend the root type, and override one or more primitive operations,
35 -- inheriting the other primitive operations from the root type.
36 -- Derive from the extended type, again overriding some primitive
37 -- operations and inheriting others (including some that the parent
39 -- Define a subprogram with a class-wide parameter, inside of which is a
40 -- call on a dispatching primitive operation. These primitive operations
41 -- modify global variables (the class-wide parameter has mode IN).
45 -- The following hierarchy of tagged types and primitive operations is
46 -- utilized in this test:
48 -- type Bank_Account (root)
51 -- | Increment_Bank_Reserve
52 -- | Assign_Representative
53 -- | Increment_Counters
56 -- type Savings_Account (extended from Bank_Account)
59 -- | (Increment_Bank_Reserve) (inherited)
60 -- | Assign_Representative (overridden)
61 -- | Increment_Counters (overridden)
62 -- | Open (overridden)
64 -- type Preferred_Account (extended from Savings_Account)
67 -- | (Increment_Bank_Reserve) (inherited twice - Bank_Acct.)
68 -- | (Assign_Representative) (inherited - Savings_Acct.)
69 -- | Increment_Counters (overridden)
70 -- | Open (overridden)
73 -- In this test, we are concerned with the following selection of dispatching
74 -- calls, accomplished with the use of a Bank_Account'Class IN procedure
78 -- Prim. Op \ Bank_Account Savings_Account Preferred_Account
79 -- \------------------------------------------------
80 -- Increment_Bank_Reserve| X X X
81 -- Assign_Representative | X
82 -- Increment_Counters | X X X
86 -- The location of the declaration and derivation of the root and extended
87 -- types will be varied over a series of tests. Locations of declaration
88 -- and derivation for a particular test are marked with an asterisk (*).
92 -- * Declared in package.
93 -- Declared in generic package.
97 -- * Derived in parent location.
98 -- Derived in a nested package.
99 -- Derived in a nested subprogram.
100 -- Derived in a nested generic package.
101 -- Derived in a separate package.
102 -- Derived in a separate visible child package.
103 -- Derived in a separate private child package.
105 -- Primitive Operations:
107 -- * Procedures with same parameter profile.
108 -- Procedures with different parameter profile.
109 -- Functions with same parameter profile.
110 -- Functions with different parameter profile.
111 -- Mixture of Procedures and Functions.
115 -- This test depends on the following foundation code:
119 -- The following files comprise this test:
125 -- 06 Dec 94 SAIC ACVC 2.0
129 with F392A00
; -- package Accounts
134 package Accounts
renames F392A00
;
136 -- Declare account objects.
138 B_Account
: Accounts
.Bank_Account
;
139 S_Account
: Accounts
.Savings_Account
;
140 P_Account
: Accounts
.Preferred_Account
;
142 -- Procedures to operate on accounts.
143 -- Each uses a class-wide IN parameter, as well as a call to a
144 -- dispatching operation.
146 -- Procedure Tabulate_Account performs a dispatching call on a primitive
147 -- operation that has been overridden for each of the extended types.
149 procedure Tabulate_Account
(Acct
: in Accounts
.Bank_Account
'Class) is
151 Accounts
.Increment_Counters
(Acct
); -- Dispatch according to tag.
152 end Tabulate_Account
;
155 -- Procedure Accumulate_Reserve performs a dispatching call on a
156 -- primitive operation that has been defined for the root type and
157 -- inherited by each derived type.
159 procedure Accumulate_Reserve
(Acct
: in Accounts
.Bank_Account
'Class) is
161 Accounts
.Increment_Bank_Reserve
(Acct
); -- Dispatch according to tag.
162 end Accumulate_Reserve
;
165 -- Procedure Resolve_Dispute performs a dispatching call on a primitive
166 -- operation that has been defined in the root type, overridden in the
167 -- first derived extended type, and inherited by the subsequent extended
170 procedure Resolve_Dispute
(Acct
: in Accounts
.Bank_Account
'Class) is
172 Accounts
.Assign_Representative
(Acct
); -- Dispatch according to tag.
177 begin -- Main test procedure.
179 Report
.Test
("C392A01", "Check that the use of a class-wide parameter " &
180 "allows for proper dispatching where root type " &
181 "and extended types are declared in the same " &
184 Bank_Account_Subtest
:
188 Accounts
.Open
(B_Account
);
190 -- Demonstrate class-wide parameter allowing dispatch by a primitive
191 -- operation that has been defined for this specific type.
192 Accumulate_Reserve
(Acct
=> B_Account
);
193 Tabulate_Account
(B_Account
);
195 if (Accounts
.Bank_Reserve
/= Accounts
.Opening_Balance
) or
196 (Accounts
.Number_Of_Accounts
(Bank
) /= 1) or
197 (Accounts
.Number_Of_Accounts
(Total
) /= 1)
199 Report
.Failed
("Failed in Bank_Account_Subtest");
202 end Bank_Account_Subtest
;
205 Savings_Account_Subtest
:
209 Accounts
.Open
(Acct
=> S_Account
);
211 -- Demonstrate class-wide parameter allowing dispatch by a primitive
212 -- operation that has been inherited by this extended type.
213 Accumulate_Reserve
(Acct
=> S_Account
);
215 -- Demonstrate class-wide parameter allowing dispatch by a primitive
216 -- operation that has been overridden for this extended type.
217 Resolve_Dispute
(Acct
=> S_Account
);
218 Tabulate_Account
(S_Account
);
220 if Accounts
.Bank_Reserve
/= (3.0 * Accounts
.Opening_Balance
) or
221 Accounts
.Daily_Representative
/= Accounts
.Manager
or
222 Accounts
.Number_Of_Accounts
(Savings
) /= 1 or
223 Accounts
.Number_Of_Accounts
(Total
) /= 2
225 Report
.Failed
("Failed in Savings_Account_Subtest");
228 end Savings_Account_Subtest
;
231 Preferred_Account_Subtest
:
235 Accounts
.Open
(P_Account
);
237 -- Verify that the correct implementation of Open (overridden) was
238 -- used for the Preferred_Account object.
239 if not Accounts
.Verify_Open
(P_Account
) then
240 Report
.Failed
("Incorrect values for init. Preferred Acct object");
243 -- Demonstrate class-wide parameter allowing dispatch by a primitive
244 -- operation that has been twice inherited by this extended type.
245 Accumulate_Reserve
(Acct
=> P_Account
);
247 -- Demonstrate class-wide parameter allowing dispatch by a primitive
248 -- operation that has been overridden for this extended type (the
249 -- operation was overridden by its parent type as well).
250 Tabulate_Account
(P_Account
);
252 if Accounts
.Bank_Reserve
/= 1300.00 or
253 Accounts
.Number_Of_Accounts
(Preferred
) /= 1 or
254 Accounts
.Number_Of_Accounts
(Total
) /= 3
256 Report
.Failed
("Failed in Preferred_Account_Subtest");
259 end Preferred_Account_Subtest
;