--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/gcc/testsuite/ada/acats/tests/cc/cc50a01.a	Fri Oct 27 22:46:09 2017 +0900
@@ -0,0 +1,313 @@
+-- CC50A01.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 a formal parameter of a library-level generic unit may be
+--      a formal tagged private type. Check that a nonlimited tagged type may
+--      be passed as an actual. Check that if the formal type is indefinite,
+--      both indefinite and definite types may be passed as actuals.
+--
+-- TEST DESCRIPTION:
+--      The generic package declares a formal tagged private type (this can
+--      be considered the parent "mixin" class). This type is extended in
+--      the generic to provide support for stacks of items of any nonlimited
+--      tagged type. Stacks are modeled as singly linked lists, with the list
+--      nodes being objects of the extended type.
+--
+--      A generic testing procedure pushes items onto a stack, and pops them
+--      back off, verifying the state of the stack at various points along the
+--      way. The push and pop routines exercise functionality important to
+--      tagged types, such as type conversion toward the root of the derivation
+--      class and extension aggregates.
+--
+--      The formal tagged private type has an unknown discriminant part, and
+--      is thus indefinite. This allows both definite and indefinite types
+--      to be passed as actuals. For tagged types, definite implies
+--      nondiscriminated, and indefinite implies discriminated (with known
+--      or unknown discriminants). 
+--
+-- TEST FILES:
+--      This test consists of the following files:
+--
+--         FC50A00.A
+--      -> CC50A01.A
+--
+--
+-- CHANGE HISTORY:
+--      06 Dec 94   SAIC    ACVC 2.0
+--      21 Nov 95   SAIC    ACVC 2.0.1 fixes: Moved instantiations of
+--                          BC50A01_0 to library level.
+--      11 Aug 96   SAIC    ACVC 2.1: Updated prologue. Added pragma
+--                          Elaborate to context clauses for CC50A01_2 & _3.
+--
+--!
+
+with FC50A00;  -- Tagged (actual) type declarations.
+generic        -- Generic stack abstraction.
+
+   type Item (<>) is tagged private;            -- Formal tagged private type.
+   TC_Default_Value : Item;                     -- Needed in View_Top (see
+                                                -- below).
+package CC50A01_0 is
+
+   type Stack is private;
+
+-- Note that because the actual type corresponding to Item may be
+-- unconstrained, the functions of removing the top item from the stack and
+-- returning the value of the top item of the stack have been separated into
+-- Pop and View_Top, respectively. This is necessary because otherwise the
+-- returned value would have to be an out parameter of Pop, which would
+-- require the user (in the unconstrained case) to create an uninitialized
+-- unconstrained object to serve as the actual, which is illegal.
+
+   procedure Push     (I : in Item; S : in out Stack);
+   procedure Pop      (S : in out Stack);
+   function  View_Top (S : Stack) return Item;
+
+   function Size_Of (S : Stack) return Natural;
+
+private
+
+   type Stack_Item;
+   type Stack_Ptr is access Stack_Item;
+
+   type Stack_Item is new Item with record      -- Extends formal type.
+      Next : Stack_Ptr := null;
+   end record;
+
+   type Stack is record
+      Top  : Stack_Ptr := null;
+      Size : Natural   := 0;
+   end record;
+
+end CC50A01_0;
+
+
+     --==================================================================--
+
+
+package body CC50A01_0 is
+
+   -- Link NewItem in at the top of the stack (the extension aggregate within
+   -- the allocator initializes the inherited portion of NewItem to equal I,
+   -- and NewItem.Next to point to what S.Top points to).
+
+   procedure Push (I : in Item; S : in out Stack) is
+      NewItem : Stack_Ptr;
+   begin
+      NewItem := new Stack_Item'(I with S.Top);     -- Extension aggregate.
+      S.Top   := NewItem;
+      S.Size  := S.Size + 1;
+   end Push;
+
+
+   -- Remove item from top of stack. This procedure only updates the state of
+   -- the stack; it does not return the value of the popped item. Hence, in
+   -- order to accomplish a "true" pop, both View_Top and Pop must be called
+   -- consecutively.
+   --
+   -- If the stack is empty, the Pop is ignored (for simplicity; in a true
+   -- application this might be treated as an error condition).
+
+   procedure Pop (S : in out Stack) is
+   begin
+      if S.Top = null then                          -- Stack is empty.
+         null;
+         -- Raise exception.
+      else
+         S.Top  := S.Top.Next;
+         S.Size := S.Size - 1;
+         -- Deallocate discarded node.
+      end if;
+   end Pop;
+
+
+   -- Return the value of the top item on the stack. This procedure only
+   -- returns the value; it does not remove the top item from the stack.
+   -- Hence, in order to accomplish a "true" pop, both View_Top and Pop must
+   -- be called consecutively.
+   --
+   -- Since items on the stack are of a type (Stack_Item) derived from Item,
+   -- which is a (tagged) private type, type conversion toward the root is the
+   -- only way to get a value of type Item for return to the caller.
+   --
+   -- If the stack is empty, View_Top returns a pre-specified default value.
+   -- (In a true application, an exception might be raised instead).
+
+   function View_Top (S : Stack) return Item is
+   begin
+      if S.Top = null then                          -- Stack is empty.
+         return TC_Default_Value;                   -- Testing artifice.
+         -- Raise exception.
+      else
+         return Item(S.Top.all);                    -- Type conversion.
+      end if;
+   end View_Top;
+
+
+   function Size_Of (S : Stack) return Natural is
+   begin
+      return (S.Size);
+   end Size_Of;
+
+
+end CC50A01_0;
+
+
+     --==================================================================--
+
+
+-- The formal package Stacker below is needed to gain access to the
+-- appropriate version of the "generic" type Stack. It is provided with an
+-- explicit actual part in order to restrict the packages that can be passed
+-- as actuals to those which have been instantiated with the same actuals
+-- which this generic procedure has been instantiated with.
+
+with CC50A01_0;  -- Generic stack abstraction.
+generic
+   type Item_Type (<>) is tagged private;       -- Formal tagged private type.
+   Default : Item_Type;
+   with package Stacker is new CC50A01_0 (Item_Type, Default);
+procedure CC50A01_1 (S : in out Stacker.Stack; I : in Item_Type);
+
+
+     --==================================================================--
+
+--
+-- This generic procedure performs all of the testing of the
+-- stack abstraction.
+--
+
+with Report;
+procedure CC50A01_1 (S : in out Stacker.Stack; I : in Item_Type) is
+begin
+   Stacker.Push (I, S);                    -- Push onto empty stack.
+   Stacker.Push (I, S);                    -- Push onto nonempty stack.
+
+   if Stacker.Size_Of (S) /= 2 then
+      Report.Failed ("   Wrong stack size after 2 Pushes");
+   end if;
+
+   -- Calls to View_Top must initialize a declared object of type Item_Type
+   -- because the type may be unconstrained.
+
+   declare
+      Buffer1 : Item_Type := Stacker.View_Top (S);
+   begin
+      Stacker.Pop (S);                     -- Pop item off nonempty stack.
+      if Buffer1 /= I then
+         Report.Failed ("   Wrong stack item value after 1st Pop");
+      end if;
+   end;
+
+   declare
+      Buffer2 : Item_Type := Stacker.View_Top (S);
+   begin
+      Stacker.Pop (S);                     -- Pop last item off stack.
+      if Buffer2 /= I then
+         Report.Failed ("   Wrong stack item value after 2nd Pop");
+      end if;
+   end;
+
+   if Stacker.Size_Of (S) /= 0 then
+      Report.Failed ("   Wrong stack size after 2 Pops");
+   end if;
+
+   declare
+      Buffer3 : Item_Type := Stacker.View_Top (S);
+   begin
+      if Buffer3 /= Default then
+         Report.Failed ("   Wrong result after Pop of empty stack");
+      end if;
+      Stacker.Pop (S);                     -- Pop off empty stack.
+   end;
+
+end CC50A01_1;
+
+
+     --==================================================================--
+
+
+with FC50A00;
+
+with CC50A01_0;
+pragma Elaborate (CC50A01_0);
+
+package CC50A01_2 is new CC50A01_0 (FC50A00.Count_Type,
+                                    FC50A00.TC_Default_Count);
+
+
+     --==================================================================--
+
+
+with FC50A00;
+
+with CC50A01_0;
+pragma Elaborate (CC50A01_0);
+
+package CC50A01_3 is new CC50A01_0 (FC50A00.Person_Type,
+                                    FC50A00.TC_Default_Person);
+
+
+     --==================================================================--
+
+
+with FC50A00;   -- Tagged (actual) type declarations.
+with CC50A01_0; -- Generic stack abstraction.
+with CC50A01_1; -- Generic stack testing procedure.
+with CC50A01_2;
+with CC50A01_3;
+
+with Report;
+procedure CC50A01 is
+
+   package Count_Stacks  renames CC50A01_2;
+   package Person_Stacks renames CC50A01_3;
+
+
+   procedure TC_Count_Test is new CC50A01_1 (FC50A00.Count_Type,
+                                             FC50A00.TC_Default_Count,
+                                             Count_Stacks);
+   Count_Stack : Count_Stacks.Stack;
+
+ 
+   procedure TC_Person_Test is new CC50A01_1 (FC50A00.Person_Type,
+                                              FC50A00.TC_Default_Person,
+                                              Person_Stacks);
+   Person_Stack : Person_Stacks.Stack;
+
+begin
+   Report.Test ("CC50A01", "Check that a formal parameter of a " &
+                "library-level generic unit may be a formal tagged " &
+                "private type");
+
+   Report.Comment ("Testing definite tagged type..");
+   TC_Count_Test  (Count_Stack,  FC50A00.TC_Count_Item);
+
+   Report.Comment ("Testing indefinite tagged type..");
+   TC_Person_Test (Person_Stack, FC50A00.TC_Person_Item);
+
+   Report.Result;
+end CC50A01;