| -- 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; |