gcc/m2/gm2-compiler/M2StackWord.mod

   1 (* M2StackWord.mod provides a generic stack for WORD sized objects.
   2
   3 Copyright (C) 2001-2023 Free Software Foundation, Inc.
   4 Contributed by Gaius Mulley <gaius.mulley@southwales.ac.uk>.
   5
   6 This file is part of GNU Modula-2.
   7
   8 GNU Modula-2 is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 3, or (at your option)
  11 any later version.
  12
  13 GNU Modula-2 is distributed in the hope that it will be useful, but
  14 WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GNU Modula-2; see the file COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  *)
  21
  22 IMPLEMENTATION MODULE M2StackWord ;
  23
  24 FROM Storage IMPORT ALLOCATE, DEALLOCATE ;
  25 FROM M2Error IMPORT InternalError ;
  26 FROM M2Debug IMPORT Assert ;
  27
  28 CONST
  29    MaxBucket = 10 ;
  30
  31 TYPE
  32    StackBucketWord = POINTER TO BucketWord ;
  33    BucketWord      = RECORD
  34                          bucket: ARRAY [0..MaxBucket-1] OF WORD ;
  35                          items : CARDINAL ;
  36                          last  : StackBucketWord ;
  37                      END ;
  38
  39    StackOfWord     = POINTER TO StackDescriptor ;
  40    StackDescriptor = RECORD
  41                         tail: StackBucketWord ;
  42                      END ;
  43
  44
  45 (*
  46    InitStackWord - creates and returns a new stack.
  47 *)
  48
  49 PROCEDURE InitStackWord () : StackOfWord ;
  50 VAR
  51    s: StackOfWord ;
  52 BEGIN
  53    NEW(s) ;
  54    WITH s^ DO
  55       tail := NIL
  56    END ;
  57    RETURN( s )
  58 END InitStackWord ;
  59
  60
  61 (*
  62    KillBucket - destroys a StackBucketWord and returns, NIL.
  63 *)
  64
  65 PROCEDURE KillBucket (b: StackBucketWord) : StackBucketWord ;
  66 BEGIN
  67    IF b#NIL
  68    THEN
  69       b := KillBucket(b^.last) ;
  70       DISPOSE(b)
  71    END ;
  72    RETURN( NIL )
  73 END KillBucket ;
  74
  75
  76 (*
  77    KillStackWord - destroys a stack, returning NIL.
  78 *)
  79
  80 PROCEDURE KillStackWord (s: StackOfWord) : StackOfWord ;
  81 BEGIN
  82    IF s#NIL
  83    THEN
  84       s^.tail := KillBucket(s^.tail) ;
  85       DISPOSE(s)
  86    END ;
  87    RETURN( NIL )
  88 END KillStackWord ;
  89
  90
  91 (*
  92    InitBucket - returns an empty StackBucketWord.
  93 *)
  94
  95 PROCEDURE InitBucket (l: StackBucketWord) : StackBucketWord ;
  96 VAR
  97    b: StackBucketWord ;
  98 BEGIN
  99    NEW(b) ;
 100    WITH b^ DO
 101       items := 0 ;
 102       last  := l
 103    END ;
 104    RETURN( b )
 105 END InitBucket ;
 106
 107
 108 (*
 109    PushWord - pushes a word, w, onto, s.
 110 *)
 111
 112 PROCEDURE PushWord (s: StackOfWord; w: WORD) ;
 113 BEGIN
 114    IF s=NIL
 115    THEN
 116       InternalError ('stack has not been initialized')
 117    ELSE
 118       WITH s^ DO
 119          IF (tail=NIL) OR (tail^.items=MaxBucket)
 120          THEN
 121             tail := InitBucket(tail)
 122          END ;
 123          WITH tail^ DO
 124             IF items<MaxBucket
 125             THEN
 126                bucket[items] := w ;
 127                INC(items)
 128             END
 129          END
 130       END
 131    END
 132 END PushWord ;
 133
 134
 135 (*
 136    PopWord - pops an element from stack, s.
 137 *)
 138
 139 PROCEDURE PopWord (s: StackOfWord) : WORD ;
 140 VAR
 141    b: StackBucketWord ;
 142 BEGIN
 143    IF s=NIL
 144    THEN
 145       InternalError ('stack has not been initialized')
 146    ELSE
 147       IF s^.tail=NIL
 148       THEN
 149          InternalError ('stack underflow')
 150       ELSE
 151          IF s^.tail^.items=0
 152          THEN
 153             b := s^.tail ;
 154             IF b=NIL
 155             THEN
 156                InternalError ('stack underflow')
 157             ELSE
 158                s^.tail := b^.last
 159             END ;
 160             DISPOSE(b)
 161          END ;
 162          WITH s^.tail^ DO
 163             DEC(items) ;
 164             RETURN( bucket[items] )
 165          END
 166       END
 167    END
 168 END PopWord ;
 169
 170
 171 (*
 172    IsEmptyWord - returns TRUE if stack, s, is empty.
 173 *)
 174
 175 PROCEDURE IsEmptyWord (s: StackOfWord) : BOOLEAN ;
 176 BEGIN
 177    RETURN( (s=NIL) OR (s^.tail=NIL) )
 178 END IsEmptyWord ;
 179
 180
 181 (*
 182    PeepWord - returns the element at, n, items below in the stack.
 183               Top of stack can be seen via Peep(s, 1)
 184 *)
 185
 186 PROCEDURE PeepWord (s: StackOfWord; n: CARDINAL) : WORD ;
 187 VAR
 188    b: StackBucketWord ;
 189 BEGIN
 190    IF s^.tail=NIL
 191    THEN
 192       InternalError ('stack underflow')
 193    ELSE
 194       IF s^.tail^.items=0
 195       THEN
 196          b := s^.tail ;
 197          IF b=NIL
 198          THEN
 199             InternalError ('stack underflow')
 200          ELSE
 201             s^.tail := b^.last
 202          END ;
 203          DISPOSE(b)
 204       END ;
 205       b := s^.tail ;
 206       WHILE n>=1 DO
 207          IF b=NIL
 208          THEN
 209             InternalError ('stack underflow')
 210          ELSIF b^.items>=n
 211          THEN
 212             RETURN( b^.bucket[b^.items-n] )
 213          ELSE
 214             Assert(b^.items<n) ;
 215             DEC(n, b^.items) ;
 216             b := b^.last
 217          END
 218       END ;
 219       InternalError ('stack underflow')
 220    END
 221 END PeepWord ;
 222
 223
 224 (*
 225    ReduceWord - reduce the stack by n elements.
 226 *)
 227
 228 PROCEDURE ReduceWord (s: StackOfWord; n: CARDINAL) ;
 229 VAR
 230    b: StackBucketWord ;
 231 BEGIN
 232    IF s^.tail=NIL
 233    THEN
 234       InternalError ('stack underflow')
 235    ELSE
 236       IF s^.tail^.items=0
 237       THEN
 238          b := s^.tail ;
 239          IF b=NIL
 240          THEN
 241             InternalError ('stack underflow')
 242          ELSE
 243             s^.tail := b^.last
 244          END ;
 245          DISPOSE(b)
 246       END ;
 247       LOOP
 248          IF s^.tail=NIL
 249          THEN
 250             InternalError ('stack underflow')
 251          ELSIF s^.tail^.items>=n
 252          THEN
 253             DEC( s^.tail^.items, n) ;
 254             RETURN  (* all done exit *)
 255          ELSE
 256             b := s^.tail ;
 257             DEC(n, b^.items) ;
 258             s^.tail := s^.tail^.last ;
 259             DISPOSE(b)
 260          END
 261       END
 262    END
 263 END ReduceWord ;
 264
 265
 266 (*
 267    RemoveTop - throw away the top element of the stack.
 268 *)
 269
 270 PROCEDURE RemoveTop (s: StackOfWord) ;
 271 BEGIN
 272    ReduceWord (s, 1)
 273 END RemoveTop ;
 274
 275
 276 (*
 277    NoOfItemsInStackWord - returns the number of items held in the stack, s.
 278 *)
 279
 280 PROCEDURE NoOfItemsInStackWord (s: StackOfWord) : CARDINAL ;
 281 VAR
 282    b: StackBucketWord ;
 283    n: CARDINAL ;
 284 BEGIN
 285    IF IsEmptyWord(s)
 286    THEN
 287       RETURN( 0 )
 288    ELSE
 289       n := 0 ;
 290       b := s^.tail ;
 291       WHILE b#NIL DO
 292          INC(n, b^.items) ;
 293          b := b^.last
 294       END ;
 295       RETURN( n )
 296    END
 297 END NoOfItemsInStackWord ;
 298
 299
 300 END M2StackWord.