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