diff options
Diffstat (limited to 'gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392c07.a')
| -rw-r--r-- | gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392c07.a | 190 |
1 files changed, 190 insertions, 0 deletions
diff --git a/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392c07.a b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392c07.a new file mode 100644 index 000000000..f13cc0b01 --- /dev/null +++ b/gcc-4.9/gcc/testsuite/ada/acats/tests/c3/c392c07.a @@ -0,0 +1,190 @@ +-- 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; |