1-- C392D02.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 a primitive procedure declared in a private part is not 28-- overridden by a procedure explicitly declared at a place where the 29-- primitive procedure in question is not visible. 30-- 31-- Check for the case where the non-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-- TEST DESCRIPTION: 36-- Consider: 37-- 38-- package P is 39-- type Root is tagged ... 40-- private 41-- procedure Pri_Op (A: Root); 42-- end P; 43-- 44-- with P; 45-- package Q is 46-- type Derived is new P.Root with record... 47-- procedure Pri_Op (A: Derived); -- Does NOT override parent's Op. 48-- ... 49-- end Q; 50-- 51-- Type Derived inherits Pri_Op from the parent type Root. However, 52-- because P.Pri_Op is never visible within the immediate scope of 53-- Derived, it is not implicitly declared for Derived. As a result, 54-- the explicit Q.Pri_Op does not override P.Pri_Op and is totally 55-- unrelated to it. 56-- 57-- Dispatching calls to P.Pri_Op with operands of tag Derived will 58-- not dispatch to Q.Pri_Op; the body executed will be that of P.Pri_Op. 59-- 60-- TEST FILES: 61-- The following files comprise this test: 62-- 63-- F392D00.A 64-- C392D02.A 65-- 66-- 67-- CHANGE HISTORY: 68-- 06 Dec 94 SAIC ACVC 2.0 69-- 70--! 71 72with F392D00; 73package C392D02_0 is 74 75 type Aperture is (Eight, Sixteen); 76 77 type Auto_Speed is new F392D00.Remote_Camera with record 78 -- ... 79 FStop : Aperture; 80 end record; 81 82 83 procedure Set_Shutter_Speed (C : in out Auto_Speed; 84 Speed : in F392D00.Shutter_Speed); 85 -- Does NOT override. 86 87 -- This version of Set_Shutter_Speed does NOT override the operation 88 -- inherited from the parent, because the inherited operation is never 89 -- visible (and thus, is never implicitly declared) within the immediate 90 -- scope of type Auto_Speed. 91 92 procedure Self_Test (C : in out Auto_Speed'Class); 93 94 -- ...Other operations. 95 96end C392D02_0; 97 98 99 --==================================================================-- 100 101 102package body C392D02_0 is 103 104 procedure Set_Shutter_Speed (C : in out Auto_Speed; 105 Speed : in F392D00.Shutter_Speed) is 106 begin 107 -- Artificial for testing purposes. 108 C.Shutter := F392D00.Four_Hundred; 109 end Set_Shutter_Speed; 110 111 ---------------------------------------------------- 112 procedure Self_Test (C : in out Auto_Speed'Class) is 113 begin 114 -- Should dispatch to the Set_Shutter_Speed explicitly declared 115 -- for Auto_Speed. 116 Set_Shutter_Speed (C, F392D00.Two_Fifty); 117 end Self_Test; 118 119end C392D02_0; 120 121 122 --==================================================================-- 123 124 125with F392D00; 126with C392D02_0; 127 128with Report; 129 130procedure C392D02 is 131 Basic_Camera : F392D00.Remote_Camera; 132 Auto_Camera1 : C392D02_0.Auto_Speed; 133 Auto_Camera2 : C392D02_0.Auto_Speed; 134 135 TC_Expected_Basic_Speed : constant F392D00.Shutter_Speed 136 := F392D00.Thousand; 137 TC_Expected_Speed : constant F392D00.Shutter_Speed 138 := F392D00.Four_Hundred; 139 140 use type F392D00.Shutter_Speed; 141 142begin 143 Report.Test ("C392D02", "Dispatching for non-overridden primitive " & 144 "subprograms: record extension declared in non-child " & 145 "package, parent is tagged record"); 146 147-- Call the class-wide operation for Remote_Camera'Class, which dispatches 148-- to Set_Shutter_Speed: 149 150 -- For an object of type Remote_Camera, the dispatching call should 151 -- dispatch to the body declared for the root type: 152 153 F392D00.Self_Test(Basic_Camera); 154 155 if Basic_Camera.Shutter /= TC_Expected_Basic_Speed then 156 Report.Failed ("Call dispatched incorrectly for root type"); 157 end if; 158 159 160 -- C392D02_0.Set_Shutter_Speed should never be called by F392D00.Self_Test, 161 -- since C392D02_0.Set_Shutter_Speed does not override 162 -- F392D00.Set_Shutter_Speed. 163 164 -- For an object of type Auto_Speed, the dispatching call should 165 -- also dispatch to the body declared for the root type: 166 167 F392D00.Self_Test(Auto_Camera1); 168 169 if Auto_Camera1.Shutter /= TC_Expected_Basic_Speed then 170 Report.Failed ("Call dispatched incorrectly for derived type"); 171 end if; 172 173 -- Call to Self_Test from C392D02_0 invokes the dispatching call to 174 -- Set_Shutter_Speed which should dispatch to the body explicitly declared 175 -- for Auto_Speed: 176 177 C392D02_0.Self_Test(Auto_Camera2); 178 179 if Auto_Camera2.Shutter /= TC_Expected_Speed then 180 Report.Failed ("Call to explicit subprogram executed the wrong body"); 181 end if; 182 183 Report.Result; 184 185end C392D02; 186