gcc/testsuite/ada/acats/tests/cc/cc3019b1.ada

   1 -- CC3019B1.ADA
   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 --  THIS IS GENERIC PACKAGE WHICH IS USED TO CHECK THE LEVEL OF
  26 --  NESTED GENERICS SUPPORTED BY AN IMPLEMENTATION. IT IS USED
  27 --  BY THE MAIN PROCEDURE, I.E., CC3019B2M.ADA.
  28 --
  29 -- *** THIS FILE MUST BE COMPILED AFTER CC3019B0.ADA HAS BEEN
  30 -- *** COMPILED.
  31 --
  32 -- HISTORY:
  33 --         EDWARD V. BERARD, 31 AUGUST 1990
  34
  35 WITH CC3019B0_LIST_CLASS ;
  36
  37 GENERIC
  38
  39      TYPE ELEMENT IS LIMITED PRIVATE ;
  40
  41      WITH PROCEDURE ASSIGN (SOURCE        : IN OUT ELEMENT ;
  42                             DESTINATION   : IN OUT ELEMENT) ;
  43
  44      WITH FUNCTION "=" (LEFT  : IN ELEMENT ;
  45                         RIGHT : IN ELEMENT) RETURN BOOLEAN ;
  46
  47 PACKAGE CC3019B1_STACK_CLASS IS
  48
  49      TYPE STACK IS LIMITED PRIVATE ;
  50
  51      OVERFLOW    : EXCEPTION ;
  52      UNDERFLOW   : EXCEPTION ;
  53
  54      PROCEDURE PUSH (THIS_ELEMENT        : IN OUT ELEMENT ;
  55                      ON_TO_THIS_STACK    : IN OUT STACK) ;
  56
  57      PROCEDURE POP  (THIS_ELEMENT        : IN OUT ELEMENT ;
  58                      OFF_THIS_STACK      : IN OUT STACK) ;
  59
  60      PROCEDURE COPY  (THIS_STACK       : IN OUT STACK ;
  61                       TO_THIS_STACK    : IN OUT STACK) ;
  62
  63      PROCEDURE CLEAR (THIS_STACK       : IN OUT STACK) ;
  64
  65      GENERIC
  66
  67           WITH PROCEDURE PROCESS (THIS_ELEMENT    : IN  ELEMENT ;
  68                                   CONTINUE        : OUT BOOLEAN) ;
  69
  70      PROCEDURE ITERATE (OVER_THIS_STACK    : IN STACK) ;
  71
  72      FUNCTION NUMBER_OF_ELEMENTS (ON_THIS_STACK    : IN STACK)
  73           RETURN NATURAL ;
  74
  75      FUNCTION "=" (LEFT  : IN STACK ;
  76                    RIGHT : IN STACK) RETURN BOOLEAN ;
  77
  78 PRIVATE
  79
  80      PACKAGE NEW_LIST_CLASS IS
  81           NEW CC3019B0_LIST_CLASS (ELEMENT => ELEMENT,
  82                                    ASSIGN  => ASSIGN,
  83                                    "="     => "=") ;
  84
  85      TYPE STACK IS NEW NEW_LIST_CLASS.LIST ;
  86
  87 END CC3019B1_STACK_CLASS ;
  88
  89 PACKAGE BODY CC3019B1_STACK_CLASS IS
  90
  91      PROCEDURE PUSH (THIS_ELEMENT        : IN OUT ELEMENT ;
  92                      ON_TO_THIS_STACK    : IN OUT STACK) IS
  93
  94      BEGIN  -- PUSH
  95
  96           NEW_LIST_CLASS.ADD (
  97                THIS_ELEMENT    => THIS_ELEMENT,
  98                TO_THIS_LIST    =>
  99                     NEW_LIST_CLASS.LIST (ON_TO_THIS_STACK)) ;
 100
 101      EXCEPTION
 102
 103           WHEN NEW_LIST_CLASS.OVERFLOW => RAISE OVERFLOW ;
 104
 105      END PUSH ;
 106
 107      PROCEDURE POP  (THIS_ELEMENT        : IN OUT ELEMENT ;
 108                      OFF_THIS_STACK      : IN OUT STACK) IS
 109
 110      BEGIN  -- POP
 111
 112           NEW_LIST_CLASS.DELETE (
 113                THIS_ELEMENT      => THIS_ELEMENT,
 114                FROM_THIS_LIST    =>
 115                          NEW_LIST_CLASS.LIST (OFF_THIS_STACK)) ;
 116
 117      EXCEPTION
 118
 119           WHEN NEW_LIST_CLASS.UNDERFLOW => RAISE UNDERFLOW ;
 120
 121      END POP ;
 122
 123      PROCEDURE COPY  (THIS_STACK       : IN OUT STACK ;
 124                       TO_THIS_STACK    : IN OUT STACK) IS
 125
 126      BEGIN  -- COPY
 127
 128           NEW_LIST_CLASS.COPY (
 129                THIS_LIST    => NEW_LIST_CLASS.LIST (THIS_STACK),
 130                TO_THIS_LIST => NEW_LIST_CLASS.LIST (TO_THIS_STACK)) ;
 131
 132      END COPY ;
 133
 134      PROCEDURE CLEAR (THIS_STACK        : IN OUT STACK) IS
 135
 136      BEGIN  -- CLEAR
 137
 138           NEW_LIST_CLASS.CLEAR (NEW_LIST_CLASS.LIST (THIS_STACK)) ;
 139
 140      END CLEAR ;
 141
 142      PROCEDURE ITERATE (OVER_THIS_STACK    : IN STACK) IS
 143
 144           PROCEDURE STACK_ITERATE IS NEW NEW_LIST_CLASS.ITERATE
 145                (PROCESS => PROCESS) ;
 146
 147      BEGIN  -- ITERATE
 148
 149           STACK_ITERATE (NEW_LIST_CLASS.LIST (OVER_THIS_STACK)) ;
 150
 151      END ITERATE ;
 152
 153      FUNCTION NUMBER_OF_ELEMENTS (ON_THIS_STACK    : IN STACK)
 154           RETURN NATURAL IS
 155
 156      BEGIN  -- NUMBER_OF_ELEMENTS
 157
 158           RETURN NEW_LIST_CLASS.NUMBER_OF_ELEMENTS
 159                (IN_THIS_LIST => NEW_LIST_CLASS.LIST (ON_THIS_STACK)) ;
 160
 161      END NUMBER_OF_ELEMENTS ;
 162
 163      FUNCTION "=" (LEFT  : IN STACK ;
 164                    RIGHT : IN STACK) RETURN BOOLEAN IS
 165
 166      BEGIN  -- "="
 167
 168           RETURN NEW_LIST_CLASS."=" (
 169                LEFT  => NEW_LIST_CLASS.LIST (LEFT),
 170                RIGHT => NEW_LIST_CLASS.LIST (RIGHT)) ;
 171
 172      END "=" ;
 173
 174 END CC3019B1_STACK_CLASS ;