gcc/m2/gm2-compiler/Sets.mod

   1 (* Sets.mod provides a dynamic set module.
   2
   3 Copyright (C) 2009-2022 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 Sets ;
  23
  24 FROM SYSTEM IMPORT ADDRESS, BYTE ;
  25 FROM SymbolTable IMPORT FinalSymbol ;
  26 FROM M2Error IMPORT InternalError ;
  27 FROM Storage IMPORT ALLOCATE, REALLOCATE, DEALLOCATE ;
  28 FROM libc IMPORT memset, memcpy ;
  29 FROM M2Printf IMPORT printf0, printf1, printf2 ;
  30 FROM Assertion IMPORT Assert ;
  31
  32
  33 CONST
  34    BitsetSize  = SIZE(BITSET) ;
  35    MaxBitset   = MAX(BITSET) ;
  36    BitsPerByte = (MaxBitset+1) DIV BitsetSize ;
  37    Debugging   = FALSE ;
  38
  39 TYPE
  40    PtrToByte   = POINTER TO BYTE ;
  41    PtrToBitset = POINTER TO BITSET ;
  42    Set = POINTER TO RECORD
  43                        init,
  44                        start,
  45                        end     : CARDINAL ;
  46                        pb      : PtrToBitset ;
  47                        bytes   : CARDINAL ;
  48                        elements: CARDINAL ;
  49                     END ;
  50
  51
  52 (*
  53    growSet -
  54 *)
  55
  56 PROCEDURE growSet (i: CARDINAL; bytes: CARDINAL) ;
  57 BEGIN
  58    printf2("i = %d,  bytes = %d\n", i, bytes)
  59 END growSet ;
  60
  61
  62 (*
  63    checkRange - checks to make sure, i, is within range and
  64                 it will extend the set bitmap if required.
  65 *)
  66
  67 PROCEDURE checkRange (s: Set; i: CARDINAL) ;
  68 VAR
  69    bits,
  70    o, j: CARDINAL ;
  71    b   : PtrToBitset ;
  72    v   : PtrToByte ;
  73 BEGIN
  74    WITH s^ DO
  75       IF i<init
  76       THEN
  77          InternalError ('set element is too low and out of bounds')
  78       ELSIF i>FinalSymbol()
  79       THEN
  80          InternalError ('set element is too high and out of bounds')
  81       ELSE
  82          j := bytes * BitsPerByte ;
  83          IF i>=j
  84          THEN
  85             o := bytes ;
  86             IF Debugging
  87             THEN
  88                printf2("previous bitset size %d bytes, need %d bits\n",
  89                        o, i)
  90             END ;
  91             IF bytes=0
  92             THEN
  93                bytes := BitsetSize
  94             END ;
  95             WHILE i >= bytes*BitsPerByte DO
  96                IF Debugging
  97                THEN
  98                   growSet(i, bytes)
  99                END ;
 100                bytes := bytes * 2
 101             END ;
 102             ALLOCATE(b, bytes) ;
 103             IF Debugging
 104             THEN
 105                bits := bytes*8 ;
 106                printf2("new allocated bitset size %d bytes, holds %d bits\n", bytes, bits) ;
 107                IF i>bits
 108                THEN
 109                   InternalError ('buffer is too small')
 110                END
 111             END ;
 112             (* a := memset(b, 0, bytes) ; *)
 113             v := PtrToByte(b) ;
 114             INC(v, o) ;
 115             Assert (memset (v, 0, bytes-o) = v) ;
 116             Assert (memcpy (b, pb, o) = b) ;
 117             IF Debugging
 118             THEN
 119                printf1("deallocating old bitset size %d bytes\n", o)
 120             END ;
 121             IF o>0
 122             THEN
 123                DEALLOCATE(pb, o)
 124             END ;
 125             pb := b
 126          END
 127       END
 128    END
 129 END checkRange ;
 130
 131
 132 (*
 133    findPos - returns a pointer to the BITSET which will contain, i.
 134 *)
 135
 136 PROCEDURE findPos (pb: PtrToBitset; i: CARDINAL) : PtrToBitset ;
 137 VAR
 138    v: PtrToByte ;
 139 BEGIN
 140    IF (((i DIV (MaxBitset+1)) * (MaxBitset+1)) DIV BitsPerByte) MOD BitsetSize#0
 141    THEN
 142       InternalError ('must be a multiple of bitset size')
 143    END ;
 144    v := PtrToByte(pb) ;
 145    INC(v, ((i DIV (MaxBitset+1)) * (MaxBitset+1)) DIV BitsPerByte) ;
 146    pb := PtrToBitset(v) ;
 147    RETURN( pb )
 148 END findPos ;
 149
 150
 151 (*
 152    InitSet - initializes and returns a set.  The set will
 153              never contain an element less than, low.
 154 *)
 155
 156 PROCEDURE InitSet (low: CARDINAL) : Set ;
 157 VAR
 158    s: Set ;
 159 BEGIN
 160    NEW(s) ;
 161    WITH s^ DO
 162       init     := low ;
 163       start    := 0 ;
 164       end      := 0 ;
 165       pb       := NIL ;
 166       bytes    := 0 ;
 167       elements := 0
 168    END ;
 169    RETURN( s )
 170 END InitSet ;
 171
 172
 173 (*
 174    KillSet - deallocates Set, s.
 175 *)
 176
 177 PROCEDURE KillSet (s: Set) : Set ;
 178 BEGIN
 179    WITH s^ DO
 180       IF bytes>0
 181       THEN
 182          DEALLOCATE(pb, bytes)
 183       END
 184    END ;
 185    DISPOSE(s) ;
 186    RETURN( NIL )
 187 END KillSet ;
 188
 189
 190 (*
 191    DuplicateSet - returns a new duplicated set.
 192 *)
 193
 194 PROCEDURE DuplicateSet (s: Set) : Set ;
 195 VAR
 196    t: Set ;
 197 BEGIN
 198    NEW(t) ;
 199    t^ := s^ ;
 200    WITH t^ DO
 201       ALLOCATE(pb, bytes) ;
 202       Assert (memcpy (pb, s^.pb, bytes) = pb)
 203    END ;
 204    RETURN( t )
 205 END DuplicateSet ;
 206
 207
 208 (*
 209    ForeachElementInSetDo - for each element e in, s, call, p(e).
 210 *)
 211
 212 PROCEDURE ForeachElementInSetDo (s: Set; p: PerformOperation) ;
 213 VAR
 214    i, j, c: CARDINAL ;
 215    b      : PtrToBitset ;
 216    v      : PtrToByte ;
 217 BEGIN
 218    WITH s^ DO
 219       i := start ;
 220       c := elements ;
 221       b := findPos(pb, i) ;
 222       j := i MOD (MaxBitset+1) ;
 223       WHILE (i<=end) AND (c>0) DO
 224          IF j IN b^
 225          THEN
 226             DEC(c) ;
 227             p(i)
 228          END ;
 229          IF j=MaxBitset
 230          THEN
 231             v := PtrToByte(b) ;
 232             INC(v, BitsetSize) ;   (* avoid implications of C address arithmetic in mc PtrToByte *)
 233             b := PtrToBitset(v) ;
 234             j := 0
 235          ELSE
 236             INC(j)
 237          END ;
 238          INC(i)
 239       END
 240    END
 241 END ForeachElementInSetDo ;
 242
 243
 244 (*
 245    IsElementInSet - returns TRUE if element, i, is in set, s.
 246 *)
 247
 248 PROCEDURE IsElementInSet (s: Set; i: CARDINAL) : BOOLEAN ;
 249 VAR
 250    b: PtrToBitset ;
 251 BEGIN
 252    checkRange(s, i) ;
 253    WITH s^ DO
 254       b := findPos(pb, i) ;
 255       RETURN( (i MOD (MaxBitset+1)) IN b^ )
 256    END
 257 END IsElementInSet ;
 258
 259
 260 (*
 261    NoOfElementsInSet - returns the number of elements in a set, s.
 262 *)
 263
 264 PROCEDURE NoOfElementsInSet (s: Set) : CARDINAL ;
 265 BEGIN
 266    RETURN( s^.elements )
 267 END NoOfElementsInSet ;
 268
 269
 270 (*
 271    ExcludeElementFromSet - excludes element, i, from set, s.
 272 *)
 273
 274 PROCEDURE ExcludeElementFromSet (s: Set; i: CARDINAL) ;
 275 VAR
 276    b: PtrToBitset ;
 277 BEGIN
 278    checkRange(s, i) ;
 279    WITH s^ DO
 280       b := findPos(pb, i) ;
 281       IF (i MOD (MaxBitset+1)) IN b^
 282       THEN
 283          DEC(elements) ;
 284          EXCL(b^, i MOD (MaxBitset+1))
 285       END
 286    END
 287 END ExcludeElementFromSet ;
 288
 289
 290 (*
 291    IncludeElementIntoSet - includes element, i, into set, s.
 292 *)
 293
 294 PROCEDURE IncludeElementIntoSet (s: Set; i: CARDINAL) ;
 295 VAR
 296    b: PtrToBitset ;
 297 BEGIN
 298    checkRange(s, i) ;
 299    WITH s^ DO
 300       b := findPos(pb, i) ;
 301       IF NOT ((i MOD (MaxBitset+1)) IN b^)
 302       THEN
 303          INC(elements) ;
 304          INCL(b^, i MOD (MaxBitset+1)) ;
 305          IF (start=0) OR (start>i)
 306          THEN
 307             start := i
 308          END ;
 309          IF (end=0) OR (end<i)
 310          THEN
 311             end := i
 312          END
 313       END
 314    END
 315 END IncludeElementIntoSet ;
 316
 317
 318 END Sets.