module/rnrs/arithmetic/bitwise.scm

   1 ;;; bitwise.scm --- The R6RS bitwise arithmetic operations library
   2
   3 ;;      Copyright (C) 2010 Free Software Foundation, Inc.
   4 ;;
   5 ;; This library is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public
   7 ;; License as published by the Free Software Foundation; either
   8 ;; version 3 of the License, or (at your option) any later version.
   9 ;;
  10 ;; This library is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this library; if not, write to the Free Software
  17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18 \f
  19
  20 (library (rnrs arithmetic bitwise (6))
  21   (export bitwise-not
  22
  23           bitwise-and
  24           bitwise-ior
  25           bitwise-xor
  26
  27           bitwise-if
  28           bitwise-bit-count
  29           bitwise-length
  30
  31           bitwise-first-bit-set
  32           bitwise-bit-set?
  33           bitwise-copy-bit
  34           bitwise-bit-field
  35           bitwise-copy-bit-field
  36
  37           bitwise-arithmetic-shift
  38           bitwise-arithmetic-shift-left
  39           bitwise-arithmetic-shift-right
  40           bitwise-rotate-bit-field
  41           bitwise-reverse-bit-field)
  42   (import (rnrs base (6))
  43           (rnrs control (6))
  44           (rename (only (guile) lognot
  45                                 logand
  46                                 logior
  47                                 logxor
  48                                 logcount
  49                                 logbit?
  50                                 modulo
  51                                 ash)
  52                   (lognot bitwise-not)
  53                   (logand bitwise-and)
  54                   (logior bitwise-ior)
  55                   (logxor bitwise-xor)
  56                   (logcount bitwise-bit-count)
  57                   (ash bitwise-arithmetic-shift)))
  58
  59   (define (bitwise-if ei1 ei2 ei3)
  60     (bitwise-ior (bitwise-and ei1 ei2) (bitwise-and (bitwise-not ei1) ei3)))
  61
  62   (define (bitwise-length ei)
  63     (do ((result 0 (+ result 1))
  64          (bits (if (negative? ei) (bitwise-not ei) ei)
  65                (bitwise-arithmetic-shift bits -1)))
  66         ((zero? bits)
  67          result)))
  68
  69   (define (bitwise-first-bit-set ei)
  70     (define (bitwise-first-bit-set-inner bits count)
  71       (cond ((zero? bits) -1)
  72             ((logbit? 0 bits) count)
  73             (else (bitwise-first-bit-set-inner
  74                    (bitwise-arithmetic-shift bits -1) (+ count 1)))))
  75     (bitwise-first-bit-set-inner ei 0))
  76
  77   (define (bitwise-bit-set? ei1 ei2) (logbit? ei2 ei1))
  78
  79   (define (bitwise-copy-bit ei1 ei2 ei3)
  80     (bitwise-if (bitwise-arithmetic-shift-left 1 ei2)
  81                 (bitwise-arithmetic-shift-left ei3 ei2)
  82                 ei1))
  83
  84   (define (bitwise-bit-field ei1 ei2 ei3)
  85     (bitwise-arithmetic-shift-right
  86      (bitwise-and ei1 (bitwise-not (bitwise-arithmetic-shift-left -1 ei3)))
  87      ei2))
  88
  89   (define (bitwise-copy-bit-field ei1 ei2 ei3 ei4)
  90     (bitwise-if (bitwise-and (bitwise-arithmetic-shift-left -1 ei2)
  91                              (bitwise-not
  92                               (bitwise-arithmetic-shift-left -1 ei3)))
  93                 (bitwise-arithmetic-shift-left ei4 ei2)
  94                 ei1))
  95
  96   (define bitwise-arithmetic-shift-left bitwise-arithmetic-shift)
  97   (define (bitwise-arithmetic-shift-right ei1 ei2)
  98     (bitwise-arithmetic-shift ei1 (- ei2)))
  99
 100   (define (bitwise-rotate-bit-field ei1 ei2 ei3 ei4)
 101     (let ((width (- ei3 ei2)))
 102       (if (positive? width)
 103           (let ((field (bitwise-bit-field ei1 ei2 ei3))
 104                 (count (modulo ei4 width)))
 105             (bitwise-copy-bit-field
 106              ei1 ei2 ei3
 107              (bitwise-ior (bitwise-arithmetic-shift-left field count)
 108                           (bitwise-arithmetic-shift-right
 109                            field (- width count)))))
 110           ei1)))
 111
 112   (define (bitwise-reverse-bit-field ei1 ei2 ei3)
 113     (define (reverse-bit-field-recursive n1 n2 len)
 114       (if (> len 0)
 115           (reverse-bit-field-recursive
 116            (bitwise-arithmetic-shift-right n1 1)
 117            (bitwise-copy-bit (bitwise-arithmetic-shift-left n2 1) 0 n1)
 118            (- len 1))
 119           n2))
 120     (let ((width (- ei3 ei2)))
 121       (if (positive? width)
 122           (let ((field (bitwise-bit-field ei1 ei2 ei3)))
 123             (bitwise-copy-bit-field
 124              ei1 ei2 ei3 (reverse-bit-field-recursive field 0 width)))
 125           ei1))))