aboutsummaryrefslogtreecommitdiff
path: root/gcc/testsuite/ada/acats/tests/c3/c392008.a
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c3/c392008.a')
-rw-r--r--gcc/testsuite/ada/acats/tests/c3/c392008.a401
1 files changed, 0 insertions, 401 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392008.a b/gcc/testsuite/ada/acats/tests/c3/c392008.a
deleted file mode 100644
index 27b4e2a8644..00000000000
--- a/gcc/testsuite/ada/acats/tests/c3/c392008.a
+++ /dev/null
@@ -1,401 +0,0 @@
--- C392008.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 case where the root tagged
--- type is defined in a package and the extended type is defined in a
--- dependent package.
---
--- TEST DESCRIPTION:
--- Declare a root tagged type, and some associated primitive operations,
--- in a visible library package.
--- Extend the root type in another visible library package, and override
--- one or more primitive operations, inheriting the other primitive
--- operations from the root type.
--- Derive from the extended type in yet another visible library package,
--- again overriding some primitive operations and inheriting others
--- (including some that the parent inherited).
--- Define subprograms with class-wide parameters, inside of which is a
--- call on a dispatching primitive operation. These primitive
--- operations modify the objects of the specific class passed as actuals
--- to the class-wide formal parameter (class-wide formal parameter has
--- mode IN OUT).
---
--- The following hierarchy of tagged types and primitive operations is
--- utilized in this test:
---
--- package Bank
--- type Account (root)
--- |
--- | Operations
--- | proc Deposit
--- | proc Withdrawal
--- | func Balance
--- | proc Service_Charge
--- | proc Add_Interest
--- | proc Open
--- |
--- package Checking
--- type Account (extended from Bank.Account)
--- |
--- | Operations
--- | proc Deposit (inherited)
--- | proc Withdrawal (inherited)
--- | func Balance (inherited)
--- | proc Service_Charge (inherited)
--- | proc Add_Interest (inherited)
--- | proc Open (overridden)
--- |
--- package Interest_Checking
--- type Account (extended from Checking.Account)
--- |
--- | Operations
--- | proc Deposit (inherited twice - Bank.Acct.)
--- | proc Withdrawal (inherited twice - Bank.Acct.)
--- | func Balance (inherited twice - Bank.Acct.)
--- | proc Service_Charge (inherited twice - Bank.Acct.)
--- | proc Add_Interest (overridden)
--- | proc 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 OUT formal
--- parameter :
---
--- \ Type
--- Prim. Op \ Bank.Account Checking.Account Interest_Checking.Account
--- \---------------------------------------------------------
-
--- Service_Charge | X X X
--- Add_Interest | X X X
--- Open | X X X
---
---
---
--- The location of the declaration of the root and derivation of 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:
---
--- C392008_0.A
---
---
--- CHANGE HISTORY:
--- 06 Dec 94 SAIC ACVC 2.0
--- 20 Nov 95 SAIC C392B04 became C392008 for ACVC 2.0.1
---
---!
-
------------------------------------------------------------------ C392008_0
-
-package C392008_0 is -- package Bank
-
- type Dollar_Amount is range -30_000..30_000;
-
- type Account is tagged
- record
- Current_Balance: Dollar_Amount;
- end record;
-
- -- Primitive operations.
-
- procedure Deposit (A : in out Account;
- X : in Dollar_Amount);
- procedure Withdrawal (A : in out Account;
- X : in Dollar_Amount);
- function Balance (A : in Account) return Dollar_Amount;
- procedure Service_Charge (A : in out Account);
- procedure Add_Interest (A : in out Account);
- procedure Open (A : in out Account);
-
-end C392008_0;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-package body C392008_0 is
-
- -- Primitive operations for type Account.
-
- procedure Deposit (A : in out Account;
- X : in Dollar_Amount) is
- begin
- A.Current_Balance := A.Current_Balance + X;
- end Deposit;
-
- procedure Withdrawal(A : in out Account;
- X : in Dollar_Amount) is
- begin
- A.Current_Balance := A.Current_Balance - X;
- end Withdrawal;
-
- function Balance (A : in Account) return Dollar_Amount is
- begin
- return (A.Current_Balance);
- end Balance;
-
- procedure Service_Charge (A : in out Account) is
- begin
- A.Current_Balance := A.Current_Balance - 5_00;
- end Service_Charge;
-
- procedure Add_Interest (A : in out Account) is
- Interest_On_Account : Dollar_Amount := 0_00;
- begin
- A.Current_Balance := A.Current_Balance + Interest_On_Account;
- end Add_Interest;
-
- procedure Open (A : in out Account) is
- Initial_Deposit : Dollar_Amount := 10_00;
- begin
- A.Current_Balance := Initial_Deposit;
- end Open;
-
-end C392008_0;
-
------------------------------------------------------------------ C392008_1
-
-with C392008_0; -- package Bank
-
-package C392008_1 is -- package Checking
-
- package Bank renames C392008_0;
-
- type Account is new Bank.Account with
- record
- Overdraft_Fee : Bank.Dollar_Amount;
- end record;
-
- -- Overridden primitive operation.
-
- procedure Open (A : in out Account);
-
- -- Inherited primitive operations.
- -- procedure Deposit (A : in out Account;
- -- X : in Bank.Dollar_Amount);
- -- procedure Withdrawal (A : in out Account;
- -- X : in Bank.Dollar_Amount);
- -- function Balance (A : in Account) return Bank.Dollar_Amount;
- -- procedure Service_Charge (A : in out Account);
- -- procedure Add_Interest (A : in out Account);
-
-end C392008_1;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-package body C392008_1 is
-
- -- Overridden primitive operation.
-
- procedure Open (A : in out Account) is
- Check_Guarantee : Bank.Dollar_Amount := 10_00;
- Initial_Deposit : Bank.Dollar_Amount := 20_00;
- begin
- A.Current_Balance := Initial_Deposit;
- A.Overdraft_Fee := Check_Guarantee;
- end Open;
-
-end C392008_1;
-
------------------------------------------------------------------ C392008_2
-
-with C392008_0; -- with Bank;
-with C392008_1; -- with Checking;
-
-package C392008_2 is -- package Interest_Checking
-
- package Bank renames C392008_0;
- package Checking renames C392008_1;
-
- subtype Interest_Rate is Bank.Dollar_Amount range 0..100; -- was digits 4;
-
- Current_Rate : Interest_Rate := 0_02;
-
- type Account is new Checking.Account with
- record
- Rate : Interest_Rate;
- end record;
-
- -- Overridden primitive operations.
-
- procedure Add_Interest (A : in out Account);
- procedure Open (A : in out Account);
-
- -- "Twice" inherited primitive operations (from Bank.Account)
- -- procedure Deposit (A : in out Account;
- -- X : in Bank.Dollar_Amount);
- -- procedure Withdrawal (A : in out Account;
- -- X : in Bank.Dollar_Amount);
- -- function Balance (A : in Account) return Bank.Dollar_Amount;
- -- procedure Service_Charge (A : in out Account);
-
-end C392008_2;
-
--- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-
-package body C392008_2 is
-
- -- Overridden primitive operations.
-
- procedure Add_Interest (A : in out Account) is
- Interest_On_Account : Bank.Dollar_Amount
- := Bank.Dollar_Amount( Bank."*"( A.Current_Balance, A.Rate ));
- begin
- A.Current_Balance := Bank."+"( A.Current_Balance, Interest_On_Account);
- end Add_Interest;
-
- procedure Open (A : in out Account) is
- Initial_Deposit : Bank.Dollar_Amount := 30_00;
- begin
- Checking.Open (Checking.Account (A));
- A.Current_Balance := Initial_Deposit;
- A.Rate := Current_Rate;
- end Open;
-
-end C392008_2;
-
-------------------------------------------------------------------- C392008
-
-with C392008_0; use C392008_0; -- package Bank
-with C392008_1; use C392008_1; -- package Checking;
-with C392008_2; use C392008_2; -- package Interest_Checking;
-with Report;
-
-procedure C392008 is
-
- package Bank renames C392008_0;
- package Checking renames C392008_1;
- package Interest_Checking renames C392008_2;
-
- B_Acct : Bank.Account;
- C_Acct : Checking.Account;
- IC_Acct : Interest_Checking.Account;
-
- --
- -- Define procedures with class-wide formal parameters of mode IN OUT.
- --
-
- -- This procedure will perform a dispatching call on the
- -- overridden primitive operation Open.
-
- procedure New_Account (Acct : in out Bank.Account'Class) is
- begin
- Open (Acct); -- Dispatch according to tag of class-wide parameter.
- end New_Account;
-
- -- This procedure will perform a dispatching call on the inherited
- -- primitive operation (for all types derived from the root Bank.Account)
- -- Service_Charge.
-
- procedure Apply_Service_Charge (Acct: in out Bank.Account'Class) is
- begin
- Service_Charge (Acct); -- Dispatch according to tag of class-wide parm.
- end Apply_Service_Charge;
-
- -- This procedure will perform a dispatching call on the
- -- inherited/overridden primitive operation Add_Interest.
-
- procedure Annual_Interest (Acct: in out Bank.Account'Class) is
- begin
- Add_Interest (Acct); -- Dispatch according to tag of class-wide parm.
- end Annual_Interest;
-
-begin
-
- Report.Test ("C392008", "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 the dispatch to primitive operations overridden for each
- -- extended type.
- New_Account (B_Acct);
- New_Account (C_Acct);
- New_Account (IC_Acct);
-
- if (B_Acct.Current_Balance /= 10_00) or
- (C_Acct.Current_Balance /= 20_00) or
- (IC_Acct.Current_Balance /= 30_00)
- then
- Report.Failed ("Failed dispatch to multiply overridden prim. oper.");
- end if;
-
-
- Annual_Interest (B_Acct);
- Annual_Interest (C_Acct);
- Annual_Interest (IC_Acct); -- Check the dispatch to primitive operation
- -- overridden from a parent type which inherited
- -- the operation from the root type.
- if (B_Acct.Current_Balance /= 10_00) or
- (C_Acct.Current_Balance /= 20_00) or
- (IC_Acct.Current_Balance /= 90_00)
- then
- Report.Failed ("Failed dispatch to overridden primitive operation");
- end if;
-
-
- Apply_Service_Charge (Acct => B_Acct);
- Apply_Service_Charge (Acct => C_Acct);
- Apply_Service_Charge (Acct => IC_Acct); -- Check the dispatch to a
- -- primitive operation twice
- -- inherited from the root
- -- tagged type.
- if (B_Acct.Current_Balance /= 5_00) or
- (C_Acct.Current_Balance /= 15_00) or
- (IC_Acct.Current_Balance /= 85_00)
- then
- Report.Failed ("Failed dispatch to Apply_Service_Charge");
- end if;
-
- Report.Result;
-
-end C392008;
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-18 02:37:14 +0000