-- 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;