--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gcc/testsuite/ada/acats/tests/c3/c392d03.a	Fri Oct 27 22:46:09 2017 +0900
@@ -0,0 +1,248 @@
+-- C392D03.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 an inherited dispatching operation that is overridden,
+--      the body executed is the body of the overriding subprogram, even if
+--      the overriding occurs in a private part.
+--
+--      Check for the case where the overriding operation is declared in a
+--      separate (non-child) package from that declaring the parent type, and
+--      the descendant type is a record extension.
+--
+--      Check for both dispatching and nondispatching calls.
+--
+-- TEST DESCRIPTION:
+--      Consider:
+--
+--      package P is
+--         type Root is tagged ...
+--         procedure Op (A: Root);
+--      end P;
+--
+--      with P;
+--      package Q is
+--         type Derived1 is new P.Root with record...
+--         -- Implicit procedure Op (A: Derived1) declared here.
+--         type Derived2 is new P.Root with private...
+--         -- Implicit procedure Op (A: Derived2) declared here.
+--         type New_Derived is new Derived1 with private...
+--         -- Implicit procedure Op (A: New_Derived) declared here.
+--      private
+--         procedure Op (A: Derived1);  -- Overrides parent's Op.
+--         type Derived2 is new P.Root with record...
+--         procedure Op (A: Derived2);  -- Overrides parent's Op.
+--         type New_Derived is new Derived1 with record...
+--         ...
+--      end Q;
+--
+--      Both type Derived1 and Derived2 inherit Op from the parent type Root. 
+--      Type New_Derived inherits (inherited) Op from Derived1.  The inherited 
+--      operation is implicitly declared immediately after the type extension.  
+--      The inherited operation is overridden by an explicit declaration in 
+--      the private part. Even though the overriding operation is private, 
+--      calls to Op with an operand of tag Derived1, Derived2, or New_Derived
+--      will execute the body of the overriding operation.
+--
+-- TEST FILES:
+--      The following files comprise this test:
+--
+--         F392D00.A
+--         C392D03.A
+--
+--
+-- CHANGE HISTORY:
+--      06 Dec 94   SAIC    ACVC 2.0
+--
+--!
+
+with F392D00;
+package C392D03_0 is
+
+   type Aperture is (Eight, Sixteen);     
+
+   type Auto_Focus is new F392D00.Remote_Camera with record
+      -- ...
+      FStop : Aperture;
+   end record;
+
+   -- Implicit procedure Focus (C     : in out Auto_Focus;
+   --                           Depth : in     Depth_Of_Field) declared here.
+
+   type Auto_Flashing is new F392D00.Remote_Camera with private;
+
+   -- Implicit procedure Focus (C     : in out Auto_Flashing;
+   --                           Depth : in     Depth_Of_Field) declared here.
+
+   type Special_Focus is new Auto_Focus with private;
+
+   -- Implicit procedure Focus (C     : in out Special_Focus;
+   --                           Depth : in     Depth_Of_Field) declared here.
+
+   -- ...Other operations.
+
+private
+
+   procedure Focus (C     : in out Auto_Focus;              -- Overrides
+                    Depth : in     F392D00.Depth_Of_Field); -- parent's op.
+
+   -- For the improved remote camera, focus is set automatically, so it is
+   -- declared as a private operation.
+
+   type Auto_Flashing is new F392D00.Remote_Camera with null record;
+
+   procedure Focus (C     : in out Auto_Flashing;           -- Overrides
+                    Depth : in     F392D00.Depth_Of_Field); -- parent's op.
+
+   type Special_Focus is new Auto_Focus with null record;
+
+end C392D03_0;
+
+
+     --==================================================================--
+
+
+package body C392D03_0 is
+
+   procedure Focus (C     : in out Auto_Focus;
+                    Depth : in     F392D00.Depth_Of_Field) is
+   begin
+      -- Artificial for testing purposes.
+      C.DOF := 52;
+   end Focus;
+
+   -----------------------------------------------------------
+   procedure Focus (C     : in out Auto_Flashing;
+                    Depth : in     F392D00.Depth_Of_Field) is
+   begin
+      -- Artificial for testing purposes.
+      C.DOF := 91;
+   end Focus;
+
+end C392D03_0;
+
+
+     --==================================================================--
+
+
+with F392D00;
+with C392D03_0;
+
+with Report;
+
+procedure C392D03 is
+
+   type Focus_Ptr is access procedure 
+     (P1 : in out C392D03_0.Auto_Focus;
+      P2 : in F392D00.Depth_Of_Field);
+
+   Basic_Camera   : F392D00.Remote_Camera;
+   Auto_Camera1   : C392D03_0.Auto_Focus;
+   Auto_Camera2   : C392D03_0.Auto_Focus;
+   Flash_Camera1  : C392D03_0.Auto_Flashing;
+   Flash_Camera2  : C392D03_0.Auto_Flashing;
+   Special_Camera : C392D03_0.Special_Focus;
+   Auto_Depth     : F392D00.Depth_Of_Field := 78;
+
+   TC_Expected_Basic_Depth : constant F392D00.Depth_Of_Field := 46;
+   TC_Expected_Auto_Depth  : constant F392D00.Depth_Of_Field := 52;
+   TC_Expected_Depth       : constant F392D00.Depth_Of_Field := 91;
+
+   FP : Focus_Ptr := C392D03_0.Focus'Access;
+
+   use type F392D00.Depth_Of_Field;
+
+begin
+   Report.Test ("C392D03", "Dispatching for overridden primitive " &
+                "subprograms: record extension declared in non-child " &
+                "package, parent is tagged record");
+
+
+-- Call the class-wide operation for Remote_Camera'Class, which itself makes
+-- a dispatching call to Focus:
+
+   -- For an object of type Remote_Camera, the dispatching call should
+   -- dispatch to the body declared for the root type:
+     
+   F392D00.Self_Test(Basic_Camera);
+
+   if Basic_Camera.DOF /= TC_Expected_Basic_Depth then
+      Report.Failed ("Call dispatched incorrectly for root type");
+   end if;
+
+
+   -- For an object of type Auto_Focus, the dispatching call should
+   -- dispatch to the body declared for the derived type:
+     
+   F392D00.Self_Test(Auto_Camera1);
+
+   if Auto_Camera1.DOF /= TC_Expected_Auto_Depth then
+      Report.Failed ("Call dispatched incorrectly for Auto_Focus type");
+   end if;
+
+
+   -- For an object of type Auto_Flash, the dispatching call should
+   -- also dispatch to the body declared for the derived type:
+
+   F392D00.Self_Test(Flash_Camera1);
+
+   if Flash_Camera1.DOF /= TC_Expected_Depth then
+      Report.Failed ("Call dispatched incorrectly for Auto_Flash type");
+   end if;
+
+   -- For an object of Auto_Flash type, a non-dispatching call to Focus should 
+   -- execute the body declared for the derived type (even through it is 
+   -- declared in the private part).
+
+   C392D03_0.Focus (Flash_Camera2, Auto_Depth);
+
+   if Flash_Camera2.DOF /= TC_Expected_Depth then
+      Report.Failed ("Non-dispatching call to privately overriding " &
+                     "subprogram executed the wrong body");
+   end if;
+
+   -- For an object of Auto_Focus type, a non-dispatching call to Focus should 
+   -- execute the body declared for the derived type (even through it is 
+   -- declared in the private part).
+
+   FP.all (Auto_Camera2, Auto_Depth);
+
+   if Auto_Camera2.DOF /= TC_Expected_Auto_Depth then
+      Report.Failed ("Non-dispatching call by using access to overriding " &
+                     "subprogram executed the wrong body");
+   end if;
+
+   -- For an object of type Special_Camera, the dispatching call should
+   -- also dispatch to the body declared for the derived type:
+
+   F392D00.Self_Test(Special_Camera);
+
+   if Special_Camera.DOF /= TC_Expected_Auto_Depth then
+      Report.Failed ("Call dispatched incorrectly for Special_Camera type");
+   end if;
+
+   Report.Result;
+
+end C392D03;