-- C392003.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 the use of a class-wide formal parameter allows for the -- proper dispatching of objects to the appropriate implementation of -- a primitive operation. Check this where the root tagged type is -- defined in a package, and the extended type is defined in a nested -- package. -- -- TEST DESCRIPTION: -- Declare a root tagged type, and some associated primitive operations. -- Extend the root type, and override one or more primitive operations, -- inheriting the other primitive operations from the root type. -- Derive from the extended type, again overriding some primitive -- operations and inheriting others (including some that the parent -- inherited). -- Define a subprogram with a class-wide parameter, inside of which is a -- call on a dispatching primitive operation. These primitive operations -- modify global variables (the class-wide parameter has mode IN). -- -- -- -- The following hierarchy of tagged types and primitive operations is -- utilized in this test: -- -- type Bank_Account (root) -- | -- | Operations -- | Increment_Bank_Reserve -- | Assign_Representative -- | Increment_Counters -- | Open -- | -- type Savings_Account (extended from Bank_Account) -- | -- | Operations -- | (Increment_Bank_Reserve) (inherited) -- | Assign_Representative (overridden) -- | Increment_Counters (overridden) -- | Open (overridden) -- | -- type Preferred_Account (extended from Savings_Account) -- | -- | Operations -- | (Increment_Bank_Reserve) (inherited twice - Bank_Acct.) -- | (Assign_Representative) (inherited - Savings_Acct.) -- | Increment_Counters (overridden) -- | Open (overridden) -- -- -- In this test, we are concerned with the following selection of dispatching -- calls, accomplished with the use of a Bank_Account'Class IN procedure -- parameter : -- -- \ Type -- Prim. Op \ Bank_Account Savings_Account Preferred_Account -- \------------------------------------------------ -- Increment_Bank_Reserve| X X -- Assign_Representative | X -- Increment_Counters | X X X -- -- -- -- The location of the declaration and derivation of the root and extended -- types will be varied over a series of tests. Locations of declaration -- and derivation for a particular test are marked with an asterisk (*). -- -- Root type: -- -- * Declared in package. -- Declared in generic package. -- -- Extended types: -- -- Derived in parent location. -- * Derived in a nested package. -- Derived in a nested subprogram. -- Derived in a nested generic package. -- Derived in a separate package. -- Derived in a separate visible child package. -- Derived in a separate private child package. -- -- Primitive Operations: -- -- * Procedures with same parameter profile. -- Procedures with different parameter profile. -- * Functions with same parameter profile. -- Functions with different parameter profile. -- * Mixture of Procedures and Functions. -- -- -- CHANGE HISTORY: -- 06 Dec 94 SAIC ACVC 2.0 -- --! with Report; procedure C392003 is -- -- Types and subtypes. -- type Dollar_Amount is new float; type Interest_Rate is delta 0.001 range 0.000 .. 1.000; type Account_Types is (Bank, Savings, Preferred, Total); type Account_Counter is array (Account_Types) of integer; type Account_Rep is (President, Manager, New_Account_Manager, Teller); -- -- Constants. -- Opening_Balance : constant Dollar_Amount := 100.00; Current_Rate : constant Interest_Rate := 0.030; Preferred_Minimum_Balance : constant Dollar_Amount := 1000.00; -- -- Global Variables -- Bank_Reserve : Dollar_Amount := 0.00; Daily_Representative : Account_Rep := New_Account_Manager; Number_Of_Accounts : Account_Counter := (Bank => 0, Savings => 0, Preferred => 0, Total => 0); -- Root tagged type and primitive operations declared in internal -- package (Accounts). -- Extended types (and primitive operations) derived in nested packages. --=================================================================-- package Accounts is -- -- Root account type and primitive operations. -- -- Root type. type Bank_Account is tagged record Balance : Dollar_Amount; end record; -- Primitive operations of Bank_Account. function Increment_Bank_Reserve (Acct : in Bank_Account) return Dollar_Amount; function Assign_Representative (Acct : in Bank_Account) return Account_Rep; procedure Increment_Counters (Acct : in Bank_Account); procedure Open (Acct : in out Bank_Account); --=================================================================-- package S_And_L is -- Declare extended type in a nested package. type Savings_Account is new Bank_Account with record Rate : Interest_Rate; end record; -- Function Increment_Bank_Reserve inherited from -- parent (Bank_Account). -- Primitive operations (Overridden). function Assign_Representative (Acct : in Savings_Account) return Account_Rep; procedure Increment_Counters (Acct : in Savings_Account); procedure Open (Acct : in out Savings_Account); --=================================================================-- package Premium is -- Declare further extended type in a nested package. type Preferred_Account is new Savings_Account with record Minimum_Balance : Dollar_Amount; end record; -- Function Increment_Bank_Reserve inherited twice. -- Function Assign_Representative inherited from parent -- (Savings_Account). -- Primitive operation (Overridden). procedure Increment_Counters (Acct : in Preferred_Account); procedure Open (Acct : in out Preferred_Account); -- Function used to verify Open operation for Preferred_Account -- objects. function Verify_Open (Acct : in Preferred_Account) return Boolean; end Premium; end S_And_L; end Accounts; --=================================================================-- package body Accounts is -- -- Primitive operations for Bank_Account. -- function Increment_Bank_Reserve (Acct : in Bank_Account) return Dollar_Amount is begin return (Bank_Reserve + Acct.Balance); end Increment_Bank_Reserve; function Assign_Representative (Acct : in Bank_Account) return Account_Rep is begin return Account_Rep'(Teller); end Assign_Representative; procedure Increment_Counters (Acct : in Bank_Account) is begin Number_Of_Accounts (Bank) := Number_Of_Accounts (Bank) + 1; Number_Of_Accounts (Total) := Number_Of_Accounts (Total) + 1; end Increment_Counters; procedure Open (Acct : in out Bank_Account) is begin Acct.Balance := Opening_Balance; end Open; --=================================================================-- package body S_And_L is -- -- Overridden operations for Savings_Account type. -- function Assign_Representative (Acct : in Savings_Account) return Account_Rep is begin return (Manager); end Assign_Representative; procedure Increment_Counters (Acct : in Savings_Account) is begin Number_Of_Accounts (Savings) := Number_Of_Accounts (Savings) + 1; Number_Of_Accounts (Total) := Number_Of_Accounts (Total) + 1; end Increment_Counters; procedure Open (Acct : in out Savings_Account) is begin Open (Bank_Account(Acct)); Acct.Rate := Current_Rate; Acct.Balance := 2.0 * Opening_Balance; end Open; --=================================================================-- package body Premium is -- -- Overridden operations for Preferred_Account type. -- procedure Increment_Counters (Acct : in Preferred_Account) is begin Number_Of_Accounts (Preferred) := Number_Of_Accounts (Preferred) + 1; Number_Of_Accounts (Total) := Number_Of_Accounts (Total) + 1; end Increment_Counters; procedure Open (Acct : in out Preferred_Account) is begin Open (Savings_Account(Acct)); Acct.Minimum_Balance := Preferred_Minimum_Balance; Acct.Balance := Acct.Minimum_Balance; end Open; -- -- Function used to verify Open operation for Preferred_Account -- objects. -- function Verify_Open (Acct : in Preferred_Account) return Boolean is begin return (Acct.Balance = Preferred_Minimum_Balance and Acct.Rate = Current_Rate and Acct.Minimum_Balance = Preferred_Minimum_Balance); end Verify_Open; end Premium; end S_And_L; end Accounts; --=================================================================-- -- Declare account objects. B_Account : Accounts.Bank_Account; S_Account : Accounts.S_And_L.Savings_Account; P_Account : Accounts.S_And_L.Premium.Preferred_Account; -- Procedures to operate on accounts. -- Each uses a class-wide IN parameter, as well as a call to a -- dispatching operation. -- Function Tabulate_Account performs a dispatching call on a primitive -- operation that has been overridden for each of the extended types. procedure Tabulate_Account (Acct : in Accounts.Bank_Account'Class) is begin Accounts.Increment_Counters (Acct); -- Dispatch according to tag. end Tabulate_Account; -- Function Accumulate_Reserve performs a dispatching call on a -- primitive operation that has been defined for the root type and -- inherited by each derived type. function Accumulate_Reserve (Acct : in Accounts.Bank_Account'Class) return Dollar_Amount is begin -- Dispatch according to tag. return (Accounts.Increment_Bank_Reserve (Acct)); end Accumulate_Reserve; -- Procedure Resolve_Dispute performs a dispatching call on a primitive -- operation that has been defined in the root type, overridden in the -- first derived extended type, and inherited by the subsequent extended -- type. procedure Resolve_Dispute (Acct : in Accounts.Bank_Account'Class) is begin -- Dispatch according to tag. Daily_Representative := Accounts.Assign_Representative (Acct); end Resolve_Dispute; --=================================================================-- begin -- Main test procedure. Report.Test ("C392003", "Check that the use of a class-wide parameter " & "allows for proper dispatching where root type " & "is declared in a nested package, and " & "subsequent extended types are derived in " & "further nested packages" ); Bank_Account_Subtest: begin Accounts.Open (B_Account); -- Demonstrate class-wide parameter allowing dispatch by a primitive -- operation that has been defined for this specific type. Bank_Reserve := Accumulate_Reserve (Acct => B_Account); Tabulate_Account (B_Account); if (Bank_Reserve /= Opening_Balance) or (Number_Of_Accounts (Bank) /= 1) or (Number_Of_Accounts (Total) /= 1) then Report.Failed ("Failed in Bank_Account_Subtest"); end if; end Bank_Account_Subtest; Savings_Account_Subtest: begin Accounts.S_And_L.Open (Acct => S_Account); -- Demonstrate class-wide parameter allowing dispatch by a primitive -- operation that has been overridden for this extended type. Resolve_Dispute (Acct => S_Account); Tabulate_Account (S_Account); if (Daily_Representative /= Manager) or (Number_Of_Accounts (Savings) /= 1) or (Number_Of_Accounts (Total) /= 2) then Report.Failed ("Failed in Savings_Account_Subtest"); end if; end Savings_Account_Subtest; Preferred_Account_Subtest: begin Accounts.S_And_L.Premium.Open (P_Account); -- Verify that the correct implementation of Open (overridden) was -- used for the Preferred_Account object. if not Accounts.S_And_L.Premium.Verify_Open (P_Account) then Report.Failed ("Incorrect values for init. Preferred Acct object"); end if; -- Demonstrate class-wide parameter allowing dispatch by a primitive -- operation that has been twice inherited by this extended type. Bank_Reserve := Accumulate_Reserve (Acct => P_Account); -- Demonstrate class-wide parameter allowing dispatch by a primitive -- operation that has been overridden for this extended type (the -- operation was overridden by its parent type as well). Tabulate_Account (P_Account); if Bank_Reserve /= 1100.00 or Number_Of_Accounts (Preferred) /= 1 or Number_Of_Accounts (Total) /= 3 then Report.Failed ("Failed in Preferred_Account_Subtest"); end if; end Preferred_Account_Subtest; Report.Result; end C392003;