llvm-gcc-4.2/gcc/testsuite/ada/acats/tests/cc/cc54001.a

-- CC54001.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 general access-to-constant type may be passed as an
--      actual to a generic formal access-to-constant type.
--
-- TEST DESCRIPTION:
--      The generic implements a stack of access objects as an array. The
--      designated type of the formal access type is itself a formal private
--      type declared in the same generic formal part.
--      
--      The generic is instantiated with an unconstrained subtype of String,
--      which results in a stack which can accommodate strings of varying
--      lengths (ragged array). Furthermore, the access objects to be pushed
--      onto the stack are created both statically and dynamically, utilizing
--      allocators and the 'Access attribute.
--
--
-- CHANGE HISTORY:
--      06 Dec 94   SAIC    ACVC 2.0
--      10 Apr 96   SAIC    ACVC 2.1: Added pragma Elaborate to context clause
--                          preceding CC54001_1.
--
--!

generic
   Size : in Positive;
   type Element_Type (<>) is private;
   type Element_Ptr       is access constant Element_Type;
package CC54001_0 is -- Generic stack of pointers.

   type Stack_Type is private;

   procedure Push (Stack    : in out Stack_Type;
                   Elem_Ptr : in     Element_Ptr);

   procedure Pop  (Stack    : in out Stack_Type;
                   Elem_Ptr :    out Element_Ptr);

   -- ... Other operations.

private

   subtype Index is Positive range 1 .. (Size + 1);
   type Stack_Type is array (Index) of Element_Ptr;  -- Last element unused.

   Top : Index := 1;

end CC54001_0;


     --===================================================================--


package body CC54001_0 is

   procedure Push (Stack    : in out Stack_Type;
                   Elem_Ptr : in     Element_Ptr) is
   begin
      Stack(Top) := Elem_Ptr;
      Top := Top + 1;  -- Artificial: no Constraint_Error protection.
   end Push;


   procedure Pop (Stack    : in out Stack_Type;
                  Elem_Ptr :    out Element_Ptr) is
   begin
      Top := Top - 1;  -- Artificial: no Constraint_Error protection.
      Elem_Ptr := Stack(Top);
   end Pop;

end CC54001_0;


     --===================================================================--


with CC54001_0;      -- Generic stack of pointers.
pragma Elaborate (CC54001_0);

package CC54001_1 is

   subtype Message     is String;
   type    Message_Ptr is access constant Message;

   Message_Count : constant := 4;

   Message_0 : aliased constant Message := "Hello";
   Message_1 : aliased constant Message := "Doctor";
   Message_2 : aliased constant Message := "Name";
   Message_3 : aliased constant Message := "Continue";


   package Stack_of_Messages is new CC54001_0
     (Element_Type => Message,
      Element_Ptr  => Message_Ptr,
      Size         => Message_Count);

   Message_Stack : Stack_Of_Messages.Stack_Type;


   procedure Create_Message_Stack;

end CC54001_1;


     --===================================================================--


package body CC54001_1 is

   procedure Create_Message_Stack is
      -- Push access objects onto stack. Note that some are statically
      -- allocated, and some are dynamically allocated (using an aliased
      -- object to initialize).
   begin
      Stack_Of_Messages.Push (Message_Stack, Message_0'Access); -- Static.
      Stack_Of_Messages.Push (Message_Stack,
                              new Message'(Message_1));         -- Dynamic.
      Stack_Of_Messages.Push (Message_Stack, Message_2'Access); -- Static.
      Stack_Of_Messages.Push (Message_Stack,                    -- Dynamic.
                              new Message'(Message_3));
   end Create_Message_Stack;

end CC54001_1;


     --===================================================================--


with CC54001_1;

with Report;
procedure CC54001 is

   package Messages renames CC54001_1.Stack_Of_Messages;

   Msg0, Msg1, Msg2, Msg3 : CC54001_1.Message_Ptr;

begin
   Report.Test ("CC54001", "Check that a general access-to-constant type "   &
                           "may be passed as an actual to a generic formal " &
                           "access-to-constant type");

   CC54001_1.Create_Message_Stack;

   Messages.Pop (CC54001_1.Message_Stack, Msg3);  -- Pop items off stack in the
   Messages.Pop (CC54001_1.Message_Stack, Msg2);  -- reverse order that they
   Messages.Pop (CC54001_1.Message_Stack, Msg1);  -- were pushed.
   Messages.Pop (CC54001_1.Message_Stack, Msg0);

   if Msg0.all /= CC54001_1.Message_0 or else
      Msg1.all /= CC54001_1.Message_1 or else
      Msg2.all /= CC54001_1.Message_2 or else
      Msg3.all /= CC54001_1.Message_3
   then
      Report.Failed ("Items popped off of stack do not match those pushed");
   end if;

   Report.Result;
end CC54001;