diff options
Diffstat (limited to 'gcc/testsuite/ada/acats/tests/c3/c392d01.a')
| -rw-r--r-- | gcc/testsuite/ada/acats/tests/c3/c392d01.a | 324 |
1 files changed, 0 insertions, 324 deletions
diff --git a/gcc/testsuite/ada/acats/tests/c3/c392d01.a b/gcc/testsuite/ada/acats/tests/c3/c392d01.a deleted file mode 100644 index bb6e192028c..00000000000 --- a/gcc/testsuite/ada/acats/tests/c3/c392d01.a +++ /dev/null @@ -1,324 +0,0 @@ --- C392D01.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, for an implicitly declared dispatching operation that is --- overridden, the body executed is the body for the overriding --- subprogram, even if the overriding occurs in a private part. --- Check that, for an implicitly declared dispatching operation that is --- NOT overridden, the body executed is the body of the corresponding --- subprogram of the parent type. --- --- Check for the case where the overriding (and non-overriding) operations --- are declared for a private extension (and its full type) in a public --- child unit of the package declaring the ancestor type, and the ancestor --- type is a tagged private type whose full view is itself a derived type. --- --- TEST DESCRIPTION: --- Consider: --- --- package Parent is --- type Root is tagged ... --- procedure Vis_Op (P: Root); --- private --- procedure Pri_Op (P: Root); -- (A) --- end Parent; --- --- package Intermediate is --- type Mid is tagged private; --- private --- type Mid is new Parent.Root with record ... --- -- Implicit Vis_Op (P: Mid) declared here. --- --- procedure Vis_Op (P: Mid); -- (B) --- end Intermediate; --- --- package Intermediate.Child is --- type Derived is new Mid with private; --- --- procedure Pri_Op (P: Derived); -- (C) --- ... --- --- private --- type Derived is new Mid with record... --- -- Implicit Vis_Op (P: Derived) declared here. --- ... --- end Intermediate.Child; --- --- Type Derived inherits Vis_Op from the parent type Mid. Note, however, --- that it is implicitly declared in the private part (inherited --- subprograms for a derived_type_definition -- in this case, the full --- type -- are implicitly declared at the earliest place within the --- immediate scope of the type_declaration where the corresponding --- declaration from the parent is visible). --- --- Because Parent.Pri_Op is never visible within the immediate scope --- of Mid, it is not implicitly declared for Mid. Thus, it is also not --- implicitly declared for Derived. As a result, the version of Pri_Op --- declared at (C) above does not override an inherited version of --- Parent.Pri_Op and is totally unrelated to it. --- --- Dispatching calls with tag Mid will execute (A) and (B). Dispatching --- calls with tag Derived from Parent will execute the bodies of (B) --- and (A). Dispatching calls with tag Derived from Parent.Child --- will execute the bodies of (B) and (C). --- --- TEST FILES: --- The following files comprise this test: --- --- F392D00.A --- C392D01.A --- --- --- CHANGE HISTORY: --- 06 Dec 94 SAIC ACVC 2.0 --- ---! - -with F392D00; -package C392D01_0 is - - type Zoom_Camera is tagged private; - - procedure Self_Test (C : in out Zoom_Camera'Class); - - -- ...Additional operations. - - - function TC_Correct_Result (C : Zoom_Camera; - D : F392D00.Depth_Of_Field; - S : F392D00.Shutter_Speed) return Boolean; - -private - - type Magnification is (Low, Medium, High); - - type Zoom_Camera is new F392D00.Remote_Camera with record - Mag : Magnification; - end record; - - -- procedure Focus (C : in out Zoom_Camera; -- Implicitly - -- Depth : in Depth_Of_Field) -- declared - -- here. - - procedure Focus (C : in out Zoom_Camera; -- Overrides - Depth : in F392D00.Depth_Of_Field); -- inherited op. - - -- For the remote zoom camera, perhaps the focusing algorithm is different - -- in some way, so the original Focus operation is overridden here. - - -- Since the partial view is not an extension, the overriding operation - -- must be declared after the full type. This version of Focus, although - -- not visible for type Zoom_Camera from outside the package, can still be - -- dispatched to. - - - -- Note: F392D00.Set_Shutter_Speed is inherited by Zoom_Camera from - -- F392D00.Remote_Camera, but since the operation never becomes visible - -- within the immediate scope of Zoom_Camera, it is never implicitly - -- declared. - -end C392D01_0; - - - --==================================================================-- - - -package body C392D01_0 is - - procedure Focus (C : in out Zoom_Camera; - Depth : in F392D00.Depth_Of_Field) is - begin - -- Artificial for testing purposes. - C.DOF := 83; - end Focus; - - ----------------------------------------------------------- - -- Indirect call to F392D00.Self_Test since the main does not know - -- that Zoom_Camera is a private extension of F392D00.Basic_Camera. - procedure Self_Test (C : in out Zoom_Camera'Class) is - begin - F392D00.Self_Test (C); - -- ...Additional self-testing. - end Self_Test; - - ----------------------------------------------------------- - function TC_Correct_Result (C : Zoom_Camera; - D : F392D00.Depth_Of_Field; - S : F392D00.Shutter_Speed) return Boolean is - use type F392D00.Depth_Of_Field; - use type F392D00.Shutter_Speed; - begin - return (C.DOF = D and C.Shutter = S); - end TC_Correct_Result; - -end C392D01_0; - - - --==================================================================-- - - -with F392D00; -package C392D01_0.C392D01_1 is - - type Film_Speed is private; - - type Auto_Speed is new Zoom_Camera with private; - - -- Implicit function TC_Correct_Result (Auto_Speed) declared here. - - procedure Set_Shutter_Speed (C : in out Auto_Speed; - Speed : in F392D00.Shutter_Speed); - - -- This version of Set_Shutter_Speed does NOT override the operation - -- inherited from Zoom_Camera, because the inherited operation is never - -- visible (and thus, is never implicitly declared) within the immediate - -- scope of type Auto_Speed. - - procedure Self_Test (C : in out Auto_Speed'Class); - - -- ...Other operations. - -private - type Film_Speed is (One_Hundred, Two_Hundred, Four_Hundred); - - type Auto_Speed is new Zoom_Camera with record - ASA : Film_Speed; - end record; - - -- procedure Focus (C : in out Auto_Speed; -- Implicitly - -- Depth : in F392D00.Depth_Of_Field); -- declared - -- here. - -end C392D01_0.C392D01_1; - - - --==================================================================-- - - -package body C392D01_0.C392D01_1 is - - procedure Set_Shutter_Speed (C : in out Auto_Speed; - Speed : in F392D00.Shutter_Speed) is - begin - -- Artificial for testing purposes. - C.Shutter := F392D00.Two_Fifty; - end Set_Shutter_Speed; - - ------------------------------------------------------- - procedure Self_Test (C : in out Auto_Speed'Class) is - begin - -- Artificial for testing purposes. - Set_Shutter_Speed (C, F392D00.Thousand); - Focus (C, 27); - end Self_Test; - -end C392D01_0.C392D01_1; - - - --==================================================================-- - - -with F392D00; -with C392D01_0.C392D01_1; - -with Report; - -procedure C392D01 is - Zooming_Camera : C392D01_0.Zoom_Camera; - Auto_Camera1 : C392D01_0.C392D01_1.Auto_Speed; - Auto_Camera2 : C392D01_0.C392D01_1.Auto_Speed; - - TC_Expected_Zoom_Depth : constant F392D00.Depth_Of_Field := 83; - TC_Expected_Auto_Depth : constant F392D00.Depth_Of_Field := 83; - TC_Expected_Depth : constant F392D00.Depth_Of_Field := 83; - TC_Expected_Zoom_Speed : constant F392D00.Shutter_Speed - := F392D00.Thousand; - TC_Expected_Auto_Speed : constant F392D00.Shutter_Speed - := F392D00.Thousand; - TC_Expected_Speed : constant F392D00.Shutter_Speed - := F392D00.Two_Fifty; - - use type F392D00.Depth_Of_Field; - use type F392D00.Shutter_Speed; - -begin - Report.Test ("C392D01", "Dispatching for overridden and non-overridden " & - "primitive subprograms: private extension declared in child " & - "unit, parent is tagged private whose full view is derived " & - "type"); - - - --- Call the class-wide operation (Self_Test) for Zoom_Camera'Class, which --- itself calls the class-wide operation for Remote_Camera'Class, which --- in turn makes dispatching calls to Focus and Set_Shutter_Speed: - - - -- For an object of type Zoom_Camera, the dispatching call to Focus should - -- dispatch to the body explicitly declared for Zoom_Camera. The dispatching - -- to Set_Shutter_Speed should dispatch to the body declared for - -- Remote_Camera: - - C392D01_0.Self_Test(Zooming_Camera); - - if not C392D01_0.TC_Correct_Result (Zooming_Camera, - TC_Expected_Zoom_Depth, - TC_Expected_Zoom_Speed) - then - Report.Failed ("Calls dispatched incorrectly for tagged private type"); - end if; - - -- For an object of type Auto_Speed, the dispatching call to Focus should - -- dispatch to the body explicitly declared for Zoom_Camera. The dispatching - -- call to Set_Shutter_Speed should dispatch to the body explicitly declared - -- for Remote_Camera: - - C392D01_0.Self_Test(Auto_Camera1); - - if not C392D01_0.C392D01_1.TC_Correct_Result (Auto_Camera1, - TC_Expected_Auto_Depth, - TC_Expected_Auto_Speed) - then - Report.Failed ("Calls dispatched incorrectly for private extension"); - end if; - - -- Call to Self_Test from C392D01_0.C392D01_1 invokes the dispatching call - -- to Focus which should dispatch to the body explicitly declared for - -- Zoom_Camera. The dispatching call to Set_Shutter_Speed should dispatch - -- to the body explicitly declared for Auto_Speed: - - C392D01_0.C392D01_1.Self_Test(Auto_Camera2); - - if not C392D01_0.C392D01_1.TC_Correct_Result (Auto_Camera2, - TC_Expected_Depth, - TC_Expected_Speed) - then - Report.Failed ("Call to explicit subprogram executed the wrong body"); - end if; - - Report.Result; - -end C392D01; |