--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gcc/testsuite/ada/acats/tests/cc/cc51d01.a	Fri Oct 27 22:46:09 2017 +0900
@@ -0,0 +1,262 @@
+-- CC51D01.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, in an instance, each implicit declaration of a user-defined
+--      subprogram of a formal private extension declares a view of the
+--      corresponding primitive subprogram of the ancestor, and that if the
+--      tag in a call is statically determined to be that of the formal type,
+--      the body executed will be that corresponding to the actual type.
+--
+--      Check subprograms declared within a generic formal package. Check for
+--      the case where the actual type passed to the formal private extension
+--      is a specific tagged type. Check for several types in the same class.
+--
+--
+-- TEST DESCRIPTION:
+--      Declare a list abstraction in a generic package which manages lists of
+--      elements of any nonlimited type (foundation code). Declare a package
+--      which declares a tagged type and a type derived from it. Declare an
+--      operation for the root tagged type and override it for the derived
+--      type. Derive a type from this derived type, but do not override the
+--      operation. Declare a generic subprogram which operates on lists of
+--      elements of tagged types. Provide the generic subprogram with two
+--      formal parameters: (1) a formal derived tagged type which represents a
+--      list element type, and (2) a generic formal package with the list
+--      abstraction package as template. Use the formal derived type as the
+--      generic formal actual part for the formal package. Within the generic
+--      subprogram, call the operation of the root tagged type. In the main
+--      program, instantiate the generic list package and the generic
+--      subprogram with the root tagged type and each derivative, then call
+--      each instance with an object of the appropriate type.
+--
+-- TEST FILES:
+--      The following files comprise this test:
+--
+--         FC51D00.A
+--      -> CC51D01.A
+--
+--
+-- CHANGE HISTORY:
+--      06 Dec 94   SAIC    ACVC 2.0
+--      04 Jan 95   SAIC    Moved declaration of type Ranked_ID_Type from
+--                          main subprogram to package CC51D01_0. Removed
+--                          case passing class-wide actual to instance.
+--                          Updated test description and modified comments.
+--
+--!
+
+package CC51D01_0 is -- This package simulates support for a personnel
+                     -- database.
+
+   type SSN_Type is new String (1 .. 9);
+
+   type Blind_ID_Type is tagged record                   -- Root type of
+      SSN : SSN_Type;                                    -- class.
+      -- ... Other components.
+   end record;
+
+   procedure Update_ID (Item : in out Blind_ID_Type);    -- Parent operation.
+
+   -- ... Other operations.
+
+
+   type Name_Type is new String (1 .. 9);
+
+   type Named_ID_Type is new Blind_ID_Type with record   -- Direct derivative
+      Name : Name_Type := "Doe      ";                   -- of root type.
+      -- ... Other components.
+   end record;
+
+   -- Inherits Update_ID from parent.
+
+   procedure Update_ID (Item : in out Named_ID_Type);    -- Overrides parent's
+                                                         -- implementation.
+
+
+   type Ranked_ID_Type is new Named_ID_Type with record
+      Level : Integer := 0;                              -- Indirect derivative
+      -- ... Other components.                           -- of root type.
+   end record;
+
+   -- Inherits Update_ID from parent.
+
+end CC51D01_0;
+
+
+     --==================================================================--
+
+
+package body CC51D01_0 is
+
+   -- The implementations of Update_ID are purely artificial; the validity of
+   -- their implementations in the context of the abstraction is irrelevant to
+   -- the feature being tested.
+
+   procedure Update_ID (Item : in out Blind_ID_Type) is
+   begin
+      Item.SSN := "111223333";
+   end Update_ID;
+
+
+   procedure Update_ID (Item : in out Named_ID_Type) is
+   begin
+      Item.SSN := "444556666";
+      -- ... Other stuff.
+   end Update_ID;
+
+end CC51D01_0;
+
+
+     --==================================================================--
+
+
+--                           --
+-- Formal package used here. --
+--                           --
+
+with FC51D00;    -- Generic list abstraction.
+with CC51D01_0;  -- Tagged type declarations.
+generic          -- This procedure simulates a generic operation for types
+                 -- in the class rooted at Blind_ID_Type.
+   type Elem_Type is new CC51D01_0.Blind_ID_Type with private;
+   with package List_Mgr is new FC51D00 (Elem_Type);
+procedure CC51D01_1 (L : in out List_Mgr.List_Type; E : in Elem_Type);
+
+
+     --==================================================================--
+
+
+-- The implementation of CC51D01_1 is purely artificial; the validity
+-- of its implementation in the context of the abstraction is irrelevant
+-- to the feature being tested.
+--
+-- The expected behavior here is as follows: for each actual type corresponding
+-- to Elem_Type, the call to Update_ID should invoke the actual type's
+-- implementation, which updates the object's SSN field. Write_Element then
+-- adds the object to the list.
+
+procedure CC51D01_1 (L : in out List_Mgr.List_Type; E : in Elem_Type) is
+   Element : Elem_Type := E;   -- Can't update IN parameter.
+begin
+   Update_ID (Element);                    -- Executes actual type's version.
+   List_Mgr.Write_Element (1, L, Element); -- Executes actual type's version.
+end CC51D01_1;
+
+
+     --==================================================================--
+
+
+with FC51D00;    -- Generic list abstraction.
+with CC51D01_0;  -- Tagged type declarations.
+with CC51D01_1;  -- Generic operation.
+
+with Report;
+procedure CC51D01 is
+
+   use CC51D01_0;                                        -- All types & ops
+                                                         -- directly visible.
+
+   -- Begin test code declarations: -----------------------
+
+   TC_Expected_1 : Blind_ID_Type       := (SSN => "111223333");
+   TC_Expected_2 : Named_ID_Type       := ("444556666", "Doe      ");
+   TC_Expected_3 : Ranked_ID_Type      := ("444556666", "Doe      ", 0);
+
+   TC_Initial_1  : Blind_ID_Type       := (SSN => "777889999");
+   TC_Initial_2  : Named_ID_Type       := ("777889999", "Doe      ");
+   TC_Initial_3  : Ranked_ID_Type      := ("777889999", "Doe      ", 0);
+
+   -- End test code declarations. -------------------------
+
+
+   -- Begin instantiations and list declarations: ---------
+
+   -- At this point in an application, the generic list package would be
+   -- instantiated for one of the visible tagged types. Next, the generic
+   -- subprogram would be instantiated for the same tagged type and the
+   -- preceding list package instance.
+   --
+   -- In order to cover all the important cases, this test instantiates several
+   -- packages and subprograms (probably more than would typically appear
+   -- in user code).
+
+   -- Support for lists of blind IDs:
+
+   package Blind_Lists is new FC51D00 (Blind_ID_Type);
+   procedure Update_and_Write is new CC51D01_1 (Blind_ID_Type, Blind_Lists);
+   Blind_List : Blind_Lists.List_Type;
+
+
+   -- Support for lists of named IDs:
+
+   package Named_Lists is new FC51D00 (Named_ID_Type);
+   procedure Update_and_Write is new                     -- Overloads subprog
+     CC51D01_1 (Elem_Type => Named_ID_Type,              -- for Blind_ID_Type.
+                List_Mgr  => Named_Lists);
+   Named_List : Named_Lists.List_Type;
+
+
+   -- Support for lists of ranked IDs:
+
+   package Ranked_Lists is new FC51D00 (Ranked_ID_Type);
+   procedure Update_and_Write is new                     -- Overloads.
+     CC51D01_1 (Elem_Type => Ranked_ID_Type,
+                List_Mgr  => Ranked_Lists);
+   Ranked_List : Ranked_Lists.List_Type;
+
+   -- End instantiations and list declarations. -----------
+
+
+begin
+   Report.Test ("CC51D01", "Formal private extension, specific tagged "   &
+                "type actual: body of primitive subprogram executed is "  &
+                "that of actual type. Check for subprograms declared in " &
+                "a formal package");
+
+
+   Update_and_Write (Blind_List, TC_Initial_1);
+
+   if (Blind_Lists.View_Element (1, Blind_List) /= TC_Expected_1) then
+      Report.Failed ("Wrong result for root tagged type");
+   end if;
+
+
+   Update_and_Write (Named_List, TC_Initial_2);
+
+   if (Named_Lists.View_Element (1, Named_List) /= TC_Expected_2) then
+      Report.Failed ("Wrong result for type derived directly from root");
+   end if;
+
+
+   Update_and_Write (Ranked_List, TC_Initial_3);
+
+   if (Ranked_Lists.View_Element (1, Ranked_List) /= TC_Expected_3) then
+      Report.Failed ("Wrong result for type derived indirectly from root");
+   end if;
+
+
+   Report.Result;
+end CC51D01;