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