1-- C392005.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 implicitly declared dispatching operation that is 28-- overridden, the body executed is the body for the overriding 29-- subprogram, even if the overriding occurs in a private part. 30-- 31-- Check for the case where the overriding operations are declared in a 32-- public child unit of the package declaring the parent type, and the 33-- descendant type is a private extension. 34-- 35-- Check for both dispatching and nondispatching calls. 36-- 37-- 38-- TEST DESCRIPTION: 39-- Consider: 40-- 41-- package Parent is 42-- type Root is tagged ... 43-- procedure Vis_Op (P: Root); 44-- private 45-- procedure Pri_Op (P: Root); 46-- end Parent; 47-- 48-- package Parent.Child is 49-- type Derived is new Root with private; 50-- -- Implicit Vis_Op (P: Derived) declared here. 51-- 52-- procedure Pri_Op (P: Derived); -- (A) 53-- ... 54-- private 55-- type Derived is new Root with record... 56-- -- Implicit Pri_Op (P: Derived) declared here. 57 58-- procedure Vis_Op (P: Derived); -- (B) 59-- ... 60-- end Parent.Child; 61-- 62-- Type Derived inherits both Vis_Op and Pri_Op from the ancestor type 63-- Root. Note, however, that Vis_Op is implicitly declared in the visible 64-- part, whereas Pri_Op is implicitly declared in the private part 65-- (inherited subprograms for a private extension are implicitly declared 66-- after the private_extension_declaration if the corresponding 67-- declaration from the ancestor is visible at that place; otherwise the 68-- inherited subprogram is not declared for the private extension, 69-- although it might be for the full type). 70-- 71-- Even though Root's version of Pri_Op hasn't been implicitly declared 72-- for Derived at the time Derived's version of Pri_Op has been 73-- explicitly declared, the explicit Pri_Op still overrides the implicit 74-- version. 75-- Also, even though the explicit Vis_Op for Derived is declared in the 76-- private part it still overrides the implicit version declared in the 77-- visible part. Calls with tag Derived will execute (A) and (B). 78-- 79-- 80-- CHANGE HISTORY: 81-- 06 Dec 94 SAIC ACVC 2.0 82-- 26 Nov 96 SAIC Improved for ACVC 2.1 83-- 84--! 85 86package C392005_0 is 87 88 type Remote_Camera is tagged private; 89 90 type Depth_Of_Field is range 5 .. 100; 91 type Shutter_Speed is (One, Two_Fifty, Four_Hundred, Thousand); 92 type Aperture is (Eight, Sixteen, Thirty_Two); 93 94 -- ...Other declarations. 95 96 procedure Focus (Cam : in out Remote_Camera; 97 Depth : in Depth_Of_Field); 98 99 procedure Self_Test (C: in out Remote_Camera'Class); 100 101 -- ...Other operations. 102 103 function TC_Get_Depth (C: Remote_Camera) return Depth_Of_Field; 104 function TC_Get_Speed (C: Remote_Camera) return Shutter_Speed; 105 106private 107 108 type Remote_Camera is tagged record 109 DOF : Depth_Of_Field := 10; 110 Shutter: Shutter_Speed := One; 111 FStop : Aperture := Eight; 112 end record; 113 114 procedure Set_Shutter_Speed (C : in out Remote_Camera; 115 Speed : in Shutter_Speed); 116 117 -- For the basic remote camera, shutter speed might be set as a function of 118 -- focus perhaps, thus it is declared as a private operation (usable 119 -- only internally within the abstraction). 120 121 function Set_Aperture (C : Remote_Camera) return Aperture; 122 123end C392005_0; 124 125 126 --==================================================================-- 127 128 129package body C392005_0 is 130 131 procedure Focus (Cam : in out Remote_Camera; 132 Depth : in Depth_Of_Field) is 133 begin 134 -- Artificial for testing purposes. 135 Cam.DOF := 46; 136 end Focus; 137 138 ----------------------------------------------------------- 139 procedure Set_Shutter_Speed (C : in out Remote_Camera; 140 Speed : in Shutter_Speed) is 141 begin 142 -- Artificial for testing purposes. 143 C.Shutter := Thousand; 144 end Set_Shutter_Speed; 145 146 ----------------------------------------------------------- 147 function Set_Aperture (C : Remote_Camera) return Aperture is 148 begin 149 -- Artificial for testing purposes. 150 return Thirty_Two; 151 end Set_Aperture; 152 153 ----------------------------------------------------------- 154 procedure Self_Test (C: in out Remote_Camera'Class) is 155 TC_Dummy_Depth : constant Depth_Of_Field := 23; 156 TC_Dummy_Speed : constant Shutter_Speed := Four_Hundred; 157 begin 158 159 -- Test focus at various depths: 160 Focus(C, TC_Dummy_Depth); 161 -- ...Additional calls to Focus. 162 163 -- Test various shutter speeds: 164 Set_Shutter_Speed(C, TC_Dummy_Speed); 165 -- ...Additional calls to Set_Shutter_Speed. 166 167 end Self_Test; 168 169 ----------------------------------------------------------- 170 function TC_Get_Depth (C: Remote_Camera) return Depth_Of_Field is 171 begin 172 return C.DOF; 173 end TC_Get_Depth; 174 175 ----------------------------------------------------------- 176 function TC_Get_Speed (C: Remote_Camera) return Shutter_Speed is 177 begin 178 return C.Shutter; 179 end TC_Get_Speed; 180 181end C392005_0; 182 183 --==================================================================-- 184 185 186package C392005_0.C392005_1 is 187 188 type Auto_Speed is new Remote_Camera with private; 189 190 191 -- procedure Focus (C : in out Auto_Speed; -- Implicitly declared 192 -- Depth : in Depth_Of_Field) -- here. 193 194 -- For the improved remote camera, shutter speed can be set manually, 195 -- so it is declared as a public operation. 196 197 -- The order of declarations for Set_Aperture and Set_Shutter_Speed are 198 -- reversed from the original declarations to trap potential compiler 199 -- problems related to subprogram ordering. 200 201 function Set_Aperture (C : Auto_Speed) return Aperture; -- Overrides 202 -- inherited op. 203 204 procedure Set_Shutter_Speed (C : in out Auto_Speed; -- Overrides 205 Speed : in Shutter_Speed);-- inherited op. 206 207 -- Set_Shutter_Speed and Set_Aperture override the operations inherited 208 -- from the parent, even though the inherited operations are not implicitly 209 -- declared until the private part below. 210 211 type New_Camera is private; 212 213 function TC_Get_Aper (C: New_Camera) return Aperture; 214 215 -- ...Other operations. 216 217private 218 type Film_Speed is (One_Hundred, Two_Hundred, Four_Hundred); 219 220 type Auto_Speed is new Remote_Camera with record 221 ASA : Film_Speed; 222 end record; 223 224 -- procedure Set_Shutter_Speed (C : in out Auto_Speed; -- Implicitly 225 -- Speed : in Shutter_Speed) -- declared 226 -- here. 227 228 -- function Set_Aperture (C : Auto_Speed) return Aperture; -- Implicitly 229 -- declared. 230 231 procedure Focus (C : in out Auto_Speed; -- Overrides 232 Depth : in Depth_Of_Field); -- inherited op. 233 234 -- For the improved remote camera, perhaps the focusing algorithm is 235 -- different, so the original Focus operation is overridden here. 236 237 Auto_Camera : Auto_Speed; 238 239 type New_Camera is record 240 Aper : Aperture := Set_Aperture (Auto_Camera); -- Calls the overridden, 241 end record; -- not the inherited op. 242 243end C392005_0.C392005_1; 244 245 246 --==================================================================-- 247 248 249package body C392005_0.C392005_1 is 250 251 procedure Focus (C : in out Auto_Speed; 252 Depth : in Depth_Of_Field) is 253 begin 254 -- Artificial for testing purposes. 255 C.DOF := 57; 256 end Focus; 257 258 --------------------------------------------------------------- 259 procedure Set_Shutter_Speed (C : in out Auto_Speed; 260 Speed : in Shutter_Speed) is 261 begin 262 -- Artificial for testing purposes. 263 C.Shutter := Two_Fifty; 264 end Set_Shutter_Speed; 265 266 ----------------------------------------------------------- 267 function Set_Aperture (C : Auto_Speed) return Aperture is 268 begin 269 -- Artificial for testing purposes. 270 return Sixteen; 271 end Set_Aperture; 272 273 ----------------------------------------------------------- 274 function TC_Get_Aper (C: New_Camera) return Aperture is 275 begin 276 return C.Aper; 277 end TC_Get_Aper; 278 279end C392005_0.C392005_1; 280 281 282 --==================================================================-- 283 284 285with C392005_0.C392005_1; 286 287with Report; 288 289procedure C392005 is 290 Basic_Camera : C392005_0.Remote_Camera; 291 Auto_Camera1 : C392005_0.C392005_1.Auto_Speed; 292 Auto_Camera2 : C392005_0.C392005_1.Auto_Speed; 293 Auto_Depth : C392005_0.Depth_Of_Field := 67; 294 New_Camera1 : C392005_0.C392005_1.New_Camera; 295 TC_Expected_Basic_Depth : constant C392005_0.Depth_Of_Field := 46; 296 TC_Expected_Auto_Depth : constant C392005_0.Depth_Of_Field := 57; 297 TC_Expected_Basic_Speed : constant C392005_0.Shutter_Speed 298 := C392005_0.Thousand; 299 TC_Expected_Auto_Speed : constant C392005_0.Shutter_Speed 300 := C392005_0.Two_Fifty; 301 TC_Expected_New_Aper : constant C392005_0.Aperture 302 := C392005_0.Sixteen; 303 304 use type C392005_0.Depth_Of_Field; 305 use type C392005_0.Shutter_Speed; 306 use type C392005_0.Aperture; 307 308begin 309 Report.Test ("C392005", "Dispatching for overridden primitive " & 310 "subprograms: private extension declared in child unit, " & 311 "parent is tagged private whose full view is tagged record"); 312 313-- Call the class-wide operation for Remote_Camera'Class, which itself makes 314-- dispatching calls to Focus and Set_Shutter_Speed: 315 316 317 -- For an object of type Remote_Camera, the dispatching calls should 318 -- dispatch to the bodies declared for the root type: 319 320 C392005_0.Self_Test(Basic_Camera); 321 322 if C392005_0.TC_Get_Depth (Basic_Camera) /= TC_Expected_Basic_Depth 323 or else C392005_0.TC_Get_Speed (Basic_Camera) /= TC_Expected_Basic_Speed 324 then 325 Report.Failed ("Calls dispatched incorrectly for root type"); 326 end if; 327 328 329 -- For an object of type Auto_Speed, the dispatching calls should 330 -- dispatch to the bodies declared for the derived type: 331 332 C392005_0.Self_Test(Auto_Camera1); 333 334 if C392005_0.C392005_1.TC_Get_Depth(Auto_Camera1) /= TC_Expected_Auto_Depth 335 336 or 337 C392005_0.C392005_1.TC_Get_Speed(Auto_Camera1) /= TC_Expected_Auto_Speed 338 then 339 Report.Failed ("Calls dispatched incorrectly for derived type"); 340 end if; 341 342 -- For an object of type Auto_Speed, a non-dispatching call to Focus should 343 344 -- execute the body declared for the derived type (even through it is 345 -- declared in the private part). 346 347 C392005_0.C392005_1.Focus (Auto_Camera2, Auto_Depth); 348 349 if C392005_0.C392005_1.TC_Get_Depth(Auto_Camera2) /= TC_Expected_Auto_Depth 350 351 then 352 Report.Failed ("Non-dispatching call to privately overriding " & 353 "subprogram executed the wrong body"); 354 end if; 355 356 -- For an object of type New_Camera, the initialization using Set_Ap 357 -- should execute the overridden body, not the inherited one. 358 359 if C392005_0.C392005_1.TC_Get_Aper (New_Camera1) /= TC_Expected_New_Aper 360 then 361 Report.Failed ("Non-dispatching call to visible overriding " & 362 "subprogram executed the wrong body"); 363 end if; 364 365 Report.Result; 366 367end C392005; 368