tests/c3/c392008.a

-- C392008.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 for the case where the root tagged
--      type is defined in a package and the extended type is defined in a
--      dependent package.
--
-- TEST DESCRIPTION:
--      Declare a root tagged type, and some associated primitive operations,
--      in a visible library package.
--      Extend the root type in another visible library package, and override
--      one or more primitive operations, inheriting the other primitive
--      operations from the root type.
--      Derive from the extended type in yet another visible library package,
--      again overriding some primitive operations and inheriting others
--      (including some that the parent inherited).
--      Define subprograms with class-wide parameters, inside of which is a
--      call on a dispatching primitive operation.  These primitive
--      operations modify the objects of the specific class passed as actuals
--      to the class-wide formal parameter (class-wide formal parameter has
--      mode IN OUT).
--
-- The following hierarchy of tagged types and primitive operations is
-- utilized in this test:
--
--   package Bank
--      type Account (root)
--            |
--            | Operations
--            |     proc Deposit
--            |     proc Withdrawal
--            |     func Balance
--            |     proc Service_Charge
--            |     proc Add_Interest
--            |     proc Open
--            |
--   package Checking
--      type Account (extended from Bank.Account)
--            |
--            | Operations
--            |     proc Deposit         (inherited)
--            |     proc Withdrawal      (inherited)
--            |     func Balance         (inherited)
--            |     proc Service_Charge  (inherited)
--            |     proc Add_Interest    (inherited)
--            |     proc Open            (overridden)
--            |
--   package Interest_Checking
--      type Account (extended from Checking.Account)
--            |
--            | Operations
--            |     proc Deposit         (inherited twice - Bank.Acct.)
--            |     proc Withdrawal      (inherited twice - Bank.Acct.)
--            |     func Balance         (inherited twice - Bank.Acct.)
--            |     proc Service_Charge  (inherited twice - Bank.Acct.)
--            |     proc Add_Interest    (overridden)
--            |     proc 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 OUT formal
-- parameter :
--
--                \ Type
--        Prim. Op \  Bank.Account  Checking.Account Interest_Checking.Account
--                  \---------------------------------------------------------

--   Service_Charge |      X                X                 X
--   Add_Interest   |      X                X                 X
--   Open           |      X                X                 X
--
--
--
-- The location of the declaration of the root and derivation of 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.
--
--
-- TEST FILES:
--      This test depends on the following foundation code:
--
--         C392008_0.A
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--      20 Nov 95   SAIC    C392B04 became C392008 for ACVC 2.0.1
--
--!

----------------------------------------------------------------- C392008_0

package C392008_0 is           -- package Bank

  type Dollar_Amount is range -30_000..30_000;

   type Account is tagged
      record
        Current_Balance: Dollar_Amount;
      end record;

   -- Primitive operations.

   procedure Deposit        (A : in out Account;
                             X : in     Dollar_Amount);
   procedure Withdrawal     (A : in out Account;
                             X : in     Dollar_Amount);
   function  Balance        (A : in     Account) return Dollar_Amount;
   procedure Service_Charge (A : in out Account);
   procedure Add_Interest   (A : in out Account);
   procedure Open           (A : in out Account);

end C392008_0;

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

package body C392008_0 is

   -- Primitive operations for type Account.

   procedure Deposit (A : in out Account;
                      X : in     Dollar_Amount) is
   begin
      A.Current_Balance := A.Current_Balance + X;
   end Deposit;

   procedure Withdrawal(A : in out Account;
                        X : in     Dollar_Amount) is
   begin
      A.Current_Balance := A.Current_Balance - X;
   end Withdrawal;

   function  Balance (A : in     Account) return Dollar_Amount is
   begin
      return (A.Current_Balance);
   end Balance;

   procedure Service_Charge (A : in out Account) is
   begin
      A.Current_Balance := A.Current_Balance - 5_00;
   end Service_Charge;

   procedure Add_Interest (A : in out Account) is
      Interest_On_Account : Dollar_Amount := 0_00;
   begin
      A.Current_Balance := A.Current_Balance + Interest_On_Account;
   end Add_Interest;

   procedure Open (A : in out Account) is
      Initial_Deposit : Dollar_Amount := 10_00;
   begin
      A.Current_Balance := Initial_Deposit;
   end Open;

end C392008_0;

----------------------------------------------------------------- C392008_1

with C392008_0;              -- package Bank

package C392008_1 is      -- package Checking

   package Bank renames C392008_0;

   type Account is new Bank.Account with
      record
         Overdraft_Fee : Bank.Dollar_Amount;
      end record;

   -- Overridden primitive operation.

   procedure Open (A : in out Account);

   -- Inherited primitive operations.
   -- procedure Deposit        (A : in out Account;
   --                           X : in     Bank.Dollar_Amount);
   -- procedure Withdrawal     (A : in out Account;
   --                           X : in     Bank.Dollar_Amount);
   -- function  Balance        (A : in     Account) return Bank.Dollar_Amount;
   -- procedure Service_Charge (A : in out Account);
   -- procedure Add_Interest   (A : in out Account);

end C392008_1;

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

package body C392008_1 is

   -- Overridden primitive operation.

   procedure Open (A : in out Account) is
      Check_Guarantee : Bank.Dollar_Amount := 10_00;
      Initial_Deposit : Bank.Dollar_Amount := 20_00;
   begin
      A.Current_Balance := Initial_Deposit;
      A.Overdraft_Fee   := Check_Guarantee;
   end Open;

end C392008_1;

----------------------------------------------------------------- C392008_2

with C392008_0;             -- with Bank;
with C392008_1;          -- with Checking;

package C392008_2 is     -- package Interest_Checking

   package Bank     renames C392008_0;
   package Checking renames C392008_1;

   subtype Interest_Rate is Bank.Dollar_Amount range 0..100; -- was digits 4;

   Current_Rate : Interest_Rate := 0_02;

   type Account is new Checking.Account with
      record
         Rate : Interest_Rate;
      end record;

   -- Overridden primitive operations.

   procedure Add_Interest (A : in out Account);
   procedure Open         (A : in out Account);

   -- "Twice" inherited primitive operations (from Bank.Account)
   -- procedure Deposit        (A : in out Account;
   --                           X : in     Bank.Dollar_Amount);
   -- procedure Withdrawal     (A : in out Account;
   --                           X : in     Bank.Dollar_Amount);
   -- function  Balance        (A : in     Account) return Bank.Dollar_Amount;
   -- procedure Service_Charge (A : in out Account);

end C392008_2;

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

package body C392008_2 is

   -- Overridden primitive operations.

   procedure Add_Interest (A : in out Account) is
      Interest_On_Account : Bank.Dollar_Amount
        := Bank.Dollar_Amount( Bank."*"( A.Current_Balance, A.Rate ));
   begin
      A.Current_Balance := Bank."+"( A.Current_Balance, Interest_On_Account);
   end Add_Interest;

   procedure Open (A : in out Account) is
      Initial_Deposit : Bank.Dollar_Amount := 30_00;
   begin
      Checking.Open (Checking.Account (A));
      A.Current_Balance := Initial_Deposit;
      A.Rate            := Current_Rate;
   end Open;

end C392008_2;

------------------------------------------------------------------- C392008

with C392008_0;    use C392008_0;          -- package Bank
with C392008_1;    use C392008_1;        -- package Checking;
with C392008_2;    use C392008_2;        -- package Interest_Checking;
with Report;

procedure C392008 is

   package Bank              renames C392008_0;
   package Checking          renames C392008_1;
   package Interest_Checking renames C392008_2;

   B_Acct  : Bank.Account;
   C_Acct  : Checking.Account;
   IC_Acct : Interest_Checking.Account;

   --
   -- Define procedures with class-wide formal parameters of mode IN OUT.
   --

   -- This procedure will perform a dispatching call on the
   -- overridden primitive operation Open.

   procedure New_Account (Acct : in out Bank.Account'Class) is
   begin
      Open (Acct);  -- Dispatch according to tag of class-wide parameter.
   end New_Account;

   -- This procedure will perform a dispatching call on the inherited
   -- primitive operation (for all types derived from the root Bank.Account)
   -- Service_Charge.

   procedure Apply_Service_Charge (Acct: in out Bank.Account'Class) is
   begin
      Service_Charge (Acct);  -- Dispatch according to tag of class-wide parm.
   end Apply_Service_Charge;

   -- This procedure will perform a dispatching call on the
   -- inherited/overridden primitive operation Add_Interest.

   procedure Annual_Interest (Acct: in out Bank.Account'Class) is
   begin
      Add_Interest (Acct);  -- Dispatch according to tag of class-wide parm.
   end Annual_Interest;

begin

   Report.Test ("C392008",  "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 the dispatch to primitive operations overridden for each
   -- extended type.
   New_Account (B_Acct);
   New_Account (C_Acct);
   New_Account (IC_Acct);

   if (B_Acct.Current_Balance  /= 10_00) or
      (C_Acct.Current_Balance  /= 20_00) or
      (IC_Acct.Current_Balance /= 30_00)
   then
      Report.Failed ("Failed dispatch to multiply overridden prim. oper.");
   end if;


   Annual_Interest (B_Acct);
   Annual_Interest (C_Acct);
   Annual_Interest (IC_Acct); -- Check the dispatch to primitive operation
                              -- overridden from a parent type which inherited
                              -- the operation from the root type.
   if (B_Acct.Current_Balance  /= 10_00) or
      (C_Acct.Current_Balance  /= 20_00) or
      (IC_Acct.Current_Balance /= 90_00)
   then
      Report.Failed ("Failed dispatch to overridden primitive operation");
   end if;


   Apply_Service_Charge (Acct => B_Acct);
   Apply_Service_Charge (Acct => C_Acct);
   Apply_Service_Charge (Acct => IC_Acct); -- Check the dispatch to a
                                           -- primitive operation twice
                                           -- inherited from the root
                                           -- tagged type.
   if (B_Acct.Current_Balance  /=  5_00) or
      (C_Acct.Current_Balance  /= 15_00) or
      (IC_Acct.Current_Balance /= 85_00)
   then
      Report.Failed ("Failed dispatch to Apply_Service_Charge");
   end if;

   Report.Result;

end C392008;