diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/cc/cc30002.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/cc/cc30002.a | 349 |
1 files changed, 0 insertions, 349 deletions
diff --git a/gcc/testsuite/ada/acats/tests/cc/cc30002.a b/gcc/testsuite/ada/acats/tests/cc/cc30002.a deleted file mode 100644 index 5132f8cae90..00000000000 --- a/gcc/testsuite/ada/acats/tests/cc/cc30002.a +++ /dev/null @@ -1,349 +0,0 @@ --- 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; |