gcc/m2/gm2-libs-iso/SYSTEM.mod

   1 (* SYSTEM.mod implement the ISO SYSTEM specification.
   2
   3 Copyright (C) 2004-2024 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 Under Section 7 of GPL version 3, you are granted additional
  19 permissions described in the GCC Runtime Library Exception, version
  20 3.1, as published by the Free Software Foundation.
  21
  22 You should have received a copy of the GNU General Public License and
  23 a copy of the GCC Runtime Library Exception along with this program;
  24 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  25 <http://www.gnu.org/licenses/>.  *)
  26
  27 IMPLEMENTATION MODULE SYSTEM ;
  28
  29 FROM libc IMPORT memcpy, memset ;
  30
  31 CONST
  32    BitsPerBitset = MAX(BITSET)+1 ;
  33
  34
  35 (*
  36    Max - returns the maximum of a and b.
  37 *)
  38
  39 PROCEDURE Max (a, b: CARDINAL) : CARDINAL ;
  40 BEGIN
  41    IF a>b
  42    THEN
  43       RETURN a
  44    ELSE
  45       RETURN b
  46    END
  47 END Max ;
  48
  49
  50 (*
  51    Min - returns the minimum of a and b.
  52 *)
  53
  54 PROCEDURE Min (a, b: CARDINAL) : CARDINAL ;
  55 BEGIN
  56    IF a<b
  57    THEN
  58       RETURN a
  59    ELSE
  60       RETURN b
  61    END
  62 END Min ;
  63
  64
  65 (*
  66    ShiftVal - is a runtime procedure whose job is to implement
  67               the SHIFT procedure of ISO SYSTEM. GNU Modula-2 will
  68               inline a SHIFT of a single WORD sized set and will only
  69               call this routine for larger sets.
  70 *)
  71
  72 PROCEDURE ShiftVal (VAR s, d: ARRAY OF BITSET;
  73                     SetSizeInBits: CARDINAL;
  74                     ShiftCount: INTEGER) ;
  75 VAR
  76    a: ADDRESS ;
  77 BEGIN
  78    IF ShiftCount>0
  79    THEN
  80       ShiftCount := ShiftCount MOD VAL(INTEGER, SetSizeInBits) ;
  81       ShiftLeft(s, d, SetSizeInBits, ShiftCount)
  82    ELSIF ShiftCount<0
  83    THEN
  84       ShiftCount := (-ShiftCount) MOD VAL(INTEGER, SetSizeInBits) ;
  85       ShiftRight(s, d, SetSizeInBits, ShiftCount)
  86    ELSE
  87       a := memcpy(ADR(d), ADR(s), (HIGH(d)+1)*SIZE(BITSET))
  88    END
  89 END ShiftVal ;
  90
  91
  92 (*
  93    ShiftLeft - performs the shift left for a multi word set.
  94                This procedure might be called by the back end of
  95                GNU Modula-2 depending whether amount is known at compile
  96                time.
  97 *)
  98
  99 PROCEDURE ShiftLeft (VAR s, d: ARRAY OF BITSET;
 100                      SetSizeInBits: CARDINAL;
 101                      ShiftCount: CARDINAL) ;
 102 VAR
 103    lo, hi : BITSET ;
 104    i, j, h: CARDINAL ;
 105    a      : ADDRESS ;
 106 BEGIN
 107    h := HIGH(s)+1 ;
 108    IF ShiftCount MOD BitsPerBitset=0
 109    THEN
 110       i := ShiftCount DIV BitsPerBitset ;
 111       a := ADR(d[i]) ;
 112       a := memcpy(a, ADR(s), (h-i)*SIZE(BITSET)) ;
 113       a := memset(ADR(d), 0, i*SIZE(BITSET))
 114    ELSE
 115       i := h ;
 116       WHILE i>0 DO
 117          DEC(i) ;
 118          lo := SHIFT(s[i], ShiftCount MOD BitsPerBitset) ;
 119          hi := SHIFT(s[i], -(BitsPerBitset - (ShiftCount MOD BitsPerBitset))) ;
 120          d[i] := BITSET{} ;
 121          j := i + ShiftCount DIV BitsPerBitset ;
 122          IF j<h
 123          THEN
 124             d[j] := d[j] + lo ;
 125             INC(j) ;
 126             IF j<h
 127             THEN
 128                d[j] := d[j] + hi
 129             END
 130          END
 131       END
 132    END
 133 END ShiftLeft ;
 134
 135
 136 (*
 137    ShiftRight - performs the shift left for a multi word set.
 138                 This procedure might be called by the back end of
 139                 GNU Modula-2 depending whether amount is known at compile
 140                 time.
 141 *)
 142
 143 PROCEDURE ShiftRight (VAR s, d: ARRAY OF BITSET;
 144                       SetSizeInBits: CARDINAL;
 145                       ShiftCount: CARDINAL) ;
 146 VAR
 147    lo, hi : BITSET ;
 148    j, i, h: INTEGER ;
 149    a      : ADDRESS ;
 150 BEGIN
 151    h := HIGH(s)+1 ;
 152    IF ShiftCount MOD BitsPerBitset=0
 153    THEN
 154       i := ShiftCount DIV BitsPerBitset ;
 155       a := ADR(s[i]) ;
 156       j := h-i ;
 157       a := memcpy(ADR(d), a, j * VAL (INTEGER, SIZE (BITSET))) ;
 158       a := ADR(d[j]) ;
 159       a := memset(a, 0, i * VAL (INTEGER, SIZE (BITSET)))
 160    ELSE
 161       i := 0 ;
 162       WHILE i<h DO
 163          lo := SHIFT(s[i], BitsPerBitset - (ShiftCount MOD BitsPerBitset)) ;
 164          hi := SHIFT(s[i], -(ShiftCount MOD BitsPerBitset)) ;
 165          d[i] := BITSET{} ;
 166          j := i - VAL(INTEGER, ShiftCount DIV BitsPerBitset) ;
 167          IF j>=0
 168          THEN
 169             d[j] := d[j] + hi ;
 170             DEC(j) ;
 171             IF j>=0
 172             THEN
 173                d[j] := d[j] + lo
 174             END
 175          END ;
 176          INC(i)
 177       END
 178    END
 179 END ShiftRight ;
 180
 181
 182 (*
 183    RotateVal - is a runtime procedure whose job is to implement
 184                the ROTATE procedure of ISO SYSTEM. GNU Modula-2 will
 185                inline a ROTATE of a single WORD (or less)
 186                sized set and will only call this routine for larger sets.
 187 *)
 188
 189 PROCEDURE RotateVal (VAR s, d: ARRAY OF BITSET;
 190                      SetSizeInBits: CARDINAL;
 191                      RotateCount: INTEGER) ;
 192 VAR
 193    a: ADDRESS ;
 194 BEGIN
 195    IF RotateCount>0
 196    THEN
 197       RotateCount := RotateCount MOD VAL(INTEGER, SetSizeInBits)
 198    ELSIF RotateCount<0
 199    THEN
 200       RotateCount := -VAL(INTEGER, VAL(CARDINAL, -RotateCount) MOD SetSizeInBits)
 201    END ;
 202    IF RotateCount>0
 203    THEN
 204       RotateLeft(s, d, SetSizeInBits, RotateCount)
 205    ELSIF RotateCount<0
 206    THEN
 207       RotateRight(s, d, SetSizeInBits, -RotateCount)
 208    ELSE
 209       (* no rotate required, but we must copy source to dest.  *)
 210       a := memcpy(ADR(d), ADR(s), (HIGH(d)+1)*SIZE(BITSET))
 211    END
 212 END RotateVal ;
 213
 214
 215 (*
 216    RotateLeft - performs the rotate left for a multi word set.
 217                 This procedure might be called by the back end of
 218                 GNU Modula-2 depending whether amount is known at compile
 219                 time.
 220 *)
 221
 222 PROCEDURE RotateLeft (VAR s, d: ARRAY OF BITSET;
 223                       SetSizeInBits: CARDINAL;
 224                       RotateCount: CARDINAL) ;
 225 VAR
 226    lo, hi : BITSET ;
 227    b, i, j, h: CARDINAL ;
 228 BEGIN
 229    h := HIGH(s) ;
 230    (* firstly we set d := {} *)
 231    i := 0 ;
 232    WHILE i<=h DO
 233       d[i] := BITSET{} ;
 234       INC(i)
 235    END ;
 236    i := h+1 ;
 237    RotateCount := RotateCount MOD SetSizeInBits ;
 238    b := SetSizeInBits MOD BitsPerBitset ;
 239    IF b=0
 240    THEN
 241       b := BitsPerBitset
 242    END ;
 243    WHILE i>0 DO
 244       DEC(i) ;
 245       lo := SHIFT(s[i], RotateCount MOD BitsPerBitset) ;
 246       hi := SHIFT(s[i], -(b - (RotateCount MOD BitsPerBitset))) ;
 247       j := ((i*BitsPerBitset + RotateCount) MOD
 248             SetSizeInBits) DIV BitsPerBitset ;
 249       d[j] := d[j] + lo ;
 250       j := (((i+1)*BitsPerBitset + RotateCount) MOD
 251             SetSizeInBits) DIV BitsPerBitset ;
 252       d[j] := d[j] + hi ;
 253       b := BitsPerBitset
 254    END
 255 END RotateLeft ;
 256
 257
 258 (*
 259    RotateRight - performs the rotate right for a multi word set.
 260                  This procedure might be called by the back end of
 261                  GNU Modula-2 depending whether amount is known at compile
 262                  time.
 263 *)
 264
 265 PROCEDURE RotateRight (VAR s, d: ARRAY OF BITSET;
 266                        SetSizeInBits: CARDINAL;
 267                        RotateCount: CARDINAL) ;
 268 BEGIN
 269    RotateLeft(s, d, SetSizeInBits, SetSizeInBits-RotateCount)
 270 END RotateRight ;
 271
 272
 273 END SYSTEM.