gomp-20050608-branch/gcc/testsuite/ada/acats/tests/cc/cc54001.a

   1 -- CC54001.A
   2 --
   3 --                             Grant of Unlimited Rights
   4 --
   5 --     Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687,
   6 --     F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained
   7 --     unlimited rights in the software and documentation contained herein.
   8 --     Unlimited rights are defined in DFAR 252.227-7013(a)(19).  By making
   9 --     this public release, the Government intends to confer upon all
  10 --     recipients unlimited rights  equal to those held by the Government.
  11 --     These rights include rights to use, duplicate, release or disclose the
  12 --     released technical data and computer software in whole or in part, in
  13 --     any manner and for any purpose whatsoever, and to have or permit others
  14 --     to do so.
  15 --
  16 --                                    DISCLAIMER
  17 --
  18 --     ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR
  19 --     DISCLOSED ARE AS IS.  THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED
  20 --     WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE
  21 --     SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE
  22 --     OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A
  23 --     PARTICULAR PURPOSE OF SAID MATERIAL.
  24 --*
  25 --
  26 -- OBJECTIVE:
  27 --      Check that a general access-to-constant type may be passed as an
  28 --      actual to a generic formal access-to-constant type.
  29 --
  30 -- TEST DESCRIPTION:
  31 --      The generic implements a stack of access objects as an array. The
  32 --      designated type of the formal access type is itself a formal private
  33 --      type declared in the same generic formal part.
  34 --
  35 --      The generic is instantiated with an unconstrained subtype of String,
  36 --      which results in a stack which can accommodate strings of varying
  37 --      lengths (ragged array). Furthermore, the access objects to be pushed
  38 --      onto the stack are created both statically and dynamically, utilizing
  39 --      allocators and the 'Access attribute.
  40 --
  41 --
  42 -- CHANGE HISTORY:
  43 --      06 Dec 94   SAIC    ACVC 2.0
  44 --      10 Apr 96   SAIC    ACVC 2.1: Added pragma Elaborate to context clause
  45 --                          preceding CC54001_1.
  46 --
  47 --!
  48
  49 generic
  50    Size : in Positive;
  51    type Element_Type (<>) is private;
  52    type Element_Ptr       is access constant Element_Type;
  53 package CC54001_0 is -- Generic stack of pointers.
  54
  55    type Stack_Type is private;
  56
  57    procedure Push (Stack    : in out Stack_Type;
  58                    Elem_Ptr : in     Element_Ptr);
  59
  60    procedure Pop  (Stack    : in out Stack_Type;
  61                    Elem_Ptr :    out Element_Ptr);
  62
  63    -- ... Other operations.
  64
  65 private
  66
  67    subtype Index is Positive range 1 .. (Size + 1);
  68    type Stack_Type is array (Index) of Element_Ptr;  -- Last element unused.
  69
  70    Top : Index := 1;
  71
  72 end CC54001_0;
  73
  74
  75      --===================================================================--
  76
  77
  78 package body CC54001_0 is
  79
  80    procedure Push (Stack    : in out Stack_Type;
  81                    Elem_Ptr : in     Element_Ptr) is
  82    begin
  83       Stack(Top) := Elem_Ptr;
  84       Top := Top + 1;  -- Artificial: no Constraint_Error protection.
  85    end Push;
  86
  87
  88    procedure Pop (Stack    : in out Stack_Type;
  89                   Elem_Ptr :    out Element_Ptr) is
  90    begin
  91       Top := Top - 1;  -- Artificial: no Constraint_Error protection.
  92       Elem_Ptr := Stack(Top);
  93    end Pop;
  94
  95 end CC54001_0;
  96
  97
  98      --===================================================================--
  99
 100
 101 with CC54001_0;      -- Generic stack of pointers.
 102 pragma Elaborate (CC54001_0);
 103
 104 package CC54001_1 is
 105
 106    subtype Message     is String;
 107    type    Message_Ptr is access constant Message;
 108
 109    Message_Count : constant := 4;
 110
 111    Message_0 : aliased constant Message := "Hello";
 112    Message_1 : aliased constant Message := "Doctor";
 113    Message_2 : aliased constant Message := "Name";
 114    Message_3 : aliased constant Message := "Continue";
 115
 116
 117    package Stack_of_Messages is new CC54001_0
 118      (Element_Type => Message,
 119       Element_Ptr  => Message_Ptr,
 120       Size         => Message_Count);
 121
 122    Message_Stack : Stack_Of_Messages.Stack_Type;
 123
 124
 125    procedure Create_Message_Stack;
 126
 127 end CC54001_1;
 128
 129
 130      --===================================================================--
 131
 132
 133 package body CC54001_1 is
 134
 135    procedure Create_Message_Stack is
 136       -- Push access objects onto stack. Note that some are statically
 137       -- allocated, and some are dynamically allocated (using an aliased
 138       -- object to initialize).
 139    begin
 140       Stack_Of_Messages.Push (Message_Stack, Message_0'Access); -- Static.
 141       Stack_Of_Messages.Push (Message_Stack,
 142                               new Message'(Message_1));         -- Dynamic.
 143       Stack_Of_Messages.Push (Message_Stack, Message_2'Access); -- Static.
 144       Stack_Of_Messages.Push (Message_Stack,                    -- Dynamic.
 145                               new Message'(Message_3));
 146    end Create_Message_Stack;
 147
 148 end CC54001_1;
 149
 150
 151      --===================================================================--
 152
 153
 154 with CC54001_1;
 155
 156 with Report;
 157 procedure CC54001 is
 158
 159    package Messages renames CC54001_1.Stack_Of_Messages;
 160
 161    Msg0, Msg1, Msg2, Msg3 : CC54001_1.Message_Ptr;
 162
 163 begin
 164    Report.Test ("CC54001", "Check that a general access-to-constant type "   &
 165                            "may be passed as an actual to a generic formal " &
 166                            "access-to-constant type");
 167
 168    CC54001_1.Create_Message_Stack;
 169
 170    Messages.Pop (CC54001_1.Message_Stack, Msg3);  -- Pop items off stack in the
 171    Messages.Pop (CC54001_1.Message_Stack, Msg2);  -- reverse order that they
 172    Messages.Pop (CC54001_1.Message_Stack, Msg1);  -- were pushed.
 173    Messages.Pop (CC54001_1.Message_Stack, Msg0);
 174
 175    if Msg0.all /= CC54001_1.Message_0 or else
 176       Msg1.all /= CC54001_1.Message_1 or else
 177       Msg2.all /= CC54001_1.Message_2 or else
 178       Msg3.all /= CC54001_1.Message_3
 179    then
 180       Report.Failed ("Items popped off of stack do not match those pushed");
 181    end if;
 182
 183    Report.Result;
 184 end CC54001;