diff options
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392d03.a')
| -rw-r--r-- | gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392d03.a | 248 |
1 files changed, 248 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392d03.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392d03.a new file mode 100644 index 000000000..3a488952e --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392d03.a @@ -0,0 +1,248 @@ +-- C392D03.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, for an inherited dispatching operation that is overridden, +-- the body executed is the body of the overriding subprogram, even if +-- the overriding occurs in a private part. +-- +-- Check for the case where the overriding operation is declared in a +-- separate (non-child) package from that declaring the parent type, and +-- the descendant type is a record extension. +-- +-- Check for both dispatching and nondispatching calls. +-- +-- TEST DESCRIPTION: +-- Consider: +-- +-- package P is +-- type Root is tagged ... +-- procedure Op (A: Root); +-- end P; +-- +-- with P; +-- package Q is +-- type Derived1 is new P.Root with record... +-- -- Implicit procedure Op (A: Derived1) declared here. +-- type Derived2 is new P.Root with private... +-- -- Implicit procedure Op (A: Derived2) declared here. +-- type New_Derived is new Derived1 with private... +-- -- Implicit procedure Op (A: New_Derived) declared here. +-- private +-- procedure Op (A: Derived1); -- Overrides parent's Op. +-- type Derived2 is new P.Root with record... +-- procedure Op (A: Derived2); -- Overrides parent's Op. +-- type New_Derived is new Derived1 with record... +-- ... +-- end Q; +-- +-- Both type Derived1 and Derived2 inherit Op from the parent type Root. +-- Type New_Derived inherits (inherited) Op from Derived1. The inherited +-- operation is implicitly declared immediately after the type extension. +-- The inherited operation is overridden by an explicit declaration in +-- the private part. Even though the overriding operation is private, +-- calls to Op with an operand of tag Derived1, Derived2, or New_Derived +-- will execute the body of the overriding operation. +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- F392D00.A +-- C392D03.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with F392D00; +package C392D03_0 is + + type Aperture is (Eight, Sixteen); + + type Auto_Focus is new F392D00.Remote_Camera with record + -- ... + FStop : Aperture; + end record; + + -- Implicit procedure Focus (C : in out Auto_Focus; + -- Depth : in Depth_Of_Field) declared here. + + type Auto_Flashing is new F392D00.Remote_Camera with private; + + -- Implicit procedure Focus (C : in out Auto_Flashing; + -- Depth : in Depth_Of_Field) declared here. + + type Special_Focus is new Auto_Focus with private; + + -- Implicit procedure Focus (C : in out Special_Focus; + -- Depth : in Depth_Of_Field) declared here. + + -- ...Other operations. + +private + + procedure Focus (C : in out Auto_Focus; -- Overrides + Depth : in F392D00.Depth_Of_Field); -- parent's op. + + -- For the improved remote camera, focus is set automatically, so it is + -- declared as a private operation. + + type Auto_Flashing is new F392D00.Remote_Camera with null record; + + procedure Focus (C : in out Auto_Flashing; -- Overrides + Depth : in F392D00.Depth_Of_Field); -- parent's op. + + type Special_Focus is new Auto_Focus with null record; + +end C392D03_0; + + + --==================================================================-- + + +package body C392D03_0 is + + procedure Focus (C : in out Auto_Focus; + Depth : in F392D00.Depth_Of_Field) is + begin + -- Artificial for testing purposes. + C.DOF := 52; + end Focus; + + ----------------------------------------------------------- + procedure Focus (C : in out Auto_Flashing; + Depth : in F392D00.Depth_Of_Field) is + begin + -- Artificial for testing purposes. + C.DOF := 91; + end Focus; + +end C392D03_0; + + + --==================================================================-- + + +with F392D00; +with C392D03_0; + +with Report; + +procedure C392D03 is + + type Focus_Ptr is access procedure + (P1 : in out C392D03_0.Auto_Focus; + P2 : in F392D00.Depth_Of_Field); + + Basic_Camera : F392D00.Remote_Camera; + Auto_Camera1 : C392D03_0.Auto_Focus; + Auto_Camera2 : C392D03_0.Auto_Focus; + Flash_Camera1 : C392D03_0.Auto_Flashing; + Flash_Camera2 : C392D03_0.Auto_Flashing; + Special_Camera : C392D03_0.Special_Focus; + Auto_Depth : F392D00.Depth_Of_Field := 78; + + TC_Expected_Basic_Depth : constant F392D00.Depth_Of_Field := 46; + TC_Expected_Auto_Depth : constant F392D00.Depth_Of_Field := 52; + TC_Expected_Depth : constant F392D00.Depth_Of_Field := 91; + + FP : Focus_Ptr := C392D03_0.Focus'Access; + + use type F392D00.Depth_Of_Field; + +begin + Report.Test ("C392D03", "Dispatching for overridden primitive " & + "subprograms: record extension declared in non-child " & + "package, parent is tagged record"); + + +-- Call the class-wide operation for Remote_Camera'Class, which itself makes +-- a dispatching call to Focus: + + -- 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.DOF /= TC_Expected_Basic_Depth then + Report.Failed ("Call dispatched incorrectly for root type"); + end if; + + + -- For an object of type Auto_Focus, the dispatching call should + -- dispatch to the body declared for the derived type: + + F392D00.Self_Test(Auto_Camera1); + + if Auto_Camera1.DOF /= TC_Expected_Auto_Depth then + Report.Failed ("Call dispatched incorrectly for Auto_Focus type"); + end if; + + + -- For an object of type Auto_Flash, the dispatching call should + -- also dispatch to the body declared for the derived type: + + F392D00.Self_Test(Flash_Camera1); + + if Flash_Camera1.DOF /= TC_Expected_Depth then + Report.Failed ("Call dispatched incorrectly for Auto_Flash type"); + end if; + + -- For an object of Auto_Flash type, a non-dispatching call to Focus should + -- execute the body declared for the derived type (even through it is + -- declared in the private part). + + C392D03_0.Focus (Flash_Camera2, Auto_Depth); + + if Flash_Camera2.DOF /= TC_Expected_Depth then + Report.Failed ("Non-dispatching call to privately overriding " & + "subprogram executed the wrong body"); + end if; + + -- For an object of Auto_Focus type, a non-dispatching call to Focus should + -- execute the body declared for the derived type (even through it is + -- declared in the private part). + + FP.all (Auto_Camera2, Auto_Depth); + + if Auto_Camera2.DOF /= TC_Expected_Auto_Depth then + Report.Failed ("Non-dispatching call by using access to overriding " & + "subprogram executed the wrong body"); + end if; + + -- For an object of type Special_Camera, the dispatching call should + -- also dispatch to the body declared for the derived type: + + F392D00.Self_Test(Special_Camera); + + if Special_Camera.DOF /= TC_Expected_Auto_Depth then + Report.Failed ("Call dispatched incorrectly for Special_Camera type"); + end if; + + Report.Result; + +end C392D03; |