--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gcc/testsuite/ada/acats/tests/c3/c392c07.a	Fri Oct 27 22:46:09 2017 +0900
@@ -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;