1-- C341A04.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 class-wide objects can be initialized using allocation. 28 -- 29 -- TEST DESCRIPTION: 30 -- Declare access types that refer to class-wide types, one with basis 31 -- of the root type, another with basis of a type extended from the root. 32 -- Declare objects of these access types, and allocate class-wide 33 -- objects, initialized to values of specific types within the particular 34 -- classes. 35 -- 36 -- The particular root and extended types used in this abstraction are 37 -- defined in foundation code (F341A00.A), and are graphically displayed 38 -- as follows: 39 -- 40 -- package Bank 41 -- type Account 42 -- | 43 -- | 44 -- | 45 -- package Checking 46 -- type Account 47 -- | 48 -- | 49 -- | 50 -- package Interest_Checking 51 -- type Account 52 -- 53 -- TEST FILES: 54 -- This test depends on the following foundation code: 55 -- 56 -- F341A00.A 57 -- 58 -- The following files comprise this test: 59 -- 60 -- => C341A04.A 61 -- 62 -- 63-- CHANGE HISTORY: 64-- 06 Dec 94 SAIC ACVC 2.0 65-- 66 --! 67 68 with F341A00_0; -- package Bank 69 with F341A00_1; -- package Checking 70 with F341A00_2; -- package Interest_Checking 71 with Report; 72 73 procedure C341A04 is 74 75 package Bank renames F341A00_0; 76 package Checking renames F341A00_1; 77 package Interest_Checking renames F341A00_2; 78 79 use type Bank.Dollar_Amount; 80 81 Max_Accts : constant := 3; 82 Bank_Balance : Bank.Dollar_Amount := 0.00; 83 84 -- Define access types referring to class of types rooted at 85 -- Bank.Account (root). 86 87 type Bank_Account_Pointer is access Bank.Account'Class; 88 89 -- 90 -- Define class-wide objects, initializing them through allocation. 91 -- 92 93 -- Initialized to specific type that is basis of class. 94 Bank_Acct : Bank_Account_Pointer := 95 new Bank.Account'(Current_Balance => 10.00); 96 97 -- Initialized to specific type that has been extended from the basis 98 -- of the class. 99 Checking_Acct : Bank_Account_Pointer := 100 new Checking.Account'(Current_Balance => 100.00, 101 Overdraft_Fee => 10.00); 102 103 -- Initialized to specific type that has been twice extended from the 104 -- basis of the class. 105 IC_Acct : Bank_Account_Pointer := 106 new Interest_Checking.Account'(Current_Balance => 1000.00, 107 Overdraft_Fee => 10.00, 108 Rate => 0.030); 109 110 -- Declare and initialize array of pointers to objects of 111 -- Bank.Account'Class. 112 113 Accounts : array (1 .. Max_Accts) of Bank_Account_Pointer := 114 (Bank_Acct, Checking_Acct, IC_Acct); 115 116 117 -- Audit will process any account object within Bank.Account'Class. 118 119 function Audit (Ptr : Bank_Account_Pointer) return Bank.Dollar_Amount is 120 begin 121 return (Ptr.Current_Balance); 122 end Audit; 123 124 125 begin -- C341A04 126 127 Report.Test ("C341A04", "Check that class-wide objects were " & 128 "successfully initialized using allocation" ); 129 130 for i in 1 .. Max_Accts loop 131 Bank_Balance := Bank_Balance + Audit (Accounts(i)); 132 end loop; 133 134 if Bank_Balance /= 1110.00 then 135 Report.Failed ("Failed class-wide object allocation"); 136 end if; 137 138 Report.Result; 139 140 end C341A04; 141 142