Subversion Repositories openrisc_me

-- C392003.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 where the root tagged type is

--      defined in a package, and the extended type is defined in a nested

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

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

--

--

-- CHANGE HISTORY:

--      06 Dec 94   SAIC    ACVC 2.0

--

--!

 with Report;

 procedure C392003 is

       --

       -- Types and subtypes.

       --

       type Dollar_Amount  is new float;

       type Interest_Rate  is delta 0.001 range 0.000 .. 1.000;

       type Account_Types  is (Bank, Savings, Preferred, Total);

       type Account_Counter is array (Account_Types) of integer;

       type Account_Rep is (President, Manager, New_Account_Manager, Teller);

       --

       -- Constants.

       --

       Opening_Balance           : constant Dollar_Amount := 100.00;

       Current_Rate              : constant Interest_Rate := 0.030;

       Preferred_Minimum_Balance : constant Dollar_Amount := 1000.00;

       --

       -- Global Variables

       --

       Bank_Reserve         : Dollar_Amount   := 0.00;

       Daily_Representative : Account_Rep     := New_Account_Manager;

       Number_Of_Accounts   : Account_Counter := (Bank      => 0,

                                                  Savings   => 0,

                                                  Preferred => 0,

                                                  Total     => 0);

    -- Root tagged type and primitive operations declared in internal

    -- package (Accounts).

    -- Extended types (and primitive operations) derived in nested packages.

      --=================================================================--

    package Accounts is

       --

       -- Root account type and primitive operations.

       --

       -- Root type.

       type Bank_Account is tagged

          record

             Balance : Dollar_Amount;

          end record;

       -- Primitive operations of Bank_Account.

       function  Increment_Bank_Reserve (Acct : in     Bank_Account)

         return Dollar_Amount;

       function Assign_Representative   (Acct : in     Bank_Account)

         return Account_Rep;

       procedure Increment_Counters     (Acct : in     Bank_Account);

       procedure Open                   (Acct : in out Bank_Account);

      --=================================================================--

       package S_And_L is

          -- Declare extended type in a nested package.

          type Savings_Account is new Bank_Account with

          record

             Rate : Interest_Rate;

          end record;

          -- Function Increment_Bank_Reserve inherited from

          -- parent (Bank_Account).

          -- Primitive operations (Overridden).

          function Assign_Representative (Acct : in     Savings_Account)

            return Account_Rep;

          procedure Increment_Counters   (Acct : in     Savings_Account);

          procedure Open                 (Acct : in out Savings_Account);

      --=================================================================--

          package Premium is

             -- Declare further extended type in a nested package.

             type Preferred_Account is new Savings_Account with

             record

                Minimum_Balance : Dollar_Amount;

             end record;

             -- Function Increment_Bank_Reserve inherited twice.

             -- Function Assign_Representative inherited from parent

             --   (Savings_Account).

             -- Primitive operation (Overridden).

             procedure Increment_Counters (Acct : in     Preferred_Account);

             procedure Open               (Acct : in out Preferred_Account);

             -- Function used to verify Open operation for Preferred_Account

             -- objects.

             function Verify_Open (Acct : in Preferred_Account) return Boolean;

          end Premium;

       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;