diff options
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392003.a')
| -rw-r--r-- | gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392003.a | 453 |
1 files changed, 453 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392003.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392003.a new file mode 100644 index 000000000..d7c5be228 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392003.a @@ -0,0 +1,453 @@ +-- 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; |