c392003.a

来自「用于进行gcc测试」· A 代码 · 共 454 行 · 第 1/2 页

       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;