path: root/gcc/testsuite/ada/acats-4/tests/c3/c391003.a

-- C391003.A
--
--                             Grant of Unlimited Rights
--
--     The Ada Conformity Assessment Authority (ACAA) holds unlimited
--     rights in the software and documentation contained herein. Unlimited
--     rights are the same as those granted by the U.S. Government for older
--     parts of the Ada Conformity Assessment Test Suite, and are defined
--     in DFAR 252.227-7013(a)(19). By making this public release, the ACAA
--     intends to confer upon all recipients unlimited rights equal to those
--     held by the ACAA. 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 ACAA 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.
--
--                                     Notice
--
--     The ACAA has created and maintains the Ada Conformity Assessment Test
--     Suite for the purpose of conformity assessments conducted in accordance
--     with the International Standard ISO/IEC 18009 - Ada: Conformity
--     assessment of a language processor. This test suite should not be used
--     to make claims of conformance unless used in accordance with
--     ISO/IEC 18009 and any applicable ACAA procedures.
--*
--
-- OBJECTIVE:
--      Check that a type can be extended at a different level than the
--      parent type. Check that subprograms overridden for such an extension
--      can be dispatched to, and that the overridden routine can access
--      local variables of the subprogram.
--
-- TEST DESCRIPTION:
--      This test checks that Ada 95 rule of the third sentence of 3.9.1(3)
--      is not enforced for more recent Ada implementations, as it was
--      repealed by AI95-00344-01. It also checks some consequences of that
--      change.
--
--      We declare a root tagged private type Acccount to represent a bank
--      account, and some associated primitive operations, in a visible
--      library package. (This type is based on the one in test C392008.) We
--      also define a Transfer operation that takes two accounts and an amount
--      in that package. That operation is implemented using dispatching calls
--      on the primitive operations of type Account.
--
--      We declare a package containing a normal extension of the type,
--      Interest_Checking. This overrides some of the operations of Account.
--
--      We then define a package containing a wire-transfer subprogram, which
--      extends Account to create a temporary account to hold funds before
--      they are transmitted. We then transfer funds from the base account
--      to the temporary account using Transfer.
--
--      Finally, we have a main program where we create various accounts and
--      try various wire-transfers.
--
-- 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 Interest_Checking                                            |
--      type Account (extended from Bank.Account)                         |
--            |                                                           |
--            \-Operations                                                |
--                  proc Deposit         (inherited)                      |
--                  func Balance         (inherited)                      |
--                  proc Service_Charge  (inherited)                      |
--                  proc Add_Interest    (overridden)                     |
--                  proc Open            (overridden)                     |
--                  proc Withdrawal      (overridden)                     |
--                                                                        |
--   procedure Wire_Transfer----------------------------------------------/
--      type Transfer_Account (extended from Bank.Account)
--            |
--            \-Operations
--                  proc Deposit         (overridden)
--                  proc Withdrawal      (inherited)
--                  func Balance         (inherited)
--                  proc Service_Charge  (inherited)
--                  proc Add_Interest    (inherited)
--                  proc Open            (inherited)
--
-- CHANGE HISTORY:
--    08 Jan 2015  RLB  Created test.
--    13 Mar 2015  RLB  Eliminated overlong line.
--
--!

----------------------------------------------------------------- C391003_0

package C391003_0 is           -- package Bank

  type Dollar_Amount is range -300_00..300_00;

   type Account is tagged private;

   -- 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);

   procedure Transfer (Source, Target : in out Account'Class;
                       Amount : Dollar_Amount);

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

end C391003_0;

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

package body C391003_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 := 00_00;
   begin
      A.Current_Balance := Initial_Deposit;
   end Open;

   procedure Transfer (Source, Target : in out Account'Class;
                       Amount : Dollar_Amount) is
      Transfer_Fee : constant Dollar_Amount := 2_00;
   begin
      Withdrawal (Source, Amount); -- Dispatching call.
      Withdrawal (Source, Transfer_Fee); -- Dispatching call.
      Deposit    (Target, Amount); -- Dispatching call.
   end Transfer;

end C391003_0;

----------------------------------------------------------------- C391003_1

with C391003_0;             -- with Bank;

package C391003_1 is     -- package Interest_Checking

   package Bank     renames C391003_0;

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

   Current_Rate : Interest_Rate := 0_02;

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

   overriding
   procedure Add_Interest (A : in out Account);

   overriding
   procedure Open         (A : in out Account);

   overriding
   procedure Withdrawal     (A : in out Account;
                             X : in     Bank.Dollar_Amount);

   -- Inherited primitive operations (from Bank.Account)
   -- procedure Deposit        (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 C391003_1;

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

package body C391003_1 is

   -- Overridden primitive operations.

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

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

   procedure Withdrawal     (A : in out Account;
                             X : in     Bank.Dollar_Amount) is
      use type Bank.Dollar_Amount;
   begin
      if X < A.Balance then
         Bank.Withdrawal (Bank.Account(A), X);
      else -- apply overdraft fee.
         Bank.Withdrawal (Bank.Account(A), X);
         Bank.Withdrawal (Bank.Account(A), A.Overdraft_Fee);
      end if;
   end Withdrawal;

end C391003_1;

----------------------------------------------------------------- C391003_2

with C391003_0;             -- with Bank;

package C391003_2 is     -- package Wire_Transfers

   package Bank     renames C391003_0;

   type Account_Kind is (Basic, Premium, Platinum);

   Transfer_Failed : exception;

   procedure Wire_Transfer (Source : in out Bank.Account'Class;
                            Amount : in     Bank.Dollar_Amount;
                            Kind   : in     Account_Kind);

end C391003_2;

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

with Report;
package body C391003_2 is

   use type Bank.Dollar_Amount;

   procedure Wire_Transfer (Source : in out Bank.Account'Class;
                            Amount : in     Bank.Dollar_Amount;
                            Kind   : in     Account_Kind) is

      Minimum_Xfer : Bank.Dollar_Amount;
      Maximum_Xfer : Bank.Dollar_Amount;

      type Transfer_Account is new Bank.Account with null record;

      overriding
      procedure Deposit    (A : in out Transfer_Account;
                            X : in     Bank.Dollar_Amount) is
      begin
         Bank.Deposit (Bank.Account(A), X);
         if A.Balance < Minimum_Xfer then
             raise Transfer_Failed with "Too little transferred";
         elsif A.Balance > Maximum_Xfer then
             --raise Transfer_Failed with "Too much transferred";
             Report.Failed ("Too much transferred, limit=" &
                Bank.Dollar_Amount'Image(Maximum_Xfer) &
                "; Balance=" & Bank.Dollar_Amount'Image(A.Balance));
         else
             null; -- Transmit money via ACH.
         end if;
      end Deposit;

      Xfer_Acct : Transfer_Account;

   begin
      case Kind is
         when Basic =>
            Minimum_Xfer :=   25_00;
            Maximum_Xfer :=  100_00;
         when Premium =>
            Minimum_Xfer :=   12_00;
            Maximum_Xfer :=  200_00;
         when Platinum =>
            Minimum_Xfer :=   10_00;
            Maximum_Xfer :=  300_00;
      end case;
      Open (Xfer_Acct); -- Zeros balance.

      Bank.Transfer (Source => Source,
                     Target => Xfer_Acct,
                     Amount => Amount);

      if Balance (Xfer_Acct) /= Amount then
         Report.Failed ("Wrong balance transferred - Balance=" &
            Bank.Dollar_Amount'Image(Balance (Xfer_Acct)));
      end if;
   end Wire_Transfer;

end C391003_2;

------------------------------------------------------------------- C391003

with C391003_0;    use C391003_0;        -- package Bank
with C391003_1;    use C391003_1;        -- package Interest_Checking;
with C391003_2;    use C391003_2;        -- package Wire_Transfer;
with Report;
with Ada.Exceptions;

procedure C391003 is

   package Bank              renames C391003_0;
   package Interest_Checking renames C391003_1;
   package Wire_Transfers    renames C391003_2;

   B_Acct  : Bank.Account;
   IC_Acct, IC_Acct2 : Interest_Checking.Account;

begin

   Report.Test ("C391003",  "Check that a type can be extended at a " &
                             "different level than the parent type. Check " &
                             "that subprograms overridden for such an " &
                             "extension can be dispatched to, and that the " &
                             "overridden routine can access local variables " &
                             "of the subprogram");

   Open (B_Acct);
   Deposit (B_Acct, 250_00);

   Open (IC_Acct);
   Deposit (IC_Acct, 30_00);  --+20_00 initial deposit.

   Open (IC_Acct2);
   Deposit (IC_Acct2, 280_00); --+20_00 initial deposit.

   -- Try a wire transfer for a platinum account:
   Wire_Transfer (IC_Acct, Amount => 23_00, Kind => Platinum);

   if Balance (IC_Acct) /= 25_00 then
      Report.Failed ("Wrong balance in account after transfer");
   end if;

   -- Try a wire transfer for a premium account:
   Wire_Transfer (IC_Acct2, Amount => 200_00, Kind => Premium);

   if Balance (IC_Acct2) /= 98_00 then
      Report.Failed ("Wrong balance in account after transfer");
   end if;

   -- Try a too-small transfer for a basic account:
   begin
      Wire_Transfer (B_Acct, Amount => 14_00, Kind => Basic);
         -- Should raise Transfer_Failed.
      Report.Failed ("Failed transfer not detected (probably did not " &
           "dispatch to overridden Deposit)");

   exception
      when Wire_Transfers.Transfer_Failed => null;
   end;

   Report.Result;

exception
    when Err:others =>
        Report.Failed ("Stray exception: " &
                        Ada.Exceptions.Exception_Information (Err));
end C391003;