diff options
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392d01.a')
| -rw-r--r-- | gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392d01.a | 324 |
1 files changed, 324 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392d01.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392d01.a new file mode 100644 index 000000000..bb6e19202 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392d01.a @@ -0,0 +1,324 @@ +-- C392D01.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 implicitly declared dispatching operation that is +-- overridden, the body executed is the body for the overriding +-- subprogram, even if the overriding occurs in a private part. +-- Check that, for an implicitly declared dispatching operation that is +-- NOT overridden, the body executed is the body of the corresponding +-- subprogram of the parent type. +-- +-- Check for the case where the overriding (and non-overriding) operations +-- are declared for a private extension (and its full type) in a public +-- child unit of the package declaring the ancestor type, and the ancestor +-- type is a tagged private type whose full view is itself a derived type. +-- +-- TEST DESCRIPTION: +-- Consider: +-- +-- package Parent is +-- type Root is tagged ... +-- procedure Vis_Op (P: Root); +-- private +-- procedure Pri_Op (P: Root); -- (A) +-- end Parent; +-- +-- package Intermediate is +-- type Mid is tagged private; +-- private +-- type Mid is new Parent.Root with record ... +-- -- Implicit Vis_Op (P: Mid) declared here. +-- +-- procedure Vis_Op (P: Mid); -- (B) +-- end Intermediate; +-- +-- package Intermediate.Child is +-- type Derived is new Mid with private; +-- +-- procedure Pri_Op (P: Derived); -- (C) +-- ... +-- +-- private +-- type Derived is new Mid with record... +-- -- Implicit Vis_Op (P: Derived) declared here. +-- ... +-- end Intermediate.Child; +-- +-- Type Derived inherits Vis_Op from the parent type Mid. Note, however, +-- that it is implicitly declared in the private part (inherited +-- subprograms for a derived_type_definition -- in this case, the full +-- type -- are implicitly declared at the earliest place within the +-- immediate scope of the type_declaration where the corresponding +-- declaration from the parent is visible). +-- +-- Because Parent.Pri_Op is never visible within the immediate scope +-- of Mid, it is not implicitly declared for Mid. Thus, it is also not +-- implicitly declared for Derived. As a result, the version of Pri_Op +-- declared at (C) above does not override an inherited version of +-- Parent.Pri_Op and is totally unrelated to it. +-- +-- Dispatching calls with tag Mid will execute (A) and (B). Dispatching +-- calls with tag Derived from Parent will execute the bodies of (B) +-- and (A). Dispatching calls with tag Derived from Parent.Child +-- will execute the bodies of (B) and (C). +-- +-- TEST FILES: +-- The following files comprise this test: +-- +-- F392D00.A +-- C392D01.A +-- +-- +-- CHANGE HISTORY: +-- 06 Dec 94 SAIC ACVC 2.0 +-- +--! + +with F392D00; +package C392D01_0 is + + type Zoom_Camera is tagged private; + + procedure Self_Test (C : in out Zoom_Camera'Class); + + -- ...Additional operations. + + + function TC_Correct_Result (C : Zoom_Camera; + D : F392D00.Depth_Of_Field; + S : F392D00.Shutter_Speed) return Boolean; + +private + + type Magnification is (Low, Medium, High); + + type Zoom_Camera is new F392D00.Remote_Camera with record + Mag : Magnification; + end record; + + -- procedure Focus (C : in out Zoom_Camera; -- Implicitly + -- Depth : in Depth_Of_Field) -- declared + -- here. + + procedure Focus (C : in out Zoom_Camera; -- Overrides + Depth : in F392D00.Depth_Of_Field); -- inherited op. + + -- For the remote zoom camera, perhaps the focusing algorithm is different + -- in some way, so the original Focus operation is overridden here. + + -- Since the partial view is not an extension, the overriding operation + -- must be declared after the full type. This version of Focus, although + -- not visible for type Zoom_Camera from outside the package, can still be + -- dispatched to. + + + -- Note: F392D00.Set_Shutter_Speed is inherited by Zoom_Camera from + -- F392D00.Remote_Camera, but since the operation never becomes visible + -- within the immediate scope of Zoom_Camera, it is never implicitly + -- declared. + +end C392D01_0; + + + --==================================================================-- + + +package body C392D01_0 is + + procedure Focus (C : in out Zoom_Camera; + Depth : in F392D00.Depth_Of_Field) is + begin + -- Artificial for testing purposes. + C.DOF := 83; + end Focus; + + ----------------------------------------------------------- + -- Indirect call to F392D00.Self_Test since the main does not know + -- that Zoom_Camera is a private extension of F392D00.Basic_Camera. + procedure Self_Test (C : in out Zoom_Camera'Class) is + begin + F392D00.Self_Test (C); + -- ...Additional self-testing. + end Self_Test; + + ----------------------------------------------------------- + function TC_Correct_Result (C : Zoom_Camera; + D : F392D00.Depth_Of_Field; + S : F392D00.Shutter_Speed) return Boolean is + use type F392D00.Depth_Of_Field; + use type F392D00.Shutter_Speed; + begin + return (C.DOF = D and C.Shutter = S); + end TC_Correct_Result; + +end C392D01_0; + + + --==================================================================-- + + +with F392D00; +package C392D01_0.C392D01_1 is + + type Film_Speed is private; + + type Auto_Speed is new Zoom_Camera with private; + + -- Implicit function TC_Correct_Result (Auto_Speed) declared here. + + procedure Set_Shutter_Speed (C : in out Auto_Speed; + Speed : in F392D00.Shutter_Speed); + + -- This version of Set_Shutter_Speed does NOT override the operation + -- inherited from Zoom_Camera, 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. + +private + type Film_Speed is (One_Hundred, Two_Hundred, Four_Hundred); + + type Auto_Speed is new Zoom_Camera with record + ASA : Film_Speed; + end record; + + -- procedure Focus (C : in out Auto_Speed; -- Implicitly + -- Depth : in F392D00.Depth_Of_Field); -- declared + -- here. + +end C392D01_0.C392D01_1; + + + --==================================================================-- + + +package body C392D01_0.C392D01_1 is + + procedure Set_Shutter_Speed (C : in out Auto_Speed; + Speed : in F392D00.Shutter_Speed) is + begin + -- Artificial for testing purposes. + C.Shutter := F392D00.Two_Fifty; + end Set_Shutter_Speed; + + ------------------------------------------------------- + procedure Self_Test (C : in out Auto_Speed'Class) is + begin + -- Artificial for testing purposes. + Set_Shutter_Speed (C, F392D00.Thousand); + Focus (C, 27); + end Self_Test; + +end C392D01_0.C392D01_1; + + + --==================================================================-- + + +with F392D00; +with C392D01_0.C392D01_1; + +with Report; + +procedure C392D01 is + Zooming_Camera : C392D01_0.Zoom_Camera; + Auto_Camera1 : C392D01_0.C392D01_1.Auto_Speed; + Auto_Camera2 : C392D01_0.C392D01_1.Auto_Speed; + + TC_Expected_Zoom_Depth : constant F392D00.Depth_Of_Field := 83; + TC_Expected_Auto_Depth : constant F392D00.Depth_Of_Field := 83; + TC_Expected_Depth : constant F392D00.Depth_Of_Field := 83; + TC_Expected_Zoom_Speed : constant F392D00.Shutter_Speed + := F392D00.Thousand; + TC_Expected_Auto_Speed : constant F392D00.Shutter_Speed + := F392D00.Thousand; + TC_Expected_Speed : constant F392D00.Shutter_Speed + := F392D00.Two_Fifty; + + use type F392D00.Depth_Of_Field; + use type F392D00.Shutter_Speed; + +begin + Report.Test ("C392D01", "Dispatching for overridden and non-overridden " & + "primitive subprograms: private extension declared in child " & + "unit, parent is tagged private whose full view is derived " & + "type"); + + + +-- Call the class-wide operation (Self_Test) for Zoom_Camera'Class, which +-- itself calls the class-wide operation for Remote_Camera'Class, which +-- in turn makes dispatching calls to Focus and Set_Shutter_Speed: + + + -- For an object of type Zoom_Camera, the dispatching call to Focus should + -- dispatch to the body explicitly declared for Zoom_Camera. The dispatching + -- to Set_Shutter_Speed should dispatch to the body declared for + -- Remote_Camera: + + C392D01_0.Self_Test(Zooming_Camera); + + if not C392D01_0.TC_Correct_Result (Zooming_Camera, + TC_Expected_Zoom_Depth, + TC_Expected_Zoom_Speed) + then + Report.Failed ("Calls dispatched incorrectly for tagged private type"); + end if; + + -- For an object of type Auto_Speed, the dispatching call to Focus should + -- dispatch to the body explicitly declared for Zoom_Camera. The dispatching + -- call to Set_Shutter_Speed should dispatch to the body explicitly declared + -- for Remote_Camera: + + C392D01_0.Self_Test(Auto_Camera1); + + if not C392D01_0.C392D01_1.TC_Correct_Result (Auto_Camera1, + TC_Expected_Auto_Depth, + TC_Expected_Auto_Speed) + then + Report.Failed ("Calls dispatched incorrectly for private extension"); + end if; + + -- Call to Self_Test from C392D01_0.C392D01_1 invokes the dispatching call + -- to Focus which should dispatch to the body explicitly declared for + -- Zoom_Camera. The dispatching call to Set_Shutter_Speed should dispatch + -- to the body explicitly declared for Auto_Speed: + + C392D01_0.C392D01_1.Self_Test(Auto_Camera2); + + if not C392D01_0.C392D01_1.TC_Correct_Result (Auto_Camera2, + TC_Expected_Depth, + TC_Expected_Speed) + then + Report.Failed ("Call to explicit subprogram executed the wrong body"); + end if; + + Report.Result; + +end C392D01; |