1-- C392D03.A 2-- 3-- Grant of Unlimited Rights 4-- 5-- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, 6-- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained 7-- unlimited rights in the software and documentation contained herein. 8-- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making 9-- this public release, the Government intends to confer upon all 10-- recipients unlimited rights equal to those held by the Government. 11-- These rights include rights to use, duplicate, release or disclose the 12-- released technical data and computer software in whole or in part, in 13-- any manner and for any purpose whatsoever, and to have or permit others 14-- to do so. 15-- 16-- DISCLAIMER 17-- 18-- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR 19-- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED 20-- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE 21-- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE 22-- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A 23-- PARTICULAR PURPOSE OF SAID MATERIAL. 24--* 25-- 26-- OBJECTIVE: 27-- Check that, for an inherited dispatching operation that is overridden, 28-- the body executed is the body of the overriding subprogram, even if 29-- the overriding occurs in a private part. 30-- 31-- Check for the case where the overriding operation is declared in a 32-- separate (non-child) package from that declaring the parent type, and 33-- the descendant type is a record extension. 34-- 35-- Check for both dispatching and nondispatching calls. 36-- 37-- TEST DESCRIPTION: 38-- Consider: 39-- 40-- package P is 41-- type Root is tagged ... 42-- procedure Op (A: Root); 43-- end P; 44-- 45-- with P; 46-- package Q is 47-- type Derived1 is new P.Root with record... 48-- -- Implicit procedure Op (A: Derived1) declared here. 49-- type Derived2 is new P.Root with private... 50-- -- Implicit procedure Op (A: Derived2) declared here. 51-- type New_Derived is new Derived1 with private... 52-- -- Implicit procedure Op (A: New_Derived) declared here. 53-- private 54-- procedure Op (A: Derived1); -- Overrides parent's Op. 55-- type Derived2 is new P.Root with record... 56-- procedure Op (A: Derived2); -- Overrides parent's Op. 57-- type New_Derived is new Derived1 with record... 58-- ... 59-- end Q; 60-- 61-- Both type Derived1 and Derived2 inherit Op from the parent type Root. 62-- Type New_Derived inherits (inherited) Op from Derived1. The inherited 63-- operation is implicitly declared immediately after the type extension. 64-- The inherited operation is overridden by an explicit declaration in 65-- the private part. Even though the overriding operation is private, 66-- calls to Op with an operand of tag Derived1, Derived2, or New_Derived 67-- will execute the body of the overriding operation. 68-- 69-- TEST FILES: 70-- The following files comprise this test: 71-- 72-- F392D00.A 73-- C392D03.A 74-- 75-- 76-- CHANGE HISTORY: 77-- 06 Dec 94 SAIC ACVC 2.0 78-- 79--! 80 81with F392D00; 82package C392D03_0 is 83 84 type Aperture is (Eight, Sixteen); 85 86 type Auto_Focus is new F392D00.Remote_Camera with record 87 -- ... 88 FStop : Aperture; 89 end record; 90 91 -- Implicit procedure Focus (C : in out Auto_Focus; 92 -- Depth : in Depth_Of_Field) declared here. 93 94 type Auto_Flashing is new F392D00.Remote_Camera with private; 95 96 -- Implicit procedure Focus (C : in out Auto_Flashing; 97 -- Depth : in Depth_Of_Field) declared here. 98 99 type Special_Focus is new Auto_Focus with private; 100 101 -- Implicit procedure Focus (C : in out Special_Focus; 102 -- Depth : in Depth_Of_Field) declared here. 103 104 -- ...Other operations. 105 106private 107 108 procedure Focus (C : in out Auto_Focus; -- Overrides 109 Depth : in F392D00.Depth_Of_Field); -- parent's op. 110 111 -- For the improved remote camera, focus is set automatically, so it is 112 -- declared as a private operation. 113 114 type Auto_Flashing is new F392D00.Remote_Camera with null record; 115 116 procedure Focus (C : in out Auto_Flashing; -- Overrides 117 Depth : in F392D00.Depth_Of_Field); -- parent's op. 118 119 type Special_Focus is new Auto_Focus with null record; 120 121end C392D03_0; 122 123 124 --==================================================================-- 125 126 127package body C392D03_0 is 128 129 procedure Focus (C : in out Auto_Focus; 130 Depth : in F392D00.Depth_Of_Field) is 131 begin 132 -- Artificial for testing purposes. 133 C.DOF := 52; 134 end Focus; 135 136 ----------------------------------------------------------- 137 procedure Focus (C : in out Auto_Flashing; 138 Depth : in F392D00.Depth_Of_Field) is 139 begin 140 -- Artificial for testing purposes. 141 C.DOF := 91; 142 end Focus; 143 144end C392D03_0; 145 146 147 --==================================================================-- 148 149 150with F392D00; 151with C392D03_0; 152 153with Report; 154 155procedure C392D03 is 156 157 type Focus_Ptr is access procedure 158 (P1 : in out C392D03_0.Auto_Focus; 159 P2 : in F392D00.Depth_Of_Field); 160 161 Basic_Camera : F392D00.Remote_Camera; 162 Auto_Camera1 : C392D03_0.Auto_Focus; 163 Auto_Camera2 : C392D03_0.Auto_Focus; 164 Flash_Camera1 : C392D03_0.Auto_Flashing; 165 Flash_Camera2 : C392D03_0.Auto_Flashing; 166 Special_Camera : C392D03_0.Special_Focus; 167 Auto_Depth : F392D00.Depth_Of_Field := 78; 168 169 TC_Expected_Basic_Depth : constant F392D00.Depth_Of_Field := 46; 170 TC_Expected_Auto_Depth : constant F392D00.Depth_Of_Field := 52; 171 TC_Expected_Depth : constant F392D00.Depth_Of_Field := 91; 172 173 FP : Focus_Ptr := C392D03_0.Focus'Access; 174 175 use type F392D00.Depth_Of_Field; 176 177begin 178 Report.Test ("C392D03", "Dispatching for overridden primitive " & 179 "subprograms: record extension declared in non-child " & 180 "package, parent is tagged record"); 181 182 183-- Call the class-wide operation for Remote_Camera'Class, which itself makes 184-- a dispatching call to Focus: 185 186 -- For an object of type Remote_Camera, the dispatching call should 187 -- dispatch to the body declared for the root type: 188 189 F392D00.Self_Test(Basic_Camera); 190 191 if Basic_Camera.DOF /= TC_Expected_Basic_Depth then 192 Report.Failed ("Call dispatched incorrectly for root type"); 193 end if; 194 195 196 -- For an object of type Auto_Focus, the dispatching call should 197 -- dispatch to the body declared for the derived type: 198 199 F392D00.Self_Test(Auto_Camera1); 200 201 if Auto_Camera1.DOF /= TC_Expected_Auto_Depth then 202 Report.Failed ("Call dispatched incorrectly for Auto_Focus type"); 203 end if; 204 205 206 -- For an object of type Auto_Flash, the dispatching call should 207 -- also dispatch to the body declared for the derived type: 208 209 F392D00.Self_Test(Flash_Camera1); 210 211 if Flash_Camera1.DOF /= TC_Expected_Depth then 212 Report.Failed ("Call dispatched incorrectly for Auto_Flash type"); 213 end if; 214 215 -- For an object of Auto_Flash type, a non-dispatching call to Focus should 216 -- execute the body declared for the derived type (even through it is 217 -- declared in the private part). 218 219 C392D03_0.Focus (Flash_Camera2, Auto_Depth); 220 221 if Flash_Camera2.DOF /= TC_Expected_Depth then 222 Report.Failed ("Non-dispatching call to privately overriding " & 223 "subprogram executed the wrong body"); 224 end if; 225 226 -- For an object of Auto_Focus type, a non-dispatching call to Focus should 227 -- execute the body declared for the derived type (even through it is 228 -- declared in the private part). 229 230 FP.all (Auto_Camera2, Auto_Depth); 231 232 if Auto_Camera2.DOF /= TC_Expected_Auto_Depth then 233 Report.Failed ("Non-dispatching call by using access to overriding " & 234 "subprogram executed the wrong body"); 235 end if; 236 237 -- For an object of type Special_Camera, the dispatching call should 238 -- also dispatch to the body declared for the derived type: 239 240 F392D00.Self_Test(Special_Camera); 241 242 if Special_Camera.DOF /= TC_Expected_Auto_Depth then 243 Report.Failed ("Call dispatched incorrectly for Special_Camera type"); 244 end if; 245 246 Report.Result; 247 248end C392D03; 249