URL
https://opencores.org/ocsvn/openrisc_2011-10-31/openrisc_2011-10-31/trunk
Subversion Repositories openrisc_2011-10-31
[/] [openrisc/] [tags/] [gnu-src/] [gcc-4.5.1/] [gcc-4.5.1-or32-1.0rc2/] [gcc/] [testsuite/] [ada/] [acats/] [tests/] [c3/] [c392005.a] - Rev 294
Go to most recent revision | Compare with Previous | Blame | View Log
-- C392005.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 for the case where the overriding operations are declared in a
-- public child unit of the package declaring the parent type, and the
-- descendant type is a private extension.
--
-- Check for both dispatching and nondispatching calls.
--
--
-- TEST DESCRIPTION:
-- Consider:
--
-- package Parent is
-- type Root is tagged ...
-- procedure Vis_Op (P: Root);
-- private
-- procedure Pri_Op (P: Root);
-- end Parent;
--
-- package Parent.Child is
-- type Derived is new Root with private;
-- -- Implicit Vis_Op (P: Derived) declared here.
--
-- procedure Pri_Op (P: Derived); -- (A)
-- ...
-- private
-- type Derived is new Root with record...
-- -- Implicit Pri_Op (P: Derived) declared here.
-- procedure Vis_Op (P: Derived); -- (B)
-- ...
-- end Parent.Child;
--
-- Type Derived inherits both Vis_Op and Pri_Op from the ancestor type
-- Root. Note, however, that Vis_Op is implicitly declared in the visible
-- part, whereas Pri_Op is implicitly declared in the private part
-- (inherited subprograms for a private extension are implicitly declared
-- after the private_extension_declaration if the corresponding
-- declaration from the ancestor is visible at that place; otherwise the
-- inherited subprogram is not declared for the private extension,
-- although it might be for the full type).
--
-- Even though Root's version of Pri_Op hasn't been implicitly declared
-- for Derived at the time Derived's version of Pri_Op has been
-- explicitly declared, the explicit Pri_Op still overrides the implicit
-- version.
-- Also, even though the explicit Vis_Op for Derived is declared in the
-- private part it still overrides the implicit version declared in the
-- visible part. Calls with tag Derived will execute (A) and (B).
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 26 Nov 96 SAIC Improved for ACVC 2.1
--
--!
package C392005_0 is
type Remote_Camera is tagged private;
type Depth_Of_Field is range 5 .. 100;
type Shutter_Speed is (One, Two_Fifty, Four_Hundred, Thousand);
type Aperture is (Eight, Sixteen, Thirty_Two);
-- ...Other declarations.
procedure Focus (Cam : in out Remote_Camera;
Depth : in Depth_Of_Field);
procedure Self_Test (C: in out Remote_Camera'Class);
-- ...Other operations.
function TC_Get_Depth (C: Remote_Camera) return Depth_Of_Field;
function TC_Get_Speed (C: Remote_Camera) return Shutter_Speed;
private
type Remote_Camera is tagged record
DOF : Depth_Of_Field := 10;
Shutter: Shutter_Speed := One;
FStop : Aperture := Eight;
end record;
procedure Set_Shutter_Speed (C : in out Remote_Camera;
Speed : in Shutter_Speed);
-- For the basic remote camera, shutter speed might be set as a function of
-- focus perhaps, thus it is declared as a private operation (usable
-- only internally within the abstraction).
function Set_Aperture (C : Remote_Camera) return Aperture;
end C392005_0;
--==================================================================--
package body C392005_0 is
procedure Focus (Cam : in out Remote_Camera;
Depth : in Depth_Of_Field) is
begin
-- Artificial for testing purposes.
Cam.DOF := 46;
end Focus;
-----------------------------------------------------------
procedure Set_Shutter_Speed (C : in out Remote_Camera;
Speed : in Shutter_Speed) is
begin
-- Artificial for testing purposes.
C.Shutter := Thousand;
end Set_Shutter_Speed;
-----------------------------------------------------------
function Set_Aperture (C : Remote_Camera) return Aperture is
begin
-- Artificial for testing purposes.
return Thirty_Two;
end Set_Aperture;
-----------------------------------------------------------
procedure Self_Test (C: in out Remote_Camera'Class) is
TC_Dummy_Depth : constant Depth_Of_Field := 23;
TC_Dummy_Speed : constant Shutter_Speed := Four_Hundred;
begin
-- Test focus at various depths:
Focus(C, TC_Dummy_Depth);
-- ...Additional calls to Focus.
-- Test various shutter speeds:
Set_Shutter_Speed(C, TC_Dummy_Speed);
-- ...Additional calls to Set_Shutter_Speed.
end Self_Test;
-----------------------------------------------------------
function TC_Get_Depth (C: Remote_Camera) return Depth_Of_Field is
begin
return C.DOF;
end TC_Get_Depth;
-----------------------------------------------------------
function TC_Get_Speed (C: Remote_Camera) return Shutter_Speed is
begin
return C.Shutter;
end TC_Get_Speed;
end C392005_0;
--==================================================================--
package C392005_0.C392005_1 is
type Auto_Speed is new Remote_Camera with private;
-- procedure Focus (C : in out Auto_Speed; -- Implicitly declared
-- Depth : in Depth_Of_Field) -- here.
-- For the improved remote camera, shutter speed can be set manually,
-- so it is declared as a public operation.
-- The order of declarations for Set_Aperture and Set_Shutter_Speed are
-- reversed from the original declarations to trap potential compiler
-- problems related to subprogram ordering.
function Set_Aperture (C : Auto_Speed) return Aperture; -- Overrides
-- inherited op.
procedure Set_Shutter_Speed (C : in out Auto_Speed; -- Overrides
Speed : in Shutter_Speed);-- inherited op.
-- Set_Shutter_Speed and Set_Aperture override the operations inherited
-- from the parent, even though the inherited operations are not implicitly
-- declared until the private part below.
type New_Camera is private;
function TC_Get_Aper (C: New_Camera) return Aperture;
-- ...Other operations.
private
type Film_Speed is (One_Hundred, Two_Hundred, Four_Hundred);
type Auto_Speed is new Remote_Camera with record
ASA : Film_Speed;
end record;
-- procedure Set_Shutter_Speed (C : in out Auto_Speed; -- Implicitly
-- Speed : in Shutter_Speed) -- declared
-- here.
-- function Set_Aperture (C : Auto_Speed) return Aperture; -- Implicitly
-- declared.
procedure Focus (C : in out Auto_Speed; -- Overrides
Depth : in Depth_Of_Field); -- inherited op.
-- For the improved remote camera, perhaps the focusing algorithm is
-- different, so the original Focus operation is overridden here.
Auto_Camera : Auto_Speed;
type New_Camera is record
Aper : Aperture := Set_Aperture (Auto_Camera); -- Calls the overridden,
end record; -- not the inherited op.
end C392005_0.C392005_1;
--==================================================================--
package body C392005_0.C392005_1 is
procedure Focus (C : in out Auto_Speed;
Depth : in Depth_Of_Field) is
begin
-- Artificial for testing purposes.
C.DOF := 57;
end Focus;
---------------------------------------------------------------
procedure Set_Shutter_Speed (C : in out Auto_Speed;
Speed : in Shutter_Speed) is
begin
-- Artificial for testing purposes.
C.Shutter := Two_Fifty;
end Set_Shutter_Speed;
-----------------------------------------------------------
function Set_Aperture (C : Auto_Speed) return Aperture is
begin
-- Artificial for testing purposes.
return Sixteen;
end Set_Aperture;
-----------------------------------------------------------
function TC_Get_Aper (C: New_Camera) return Aperture is
begin
return C.Aper;
end TC_Get_Aper;
end C392005_0.C392005_1;
--==================================================================--
with C392005_0.C392005_1;
with Report;
procedure C392005 is
Basic_Camera : C392005_0.Remote_Camera;
Auto_Camera1 : C392005_0.C392005_1.Auto_Speed;
Auto_Camera2 : C392005_0.C392005_1.Auto_Speed;
Auto_Depth : C392005_0.Depth_Of_Field := 67;
New_Camera1 : C392005_0.C392005_1.New_Camera;
TC_Expected_Basic_Depth : constant C392005_0.Depth_Of_Field := 46;
TC_Expected_Auto_Depth : constant C392005_0.Depth_Of_Field := 57;
TC_Expected_Basic_Speed : constant C392005_0.Shutter_Speed
:= C392005_0.Thousand;
TC_Expected_Auto_Speed : constant C392005_0.Shutter_Speed
:= C392005_0.Two_Fifty;
TC_Expected_New_Aper : constant C392005_0.Aperture
:= C392005_0.Sixteen;
use type C392005_0.Depth_Of_Field;
use type C392005_0.Shutter_Speed;
use type C392005_0.Aperture;
begin
Report.Test ("C392005", "Dispatching for overridden primitive " &
"subprograms: private extension declared in child unit, " &
"parent is tagged private whose full view is tagged record");
-- Call the class-wide operation for Remote_Camera'Class, which itself makes
-- dispatching calls to Focus and Set_Shutter_Speed:
-- For an object of type Remote_Camera, the dispatching calls should
-- dispatch to the bodies declared for the root type:
C392005_0.Self_Test(Basic_Camera);
if C392005_0.TC_Get_Depth (Basic_Camera) /= TC_Expected_Basic_Depth
or else C392005_0.TC_Get_Speed (Basic_Camera) /= TC_Expected_Basic_Speed
then
Report.Failed ("Calls dispatched incorrectly for root type");
end if;
-- For an object of type Auto_Speed, the dispatching calls should
-- dispatch to the bodies declared for the derived type:
C392005_0.Self_Test(Auto_Camera1);
if C392005_0.C392005_1.TC_Get_Depth(Auto_Camera1) /= TC_Expected_Auto_Depth
or
C392005_0.C392005_1.TC_Get_Speed(Auto_Camera1) /= TC_Expected_Auto_Speed
then
Report.Failed ("Calls dispatched incorrectly for derived type");
end if;
-- For an object of type Auto_Speed, a non-dispatching call to Focus should
-- execute the body declared for the derived type (even through it is
-- declared in the private part).
C392005_0.C392005_1.Focus (Auto_Camera2, Auto_Depth);
if C392005_0.C392005_1.TC_Get_Depth(Auto_Camera2) /= TC_Expected_Auto_Depth
then
Report.Failed ("Non-dispatching call to privately overriding " &
"subprogram executed the wrong body");
end if;
-- For an object of type New_Camera, the initialization using Set_Ap
-- should execute the overridden body, not the inherited one.
if C392005_0.C392005_1.TC_Get_Aper (New_Camera1) /= TC_Expected_New_Aper
then
Report.Failed ("Non-dispatching call to visible overriding " &
"subprogram executed the wrong body");
end if;
Report.Result;
end C392005;
Go to most recent revision | Compare with Previous | Blame | View Log