summaryrefslogtreecommitdiff
path: root/module/rnrs
diff options
context:
space:
mode:
authorJulian Graham <julian.graham@aya.yale.edu>2010-02-08 09:45:54 -0500
committerJulian Graham <julian.graham@aya.yale.edu>2010-05-20 21:18:02 -0400
commit2a435f1f911bf7ce4ab55414d2bd76e5c95cb182 (patch)
tree01ed9721cd7385ad6831a6ea5914ab3753b91d6e /module/rnrs
parent71194485d67733cc47c642832b2c9e1de97b6c12 (diff)
downloadguile-2a435f1f911bf7ce4ab55414d2bd76e5c95cb182.tar.gz
Implementation and test cases for the R6RS (rnrs arithmetic bitwise)
library. * module/rnrs/arithmetic/6/bitwise.scm: New file. * test-suite/tests/r6rs-arithmetic-bitwise.test: New file.
Diffstat (limited to 'module/rnrs')
-rw-r--r--module/rnrs/arithmetic/6/bitwise.scm123
1 files changed, 123 insertions, 0 deletions
diff --git a/module/rnrs/arithmetic/6/bitwise.scm b/module/rnrs/arithmetic/6/bitwise.scm
new file mode 100644
index 000000000..b21946645
--- /dev/null
+++ b/module/rnrs/arithmetic/6/bitwise.scm
@@ -0,0 +1,123 @@
+;;; bitwise.scm --- The R6RS bitwise arithmetic operations library
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+
+(library (rnrs arithmetic bitwise (6))
+ (export bitwise-not
+
+ bitwise-and
+ bitwise-ior
+ bitwise-xor
+
+ bitwise-if
+ bitwise-bit-count
+ bitwise-length
+
+ bitwise-first-bit-set
+ bitwise-bit-set?
+ bitwise-copy-bit
+ bitwise-bit-field
+ bitwise-copy-bit-field
+
+ bitwise-arithmetic-shift
+ bitwise-arithmetic-shift-left
+ bitwise-arithmetic-shift-right
+ bitwise-rotate-bit-field
+ bitwise-reverse-bit-field)
+ (import (rnrs base (6))
+ (rename (only (guile) lognot
+ logand
+ logior
+ logxor
+ logcount
+ logbit?
+ ash)
+ (lognot bitwise-not)
+ (logand bitwise-and)
+ (logior bitwise-ior)
+ (logxor bitwise-xor)
+ (logcount bitwise-bit-count)
+ (ash bitwise-arithmetic-shift)))
+
+ (define (bitwise-if ei1 ei2 ei3)
+ (bitwise-ior (bitwise-and ei1 ei2) (bitwise-and (bitwise-not ei1) ei3)))
+
+ (define (bitwise-length ei)
+ (do ((result 0 (+ result 1))
+ (bits (if (negative? ei) (bitwise-not ei) ei)
+ (bitwise-arithmetic-shift bits -1)))
+ ((zero? bits)
+ result)))
+
+ (define (bitwise-first-bit-set ei)
+ (define (bitwise-first-bit-set-inner bits count)
+ (cond ((zero? bits) -1)
+ ((logbit? 0 bits) count)
+ (else (bitwise-first-bit-set-inner
+ (bitwise-arithmetic-shift bits -1) (+ count 1)))))
+ (bitwise-first-bit-set-inner ei 0))
+
+ (define (bitwise-bit-set? ei1 ei2) (logbit? ei2 ei1))
+
+ (define (bitwise-copy-bit ei1 ei2 ei3)
+ (bitwise-if (bitwise-arithmetic-shift-left 1 ei2)
+ (bitwise-arithmetic-shift-left ei3 ei2)
+ ei1))
+
+ (define (bitwise-bit-field ei1 ei2 ei3)
+ (bitwise-arithmetic-shift-right
+ (bitwise-and ei1 (bitwise-not (bitwise-arithmetic-shift-left -1 ei3)))
+ ei2))
+
+ (define (bitwise-copy-bit-field ei1 ei2 ei3 ei4)
+ (bitwise-if (bitwise-and (bitwise-arithmetic-shift-left -1 ei2)
+ (bitwise-not
+ (bitwise-arithmetic-shift-left -1 ei3)))
+ (bitwise-arithmetic-shift-left ei4 ei2)
+ ei1))
+
+ (define bitwise-arithmetic-shift-left bitwise-arithmetic-shift)
+ (define (bitwise-arithmetic-shift-right ei1 ei2)
+ (bitwise-arithmetic-shift ei1 (- ei2)))
+
+ (define (bitwise-rotate-bit-field ei1 ei2 ei3 ei4)
+ (let ((width (- ei3 ei2)))
+ (if (positive? width)
+ (let ((field (bitwise-bit-field ei1 ei2 ei3))
+ (count (modulo ei4 width)))
+ (bitwise-copy-bit-field
+ ei1 ei2 ei3
+ (bitwise-ior (bitwise-arithmetic-shift-left field count)
+ (bitwise-arithmetic-shift-right
+ field (- width count)))))
+ ei1)))
+
+ (define (bitwise-reverse-bit-field ei1 ei2 ei3)
+ (define (reverse-bit-field-recursive n1 n2 len)
+ (if (> len 0)
+ (reverse-bit-field-recursive
+ (bitwise-arithmetic-shift-right n1 1)
+ (bitwise-copy-bit (bitwise-arithmetic-shift-left n2 1) 0 n1)
+ (- len 1))
+ n2))
+ (let ((width (- ei3 ei2)))
+ (if (positive? width)
+ (let ((field (bitwise-bit-field ei1 ei2 ei3)))
+ (bitwise-copy-bit-field
+ ei1 ei2 ei3 (reverse-bit-field-recursive field 0 width)))
+ ei1))))