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/] [c392c07.a] - Rev 384
Compare with Previous | Blame | View Log
-- C392C07.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 a call to a dispatching subprogram the subprogram
-- body which is executed is determined by the controlling tag for
-- the case where the call has dynamic tagged controlling operands
-- of the type T. Check for calls to these same subprograms where
-- the operands are of specific statically tagged types:
-- objects (declared or allocated), formal parameters, view
-- conversions, and function calls (both primitive and non-primitive).
--
-- TEST DESCRIPTION:
-- This test uses foundation F392C00 to test the usages of statically
-- tagged objects and values. This test is derived in part from
-- C392C05.
--
--
-- CHANGE HISTORY:
-- 06 Dec 94 SAIC ACVC 2.0
-- 24 Oct 95 SAIC Updated for ACVC 2.0.1
--
--!
with Report;
with TCTouch;
with F392C00_1;
procedure C392C07 is -- Hardware_Store
package Switch renames F392C00_1;
subtype Switch_Class is Switch.Toggle'Class;
type Reference is access all Switch_Class;
A_Switch : aliased Switch.Toggle;
A_Dimmer : aliased Switch.Dimmer;
An_Autodim : aliased Switch.Auto_Dimmer;
type Light_Bank is array(Positive range <>) of Reference;
Lamps : Light_Bank(1..3);
-- dynamically tagged controlling operands : class wide formal parameters
procedure Clamp( Device : in out Switch_Class; On : Boolean := False ) is
begin
if Switch.On( Device ) /= On then
Switch.Flip( Device );
end if;
end Clamp;
function Class_Item(Bank_Pos: Positive) return Switch_Class is
begin
return Lamps(Bank_Pos).all;
end Class_Item;
begin -- Main test procedure.
Report.Test ("C392C07", "Check that a dispatching subprogram call is "
& "determined by the controlling tag for "
& "dynamically tagged controlling operands" );
Lamps := ( A_Switch'Access, A_Dimmer'Access, An_Autodim'Access );
-- dynamically tagged operands referring to
-- statically tagged declared objects
for Knob in Lamps'Range loop
Clamp( Lamps(Knob).all, On => True );
end loop;
TCTouch.Validate( "BABGBABKGBA", "Clamping On Lamps" );
Lamps(1) := new Switch.Toggle;
Lamps(2) := new Switch.Dimmer;
Lamps(3) := new Switch.Auto_Dimmer;
-- turn the full bank of switches ON
-- dynamically tagged allocated objects
for Knob in Lamps'Range loop
Clamp( Lamps(Knob).all, On => True );
end loop;
TCTouch.Validate( "BABGBABKGBA", "Dynamic Allocated");
-- Double check execution correctness
if Switch.Off( Lamps(1).all )
or Switch.Off( Lamps(2).all )
or Switch.Off( Lamps(3).all ) then
Report.Failed( "Bad Value" );
end if;
TCTouch.Validate( "CCC", "Class-wide");
-- turn the full bank of switches OFF
for Knob in Lamps'Range loop
Switch.Flip( Lamps(Knob).all );
end loop;
TCTouch.Validate( "AGBAKGBA", "Dynamic Allocated, Primitive Ops");
-- check switches for OFF
-- a few function calls as operands
for Knob in Lamps'Range loop
if not Switch.Off( Class_Item(Knob) ) then
Report.Failed("At function tests, Switch not OFF");
end if;
end loop;
TCTouch.Validate( "CCC",
"Using function returning class-wide type");
-- Switches are all OFF now.
-- dynamically tagged view conversion
Clamp( Switch_Class( A_Switch ) );
Clamp( Switch_Class( A_Dimmer ) );
Clamp( Switch_Class( An_Autodim ) );
TCTouch.Validate( "BABGBABKGBA", "View Conversions" );
-- dynamically tagged controlling operands : declared class wide objects
-- calling primitive functions
declare
Dine_O_Might : Switch_Class := Switch.TC_CW_TI( 't' );
begin
Switch.Flip( Dine_O_Might );
if Switch.On( Dine_O_Might ) then
Report.Failed( "Exploded at Dine_O_Might" );
end if;
TCTouch.Validate( "WAB", "Dispatching function 1" );
end;
declare
Dyne_A_Mite : Switch_Class := Switch.TC_CW_TI( 'd' );
begin
Switch.Flip( Dyne_A_Mite );
if Switch.On( Dyne_A_Mite ) then
Report.Failed( "Exploded at Dyne_A_Mite" );
end if;
TCTouch.Validate( "WGBAB", "Dispatching function 2" );
end;
declare
Din_Um_Out : Switch_Class := Switch.TC_CW_TI( 'a' );
begin
Switch.Flip( Din_Um_Out );
if Switch.Off( Din_Um_Out ) then
Report.Failed( "Exploded at Din_Um_Out" );
end if;
TCTouch.Validate( "WKCC", "Dispatching function 3" );
-- Non-dispatching function calls.
if not Switch.TC_Non_Disp( Switch.Toggle( Din_Um_Out ) ) then
Report.Failed( "Non primitive, via view conversion" );
end if;
TCTouch.Validate( "X", "View Conversion 1" );
if not Switch.TC_Non_Disp( Switch.Dimmer( Din_Um_Out ) ) then
Report.Failed( "Non primitive, via view conversion" );
end if;
TCTouch.Validate( "Y", "View Conversion 2" );
end;
-- a few more function calls as operands (oops)
if not Switch.On( Switch.Toggle'( Switch.Create ) ) then
Report.Failed("Toggle did not create ""On""");
end if;
if Switch.Off( Switch.Dimmer'( Switch.Create ) ) then
Report.Failed("Dimmer created ""Off""");
end if;
if Switch.Off( Switch.Auto_Dimmer'( Switch.Create ) ) then
Report.Failed("Auto_Dimmer created ""Off""");
end if;
Report.Result;
end C392C07;