aboutsummaryrefslogtreecommitdiff
path: root/gcc/testsuite/ada/acats/tests/c3/c392003.a
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c3/c392003.a')
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392003.a453
1 files changed, 0 insertions, 453 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392003.a b/gcc/testsuite/ada/acats/tests/c3/c392003.a
deleted file mode 100644
index d7c5be22867..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392003.a
+++ /dev/null
@@ -1,453 +0,0 @@
--- 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;
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-23 17:28:23 +0000