URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-old/] [gcc-4.2.2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [cc/] [cc30002.a] - Rev 154
Go to most recent revision | Compare with Previous | Blame | View Log
-- 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;
Go to most recent revision | Compare with Previous | Blame | View Log