CbC/CbC_gcc: gcc/testsuite/ada/acats/tests/c3/c392a01.a comparison

comparison gcc/testsuite/ada/acats/tests/c3/c392a01.a @ 111:04ced10e8804

gcc 7

author	kono
date	Fri, 27 Oct 2017 22:46:09 +0900
parents
children

comparison

equal deleted inserted replaced

-:561a7518be6b
+:04ced10e8804
+-- 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;

Mercurial > hg > CbC > CbC_gcc

comparison gcc/testsuite/ada/acats/tests/c3/c392a01.a @ 111:04ced10e8804