path: root/gcc/testsuite/ada/acats/tests/c3/c392a01.a

-- C392A01.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 root tagged type defined
 --      in a package, and the extended type is defined in that same 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               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.
 --
 --
 -- TEST FILES:
 --      This test depends on the following foundation code:
 --
 --         F392A00.A
 --
 --      The following files comprise this test:
 --
 --      => C392A01.A
 --
 --
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--
 --!
 
 with F392A00;         -- package Accounts
 with Report;
 
 procedure C392A01 is
 
    package Accounts renames F392A00;
 
    -- Declare account objects.
 
    B_Account : Accounts.Bank_Account;
    S_Account : Accounts.Savings_Account;
    P_Account : Accounts.Preferred_Account;
 
    -- Procedures to operate on accounts.
    -- Each uses a class-wide IN parameter, as well as a call to a
    -- dispatching operation.
 
    -- Procedure 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;
 
 
    -- Procedure Accumulate_Reserve performs a dispatching call on a
    -- primitive operation that has been defined for the root type and 
    -- inherited by each derived type.
 
    procedure Accumulate_Reserve (Acct : in Accounts.Bank_Account'Class) is
    begin
       Accounts.Increment_Bank_Reserve (Acct);   -- Dispatch according to tag.
    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
       Accounts.Assign_Representative (Acct);   -- Dispatch according to tag.
    end Resolve_Dispute;
 
 
 
 begin  -- Main test procedure.
 
    Report.Test ("C392A01", "Check that the use of a class-wide parameter "   &
                             "allows for proper dispatching where root type " &
                             "and extended types are declared in the same "   &
                             "package" );
    
    Bank_Account_Subtest:
    declare
      use Accounts;
    begin
       Accounts.Open (B_Account);
 
       -- Demonstrate class-wide parameter allowing dispatch by a primitive
       -- operation that has been defined for this specific type.
       Accumulate_Reserve (Acct => B_Account);
       Tabulate_Account (B_Account);
 
       if (Accounts.Bank_Reserve /= Accounts.Opening_Balance) or
          (Accounts.Number_Of_Accounts (Bank) /= 1)           or
          (Accounts.Number_Of_Accounts (Total) /= 1)
       then
          Report.Failed ("Failed in Bank_Account_Subtest");
       end if;
 
    end Bank_Account_Subtest;
 
 
    Savings_Account_Subtest:
    declare
      use Accounts;
    begin
       Accounts.Open (Acct => S_Account);
 
       -- Demonstrate class-wide parameter allowing dispatch by a primitive
       -- operation that has been inherited by this extended type.
       Accumulate_Reserve (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 Accounts.Bank_Reserve /= (3.0 * Accounts.Opening_Balance) or
          Accounts.Daily_Representative /= Accounts.Manager         or
          Accounts.Number_Of_Accounts (Savings) /= 1                or
          Accounts.Number_Of_Accounts (Total) /= 2
       then
          Report.Failed ("Failed in Savings_Account_Subtest");
       end if;
 
    end Savings_Account_Subtest;
 
 
    Preferred_Account_Subtest:
    declare
      use Accounts;
    begin
       Accounts.Open (P_Account);
 
       -- Verify that the correct implementation of Open (overridden) was 
       -- used for the Preferred_Account object.
       if not Accounts.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.
       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 Accounts.Bank_Reserve /= 1300.00             or
          Accounts.Number_Of_Accounts (Preferred) /= 1 or
          Accounts.Number_Of_Accounts (Total) /= 3
       then
          Report.Failed ("Failed in Preferred_Account_Subtest");
       end if;
 
    end Preferred_Account_Subtest;
 
 
    Report.Result;
 
 end C392A01;