--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gcc/testsuite/ada/acats/tests/c3/c392011.a	Fri Oct 27 22:46:09 2017 +0900
@@ -0,0 +1,299 @@
+-- C392011.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 if a function call with a controlling result is itself
+--     a controlling operand of an enclosing call on a dispatching operation,
+--     then its controlling tag value is determined by the controlling tag
+--     value of the enclosing call.
+--
+-- TEST DESCRIPTION:
+--      The test builds and traverses a "ragged" list; a linked list which
+--      contains data elements of three different types (all rooted at
+--      Level_0'Class).  The traversal of this list checks the objective
+--      by calling the dispatching operation "Check" using an item from the
+--      list, and calling the function create; thus causing the controlling
+--      result of the function to be determined by evaluating the value of
+--      the other controlling parameter to the two-parameter Check.
+--
+--
+-- CHANGE HISTORY:
+--      22 SEP 95   SAIC   Initial version
+--      23 APR 96   SAIC   Corrected commentary, differentiated integer.
+--
+--!
+
+----------------------------------------------------------------- C392011_0
+
+package C392011_0 is
+
+  type Level_0 is tagged record
+    Ch_Item : Character;
+  end record;
+
+  function Create return Level_0;
+    -- primitive dispatching function
+
+  procedure Check( Left, Right: in Level_0 );
+    -- has controlling parameters
+
+end C392011_0;
+
+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
+
+with Report;
+with TCTouch;
+package body C392011_0 is
+
+  The_Character : Character := 'A';
+
+  function Create return Level_0 is
+    Created_Item_0 : constant Level_0 := ( Ch_Item => The_Character );
+  begin
+    The_Character := Character'Succ(The_Character);
+    TCTouch.Touch('A'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- A
+    return Created_Item_0;
+  end Create;
+
+  procedure Check( Left, Right: in Level_0 ) is
+  begin
+    TCTouch.Touch('B'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- B
+  end Check;
+
+end C392011_0;
+
+----------------------------------------------------------------- C392011_1
+
+with C392011_0;
+package C392011_1 is
+
+  type Level_1 is new C392011_0.Level_0 with record
+    Int_Item : Integer;
+  end record;
+  
+  -- note that Create becomes abstract upon this derivation hence:
+
+  function Create return Level_1;
+
+  procedure Check( Left, Right: in Level_1 );
+
+end C392011_1;
+
+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
+
+with TCTouch;
+package body C392011_1 is
+
+  Integer_1 : Integer := 0;
+
+  function Create return Level_1 is
+    Created_Item_1 : constant Level_1
+                   := ( C392011_0.Create with Int_Item => Integer_1 );
+    -- note call to     ^--------------^   -- A
+  begin
+    Integer_1 := Integer'Succ(Integer_1);
+    TCTouch.Touch('C'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- C
+    return Created_Item_1;
+  end Create;
+
+  procedure Check( Left, Right: in Level_1 ) is
+  begin
+    TCTouch.Touch('D'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- D
+  end Check;
+
+end C392011_1;
+
+----------------------------------------------------------------- C392011_2
+
+with C392011_1;
+package C392011_2 is
+
+  type Level_2 is new C392011_1.Level_1 with record
+    Another_Int_Item : Integer;
+  end record;
+  
+  -- note that Create becomes abstract upon this derivation hence:
+
+  function Create return Level_2;
+
+  procedure Check( Left, Right: in Level_2 );
+
+end C392011_2;
+
+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
+
+with TCTouch;
+package body C392011_2 is
+
+  Integer_2 : Integer := 100;
+
+  function Create return Level_2 is
+    Created_Item_2 : constant Level_2
+                 := ( C392011_1.Create with Another_Int_Item => Integer_2 );
+    -- note call to   ^--------------^   -- AC
+  begin
+    Integer_2 := Integer'Succ(Integer_2);
+    TCTouch.Touch('E'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- E
+    return Created_Item_2;
+  end Create;
+
+  procedure Check( Left, Right: in Level_2 ) is
+  begin
+    TCTouch.Touch('F'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- F
+  end Check;
+
+end C392011_2;
+
+------------------------------------------------------- C392011_2.C392011_3
+
+with C392011_0;
+package C392011_2.C392011_3 is
+
+  type Wide_Reference is access all C392011_0.Level_0'Class;
+
+  type Ragged_Element;
+
+  type List_Pointer is access Ragged_Element;
+
+  type Ragged_Element is record
+    Data : Wide_Reference;
+    Next : List_Pointer;
+  end record;
+
+  procedure Build_List;
+
+  procedure Traverse_List;
+
+end C392011_2.C392011_3;
+
+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
+
+package body C392011_2.C392011_3 is
+
+  The_List : List_Pointer;
+
+  procedure Build_List is
+  begin
+
+    -- build a list that looks like:
+    -- Level_2, Level_1, Level_2, Level_1, Level_0
+    --
+    -- the mechanism is to create each object, "pushing" the existing list
+    -- onto the end: cons( new_item, car, cdr )
+
+    The_List := 
+        new Ragged_Element'( new C392011_0.Level_0'(C392011_0.Create), null );
+    -- Level_0                                                            >> A
+
+    The_List := 
+    new Ragged_Element'( new C392011_1.Level_1'(C392011_1.Create), The_List );
+    -- Level_1 -> Level_0                                                >> AC
+
+    The_List := 
+    new Ragged_Element'( new C392011_2.Level_2'(C392011_2.Create), The_List );
+    -- Level_2 -> Level_1 -> Level_0                                    >> ACE
+
+    The_List := 
+    new Ragged_Element'( new C392011_1.Level_1'(C392011_1.Create), The_List );
+    -- Level_1 -> Level_2 -> Level_1 -> Level_0                          >> AC
+
+    The_List := 
+    new Ragged_Element'( new C392011_2.Level_2'(C392011_2.Create), The_List );
+    -- Level_2 -> Level_1 -> Level_2 -> Level_1 -> Level_0              >> ACE
+
+  end Build_List;
+
+  procedure Traverse_List is
+
+    Next_Item : List_Pointer := The_List;
+
+  -- Check that if a function call with a controlling result is itself
+  -- a controlling operand of an enclosing call on a dispatching operation,
+  -- then its controlling tag value is determined by the controlling tag
+  -- value of the enclosing call.
+
+  -- Level_2 -> Level_1 -> Level_2 -> Level_1 -> Level_0
+
+  begin
+
+    while Next_Item /= null loop  -- here we go!
+      -- these calls better dispatch according to the value in the particular
+      -- list item; causing the call to create to dispatch accordingly.
+      -- why do it twice?  To make sure order makes no difference
+
+      C392011_0.Check(Next_Item.Data.all, C392011_0.Create);
+      -- Create will touch first, then Check touches
+
+      C392011_0.Check(C392011_0.Create, Next_Item.Data.all); 
+
+      -- Here's what's s'pos'd to 'appen:
+      -- Check( Lev_2, Create ) >> ACEF
+      -- Check( Create, Lev_2 ) >> ACEF
+      -- Check( Lev_1, Create ) >> ACD
+      -- Check( Create, Lev_1 ) >> ACD
+      -- Check( Lev_2, Create ) >> ACEF
+      -- Check( Create, Lev_2 ) >> ACEF
+      -- Check( Lev_1, Create ) >> ACD
+      -- Check( Create, Lev_1 ) >> ACD
+      -- Check( Lev_0, Create ) >> AB
+      -- Check( Create, Lev_0 ) >> AB
+
+      Next_Item := Next_Item.Next;   
+    end loop;
+  end Traverse_List;
+
+end C392011_2.C392011_3;
+
+------------------------------------------------------------------- C392011
+
+with Report;
+with TCTouch;
+with C392011_2.C392011_3;
+
+procedure C392011 is
+
+begin  -- Main test procedure.
+
+  Report.Test ("C392011", "Check that if a function call with a " &
+                          "controlling result is itself a controlling " &
+                          "operand of an enclosing call on a dispatching " &
+                          "operation, then its controlling tag value is " &
+                          "determined by the controlling tag value of " &
+                          "the enclosing call" );
+
+  C392011_2.C392011_3.Build_List;
+  TCTouch.Validate( "A" & "AC" & "ACE" & "AC" & "ACE", "Build List" );
+
+  C392011_2.C392011_3.Traverse_List;
+  TCTouch.Validate( "ACEFACEF" & 
+                    "ACDACD" &  
+                    "ACEFACEF" &  
+                    "ACDACD" &  
+                    "ABAB",
+                    "Traverse List" );
+
+  Report.Result;
+
+end C392011;