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