llvm-gcc-4.0/gcc/testsuite/ada/acats/tests/c3/c392c07.a

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