diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c3/c392d02.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c3/c392d02.a | 185 |
1 files changed, 185 insertions, 0 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392d02.a b/gcc/testsuite/ada/acats/tests/c3/c392d02.a new file mode 100644 index 000000000..d8e012cbe --- /dev/null +++ b/gcc/testsuite/ada/acats/tests/c3/c392d02.a @@ -0,0 +1,185 @@ +-- C392D02.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 a primitive procedure declared in a private part is not +-- overridden by a procedure explicitly declared at a place where the +-- primitive procedure in question is not visible. +-- +-- Check for the case where the non-overriding operation is declared in a +-- separate (non-child) package from that declaring the parent type, and +-- the descendant type is a record extension. +-- +-- TEST DESCRIPTION: +-- Consider: +-- +-- package P is +-- type Root is tagged ... +-- private +-- procedure Pri_Op (A: Root); +-- end P; +-- +-- with P; +-- package Q is +-- type Derived is new P.Root with record... +-- procedure Pri_Op (A: Derived); -- Does NOT override parent's Op. +-- ... +-- end Q; +-- +-- Type Derived inherits Pri_Op from the parent type Root. However, +-- because P.Pri_Op is never visible within the immediate scope of +-- Derived, it is not implicitly declared for Derived. As a result, +-- the explicit Q.Pri_Op does not override P.Pri_Op and is totally +-- unrelated to it. +-- +-- Dispatching calls to P.Pri_Op with operands of tag Derived will +-- not dispatch to Q.Pri_Op; the body executed will be that of P.Pri_Op. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- F392D00.A +-- C392D02.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with F392D00; +package C392D02_0 is + + type Aperture is (Eight, Sixteen); + + type Auto_Speed is new F392D00.Remote_Camera with record + -- ... + FStop : Aperture; + end record; + + + procedure Set_Shutter_Speed (C : in out Auto_Speed; + Speed : in F392D00.Shutter_Speed); + -- Does NOT override. + + -- This version of Set_Shutter_Speed does NOT override the operation + -- inherited from the parent, because the inherited operation is never + -- visible (and thus, is never implicitly declared) within the immediate + -- scope of type Auto_Speed. + + procedure Self_Test (C : in out Auto_Speed'Class); + + -- ...Other operations. + +end C392D02_0; + + + --==================================================================-- + + +package body C392D02_0 is + + procedure Set_Shutter_Speed (C : in out Auto_Speed; + Speed : in F392D00.Shutter_Speed) is + begin + -- Artificial for testing purposes. + C.Shutter := F392D00.Four_Hundred; + end Set_Shutter_Speed; + + ---------------------------------------------------- + procedure Self_Test (C : in out Auto_Speed'Class) is + begin + -- Should dispatch to the Set_Shutter_Speed explicitly declared + -- for Auto_Speed. + Set_Shutter_Speed (C, F392D00.Two_Fifty); + end Self_Test; + +end C392D02_0; + + + --==================================================================-- + + +with F392D00; +with C392D02_0; + +with Report; + +procedure C392D02 is + Basic_Camera : F392D00.Remote_Camera; + Auto_Camera1 : C392D02_0.Auto_Speed; + Auto_Camera2 : C392D02_0.Auto_Speed; + + TC_Expected_Basic_Speed : constant F392D00.Shutter_Speed + := F392D00.Thousand; + TC_Expected_Speed : constant F392D00.Shutter_Speed + := F392D00.Four_Hundred; + + use type F392D00.Shutter_Speed; + +begin + Report.Test ("C392D02", "Dispatching for non-overridden primitive " & + "subprograms: record extension declared in non-child " & + "package, parent is tagged record"); + +-- Call the class-wide operation for Remote_Camera'Class, which dispatches +-- to Set_Shutter_Speed: + + -- For an object of type Remote_Camera, the dispatching call should + -- dispatch to the body declared for the root type: + + F392D00.Self_Test(Basic_Camera); + + if Basic_Camera.Shutter /= TC_Expected_Basic_Speed then + Report.Failed ("Call dispatched incorrectly for root type"); + end if; + + + -- C392D02_0.Set_Shutter_Speed should never be called by F392D00.Self_Test, + -- since C392D02_0.Set_Shutter_Speed does not override + -- F392D00.Set_Shutter_Speed. + + -- For an object of type Auto_Speed, the dispatching call should + -- also dispatch to the body declared for the root type: + + F392D00.Self_Test(Auto_Camera1); + + if Auto_Camera1.Shutter /= TC_Expected_Basic_Speed then + Report.Failed ("Call dispatched incorrectly for derived type"); + end if; + + -- Call to Self_Test from C392D02_0 invokes the dispatching call to + -- Set_Shutter_Speed which should dispatch to the body explicitly declared + -- for Auto_Speed: + + C392D02_0.Self_Test(Auto_Camera2); + + if Auto_Camera2.Shutter /= TC_Expected_Speed then + Report.Failed ("Call to explicit subprogram executed the wrong body"); + end if; + + Report.Result; + +end C392D02; |