1-- C392003.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 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 where the root tagged type is 30-- defined in a package, and the extended type is defined in a nested 31-- package. 32-- 33-- TEST DESCRIPTION: 34-- Declare a root tagged type, and some associated primitive operations. 35-- Extend the root type, and override one or more primitive operations, 36-- inheriting the other primitive operations from the root type. 37-- Derive from the extended type, again overriding some primitive 38-- operations and inheriting others (including some that the parent 39-- inherited). 40-- Define a subprogram with a class-wide parameter, inside of which is a 41-- call on a dispatching primitive operation. These primitive operations 42-- modify global variables (the class-wide parameter has mode IN). 43-- 44-- 45-- 46-- The following hierarchy of tagged types and primitive operations is 47-- utilized in this test: 48-- 49-- type Bank_Account (root) 50-- | 51-- | Operations 52-- | Increment_Bank_Reserve 53-- | Assign_Representative 54-- | Increment_Counters 55-- | Open 56-- | 57-- type Savings_Account (extended from Bank_Account) 58-- | 59-- | Operations 60-- | (Increment_Bank_Reserve) (inherited) 61-- | Assign_Representative (overridden) 62-- | Increment_Counters (overridden) 63-- | Open (overridden) 64-- | 65-- type Preferred_Account (extended from Savings_Account) 66-- | 67-- | Operations 68-- | (Increment_Bank_Reserve) (inherited twice - Bank_Acct.) 69-- | (Assign_Representative) (inherited - Savings_Acct.) 70-- | Increment_Counters (overridden) 71-- | Open (overridden) 72-- 73-- 74-- In this test, we are concerned with the following selection of dispatching 75-- calls, accomplished with the use of a Bank_Account'Class IN procedure 76-- parameter : 77-- 78-- \ Type 79-- Prim. Op \ Bank_Account Savings_Account Preferred_Account 80-- \------------------------------------------------ 81-- Increment_Bank_Reserve| X X 82-- Assign_Representative | X 83-- Increment_Counters | X X X 84-- 85-- 86-- 87-- The location of the declaration and derivation of the root and extended 88-- types will be varied over a series of tests. Locations of declaration 89-- and derivation for a particular test are marked with an asterisk (*). 90-- 91-- Root type: 92-- 93-- * Declared in package. 94-- Declared in generic package. 95-- 96-- Extended types: 97-- 98-- Derived in parent location. 99-- * Derived in a nested package. 100-- Derived in a nested subprogram. 101-- Derived in a nested generic package. 102-- Derived in a separate package. 103-- Derived in a separate visible child package. 104-- Derived in a separate private child package. 105-- 106-- Primitive Operations: 107-- 108-- * Procedures with same parameter profile. 109-- Procedures with different parameter profile. 110-- * Functions with same parameter profile. 111-- Functions with different parameter profile. 112-- * Mixture of Procedures and Functions. 113-- 114-- 115-- CHANGE HISTORY: 116-- 06 Dec 94 SAIC ACVC 2.0 117-- 118--! 119 120 121 with Report; 122 123 procedure C392003 is 124 125 -- 126 -- Types and subtypes. 127 -- 128 129 type Dollar_Amount is new float; 130 type Interest_Rate is delta 0.001 range 0.000 .. 1.000; 131 type Account_Types is (Bank, Savings, Preferred, Total); 132 type Account_Counter is array (Account_Types) of integer; 133 type Account_Rep is (President, Manager, New_Account_Manager, Teller); 134 135 -- 136 -- Constants. 137 -- 138 139 Opening_Balance : constant Dollar_Amount := 100.00; 140 Current_Rate : constant Interest_Rate := 0.030; 141 Preferred_Minimum_Balance : constant Dollar_Amount := 1000.00; 142 143 -- 144 -- Global Variables 145 -- 146 147 Bank_Reserve : Dollar_Amount := 0.00; 148 Daily_Representative : Account_Rep := New_Account_Manager; 149 Number_Of_Accounts : Account_Counter := (Bank => 0, 150 Savings => 0, 151 Preferred => 0, 152 Total => 0); 153 154 -- Root tagged type and primitive operations declared in internal 155 -- package (Accounts). 156 -- Extended types (and primitive operations) derived in nested packages. 157 158 --=================================================================-- 159 160 package Accounts is 161 162 -- 163 -- Root account type and primitive operations. 164 -- 165 166 -- Root type. 167 168 type Bank_Account is tagged 169 record 170 Balance : Dollar_Amount; 171 end record; 172 173 -- Primitive operations of Bank_Account. 174 175 function Increment_Bank_Reserve (Acct : in Bank_Account) 176 return Dollar_Amount; 177 function Assign_Representative (Acct : in Bank_Account) 178 return Account_Rep; 179 procedure Increment_Counters (Acct : in Bank_Account); 180 procedure Open (Acct : in out Bank_Account); 181 182 --=================================================================-- 183 184 package S_And_L is 185 186 -- Declare extended type in a nested package. 187 188 type Savings_Account is new Bank_Account with 189 record 190 Rate : Interest_Rate; 191 end record; 192 193 -- Function Increment_Bank_Reserve inherited from 194 -- parent (Bank_Account). 195 196 -- Primitive operations (Overridden). 197 function Assign_Representative (Acct : in Savings_Account) 198 return Account_Rep; 199 procedure Increment_Counters (Acct : in Savings_Account); 200 procedure Open (Acct : in out Savings_Account); 201 202 203 --=================================================================-- 204 205 package Premium is 206 207 -- Declare further extended type in a nested package. 208 209 type Preferred_Account is new Savings_Account with 210 record 211 Minimum_Balance : Dollar_Amount; 212 end record; 213 214 -- Function Increment_Bank_Reserve inherited twice. 215 -- Function Assign_Representative inherited from parent 216 -- (Savings_Account). 217 218 -- Primitive operation (Overridden). 219 procedure Increment_Counters (Acct : in Preferred_Account); 220 procedure Open (Acct : in out Preferred_Account); 221 222 -- Function used to verify Open operation for Preferred_Account 223 -- objects. 224 function Verify_Open (Acct : in Preferred_Account) return Boolean; 225 226 end Premium; 227 228 end S_And_L; 229 230 end Accounts; 231 232 --=================================================================-- 233 234 package body Accounts is 235 236 -- 237 -- Primitive operations for Bank_Account. 238 -- 239 240 function Increment_Bank_Reserve (Acct : in Bank_Account) 241 return Dollar_Amount is 242 begin 243 return (Bank_Reserve + Acct.Balance); 244 end Increment_Bank_Reserve; 245 246 function Assign_Representative (Acct : in Bank_Account) 247 return Account_Rep is 248 begin 249 return Account_Rep'(Teller); 250 end Assign_Representative; 251 252 procedure Increment_Counters (Acct : in Bank_Account) is 253 begin 254 Number_Of_Accounts (Bank) := Number_Of_Accounts (Bank) + 1; 255 Number_Of_Accounts (Total) := Number_Of_Accounts (Total) + 1; 256 end Increment_Counters; 257 258 procedure Open (Acct : in out Bank_Account) is 259 begin 260 Acct.Balance := Opening_Balance; 261 end Open; 262 263 --=================================================================-- 264 265 package body S_And_L is 266 267 -- 268 -- Overridden operations for Savings_Account type. 269 -- 270 271 function Assign_Representative (Acct : in Savings_Account) 272 return Account_Rep is 273 begin 274 return (Manager); 275 end Assign_Representative; 276 277 procedure Increment_Counters (Acct : in Savings_Account) is 278 begin 279 Number_Of_Accounts (Savings) := Number_Of_Accounts (Savings) + 1; 280 Number_Of_Accounts (Total) := Number_Of_Accounts (Total) + 1; 281 end Increment_Counters; 282 283 procedure Open (Acct : in out Savings_Account) is 284 begin 285 Open (Bank_Account(Acct)); 286 Acct.Rate := Current_Rate; 287 Acct.Balance := 2.0 * Opening_Balance; 288 end Open; 289 290 --=================================================================-- 291 292 package body Premium is 293 294 -- 295 -- Overridden operations for Preferred_Account type. 296 -- 297 298 procedure Increment_Counters (Acct : in Preferred_Account) is 299 begin 300 Number_Of_Accounts (Preferred) := 301 Number_Of_Accounts (Preferred) + 1; 302 Number_Of_Accounts (Total) := 303 Number_Of_Accounts (Total) + 1; 304 end Increment_Counters; 305 306 procedure Open (Acct : in out Preferred_Account) is 307 begin 308 Open (Savings_Account(Acct)); 309 Acct.Minimum_Balance := Preferred_Minimum_Balance; 310 Acct.Balance := Acct.Minimum_Balance; 311 end Open; 312 313 -- 314 -- Function used to verify Open operation for Preferred_Account 315 -- objects. 316 -- 317 318 function Verify_Open (Acct : in Preferred_Account) 319 return Boolean is 320 begin 321 return (Acct.Balance = Preferred_Minimum_Balance and 322 Acct.Rate = Current_Rate and 323 Acct.Minimum_Balance = Preferred_Minimum_Balance); 324 end Verify_Open; 325 326 end Premium; 327 328 end S_And_L; 329 330 end Accounts; 331 332 --=================================================================-- 333 334 -- Declare account objects. 335 336 B_Account : Accounts.Bank_Account; 337 S_Account : Accounts.S_And_L.Savings_Account; 338 P_Account : Accounts.S_And_L.Premium.Preferred_Account; 339 340 -- Procedures to operate on accounts. 341 -- Each uses a class-wide IN parameter, as well as a call to a 342 -- dispatching operation. 343 344 -- Function Tabulate_Account performs a dispatching call on a primitive 345 -- operation that has been overridden for each of the extended types. 346 347 procedure Tabulate_Account (Acct : in Accounts.Bank_Account'Class) is 348 begin 349 Accounts.Increment_Counters (Acct); -- Dispatch according to tag. 350 end Tabulate_Account; 351 352 -- Function Accumulate_Reserve performs a dispatching call on a 353 -- primitive operation that has been defined for the root type and 354 -- inherited by each derived type. 355 356 function Accumulate_Reserve (Acct : in Accounts.Bank_Account'Class) 357 return Dollar_Amount is 358 begin 359 -- Dispatch according to tag. 360 return (Accounts.Increment_Bank_Reserve (Acct)); 361 end Accumulate_Reserve; 362 363 -- Procedure Resolve_Dispute performs a dispatching call on a primitive 364 -- operation that has been defined in the root type, overridden in the 365 -- first derived extended type, and inherited by the subsequent extended 366 -- type. 367 368 procedure Resolve_Dispute (Acct : in Accounts.Bank_Account'Class) is 369 begin 370 -- Dispatch according to tag. 371 Daily_Representative := Accounts.Assign_Representative (Acct); 372 end Resolve_Dispute; 373 374 --=================================================================-- 375 376 begin -- Main test procedure. 377 378 Report.Test ("C392003", "Check that the use of a class-wide parameter " & 379 "allows for proper dispatching where root type " & 380 "is declared in a nested package, and " & 381 "subsequent extended types are derived in " & 382 "further nested packages" ); 383 384 Bank_Account_Subtest: 385 begin 386 Accounts.Open (B_Account); 387 388 -- Demonstrate class-wide parameter allowing dispatch by a primitive 389 -- operation that has been defined for this specific type. 390 Bank_Reserve := Accumulate_Reserve (Acct => B_Account); 391 Tabulate_Account (B_Account); 392 393 if (Bank_Reserve /= Opening_Balance) or 394 (Number_Of_Accounts (Bank) /= 1) or 395 (Number_Of_Accounts (Total) /= 1) 396 then 397 Report.Failed ("Failed in Bank_Account_Subtest"); 398 end if; 399 400 end Bank_Account_Subtest; 401 402 403 Savings_Account_Subtest: 404 begin 405 Accounts.S_And_L.Open (Acct => S_Account); 406 407 -- Demonstrate class-wide parameter allowing dispatch by a primitive 408 -- operation that has been overridden for this extended type. 409 Resolve_Dispute (Acct => S_Account); 410 Tabulate_Account (S_Account); 411 412 if (Daily_Representative /= Manager) or 413 (Number_Of_Accounts (Savings) /= 1) or 414 (Number_Of_Accounts (Total) /= 2) 415 then 416 Report.Failed ("Failed in Savings_Account_Subtest"); 417 end if; 418 419 end Savings_Account_Subtest; 420 421 422 423 Preferred_Account_Subtest: 424 begin 425 Accounts.S_And_L.Premium.Open (P_Account); 426 427 -- Verify that the correct implementation of Open (overridden) was 428 -- used for the Preferred_Account object. 429 if not Accounts.S_And_L.Premium.Verify_Open (P_Account) then 430 Report.Failed ("Incorrect values for init. Preferred Acct object"); 431 end if; 432 433 -- Demonstrate class-wide parameter allowing dispatch by a primitive 434 -- operation that has been twice inherited by this extended type. 435 Bank_Reserve := Accumulate_Reserve (Acct => P_Account); 436 437 -- Demonstrate class-wide parameter allowing dispatch by a primitive 438 -- operation that has been overridden for this extended type (the 439 -- operation was overridden by its parent type as well). 440 Tabulate_Account (P_Account); 441 442 if Bank_Reserve /= 1100.00 or 443 Number_Of_Accounts (Preferred) /= 1 or 444 Number_Of_Accounts (Total) /= 3 445 then 446 Report.Failed ("Failed in Preferred_Account_Subtest"); 447 end if; 448 449 end Preferred_Account_Subtest; 450 451 Report.Result; 452 453 end C392003; 454