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