-- CC30002.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 an explicit declaration in the private part of an instance -- does not override an implicit declaration in the instance, unless the -- corresponding explicit declaration in the generic overrides a -- corresponding implicit declaration in the generic. Check for primitive -- subprograms of tagged types. -- -- TEST DESCRIPTION: -- Consider the following: -- -- type Ancestor is tagged null record; -- procedure R (X: in Ancestor); -- -- generic -- type Formal is new Ancestor with private; -- package G is -- type T is new Formal with null record; -- -- Implicit procedure R (X: in T); -- procedure P (X: in T); -- (1) -- private -- procedure Q (X: in T); -- (2) -- procedure R (X: in T); -- (3) Overrides implicit R in generic. -- end G; -- -- type Actual is new Ancestor with null record; -- procedure P (X: in Actual); -- procedure Q (X: in Actual); -- procedure R (X: in Actual); -- -- package Instance is new G (Formal => Actual); -- -- In the instance, the copy of P at (1) overrides Actual's P, since it -- is declared in the visible part of the instance. The copy of Q at (2) -- does not override anything. The copy of R at (3) overrides Actual's -- R, even though it is declared in the private part, because within -- the generic the explicit declaration of R overrides an implicit -- declaration. -- -- Thus, for calls involving a parameter with tag T: -- - Calls to P will execute the body declared for T. -- - Calls to Q from within Instance will execute the body declared -- for T. -- - Calls to Q from outside Instance will execute the body declared -- for Actual. -- - Calls to R will execute the body declared for T. -- -- Verify this behavior for both dispatching and nondispatching calls to -- Q and R. -- -- -- CHANGE HISTORY: -- 24 Feb 95 SAIC Initial prerelease version. -- --! package CC30002_0 is type TC_Body_Kind is (Body_Of_Ancestor, Body_In_Instance, Body_Of_Actual, Initial_Value); type Camera is tagged record -- ... Camera components. TC_Focus_Called : TC_Body_Kind := Initial_Value; TC_Shutter_Called : TC_Body_Kind := Initial_Value; end record; procedure Focus (C: in out Camera); -- ...Other operations. end CC30002_0; --==================================================================-- package body CC30002_0 is procedure Focus (C: in out Camera) is begin -- Artificial for testing purposes. C.TC_Focus_Called := Body_Of_Ancestor; end Focus; end CC30002_0; --==================================================================-- with CC30002_0; use CC30002_0; generic type Camera_Type is new CC30002_0.Camera with private; package CC30002_1 is type Speed_Camera is new Camera_Type with record Diag_Code: Positive; -- ...Other components. end record; -- Implicit procedure Focus (C: in out Speed_Camera) declared in generic. procedure Self_Test_NonDisp (C: in out Speed_Camera); procedure Self_Test_Disp (C: in out Speed_Camera'Class); private -- The following explicit declaration of Set_Shutter_Speed does NOT override -- a corresponding implicit declaration in the generic. Therefore, its copy -- does NOT override the implicit declaration (inherited from the actual) -- in the instance. procedure Set_Shutter_Speed (C: in out Speed_Camera); -- The following explicit declaration of Focus DOES override a -- corresponding implicit declaration (inherited from the parent) in the -- generic. Therefore, its copy overrides the implicit declaration -- (inherited from the actual) in the instance. procedure Focus (C: in out Speed_Camera); -- Overrides implicit Focus -- in generic. end CC30002_1; --==================================================================-- package body CC30002_1 is procedure Self_Test_NonDisp (C: in out Speed_Camera) is begin -- Nondispatching calls: Focus (C); Set_Shutter_Speed (C); end Self_Test_NonDisp; procedure Self_Test_Disp (C: in out Speed_Camera'Class) is begin -- Dispatching calls: Focus (C); Set_Shutter_Speed (C); end Self_Test_Disp; procedure Set_Shutter_Speed (C: in out Speed_Camera) is begin -- Artificial for testing purposes. C.TC_Shutter_Called := Body_In_Instance; end Set_Shutter_Speed; procedure Focus (C: in out Speed_Camera) is begin -- Artificial for testing purposes. C.TC_Focus_Called := Body_In_Instance; end Focus; end CC30002_1; --==================================================================-- with CC30002_0; package CC30002_2 is type Aperture_Camera is new CC30002_0.Camera with record FStop: Natural; -- ...Other components. end record; procedure Set_Shutter_Speed (C: in out Aperture_Camera); procedure Focus (C: in out Aperture_Camera); end CC30002_2; --==================================================================-- package body CC30002_2 is procedure Set_Shutter_Speed (C: in out Aperture_Camera) is use CC30002_0; begin -- Artificial for testing purposes. C.TC_Shutter_Called := Body_Of_Actual; end Set_Shutter_Speed; procedure Focus (C: in out Aperture_Camera) is use CC30002_0; begin -- Artificial for testing purposes. C.TC_Focus_Called := Body_Of_Actual; end Focus; end CC30002_2; --==================================================================-- -- Instance declaration. with CC30002_1; with CC30002_2; package CC30002_3 is new CC30002_1 (Camera_Type => CC30002_2.Aperture_Camera); --==================================================================-- with CC30002_0; with CC30002_1; with CC30002_2; with CC30002_3; -- Instance. with Report; procedure CC30002 is package Speed_Cameras renames CC30002_3; use CC30002_0; TC_Camera1: Speed_Cameras.Speed_Camera; TC_Camera2: Speed_Cameras.Speed_Camera'Class := TC_Camera1; TC_Camera3: Speed_Cameras.Speed_Camera; TC_Camera4: Speed_Cameras.Speed_Camera; begin Report.Test ("CC30002", "Check that an explicit declaration in the " & "private part of an instance does not override an implicit " & "declaration in the instance, unless the corresponding " & "explicit declaration in the generic overrides a " & "corresponding implicit declaration in the generic. Check " & "for primitive subprograms of tagged types"); -- -- Check non-dispatching calls outside instance: -- -- Non-overriding primitive operation: Speed_Cameras.Set_Shutter_Speed (TC_Camera1); if TC_Camera1.TC_Shutter_Called /= Body_Of_Actual then Report.Failed ("Wrong body executed: non-dispatching call to " & "Set_Shutter_Speed outside instance"); end if; -- Overriding primitive operation: Speed_Cameras.Focus (TC_Camera1); if TC_Camera1.TC_Focus_Called /= Body_In_Instance then Report.Failed ("Wrong body executed: non-dispatching call to " & "Focus outside instance"); end if; -- -- Check dispatching calls outside instance: -- -- Non-overriding primitive operation: Speed_Cameras.Set_Shutter_Speed (TC_Camera2); if TC_Camera2.TC_Shutter_Called /= Body_Of_Actual then Report.Failed ("Wrong body executed: dispatching call to " & "Set_Shutter_Speed outside instance"); end if; -- Overriding primitive operation: Speed_Cameras.Focus (TC_Camera2); if TC_Camera2.TC_Focus_Called /= Body_In_Instance then Report.Failed ("Wrong body executed: dispatching call to " & "Focus outside instance"); end if; -- -- Check non-dispatching calls within instance: -- Speed_Cameras.Self_Test_NonDisp (TC_Camera3); -- Non-overriding primitive operation: if TC_Camera3.TC_Shutter_Called /= Body_In_Instance then Report.Failed ("Wrong body executed: non-dispatching call to " & "Set_Shutter_Speed inside instance"); end if; -- Overriding primitive operation: if TC_Camera3.TC_Focus_Called /= Body_In_Instance then Report.Failed ("Wrong body executed: non-dispatching call to " & "Focus inside instance"); end if; -- -- Check dispatching calls within instance: -- Speed_Cameras.Self_Test_Disp (TC_Camera4); -- Non-overriding primitive operation: if TC_Camera4.TC_Shutter_Called /= Body_In_Instance then Report.Failed ("Wrong body executed: dispatching call to " & "Set_Shutter_Speed inside instance"); end if; -- Overriding primitive operation: if TC_Camera4.TC_Focus_Called /= Body_In_Instance then Report.Failed ("Wrong body executed: dispatching call to " & "Focus inside instance"); end if; Report.Result; end CC30002;