Optimize R6RS bitwise operators.

* module/rnrs/arithmetic/bitwise.scm (bitwise-if, bitwise-length,
  bitwise-first-bit-set, bitwise-bit-field, bitwise-reverse-bit-field):
  Replace these with aliases to the identical SRFI-60 operators
  'bitwise-if', 'integer-length', 'first-set-bit', 'bit-field', and
  'reverse-bit-field'.

  (bitwise-copy-bit, bitwise-copy-bit-field, bitwise-rotate-bit-field):
  Reimplement these based upon the similar SRFI-60 operators 'copy-bit',
  'copy-bit-field', and 'rotate-bit-field'.

* test-suite/tests/r6rs-arithmetic-bitwise.test (bitwise-copy-bit): Fix
  test to conform to the specification, which requires the third
  argument to be either 0 or 1.

* test-suite/tests/r6rs-arithmetic-fixnums.test (fxcopy-bit): Fix test
  to conform to the specification, which requires the third argument to
  be either 0 or 1.

diff --git a/module/rnrs/arithmetic/bitwise.scm b/module/rnrs/arithmetic/bitwise.scm
index 0acbc8c..5f66cf1 100644 (file)
--- a/module/rnrs/arithmetic/bitwise.scm
+++ b/module/rnrs/arithmetic/bitwise.scm
@@ -41,6 +41,18 @@
          bitwise-reverse-bit-field)
   (import (rnrs base (6))
          (rnrs control (6))
+          (rename (only (srfi srfi-60) bitwise-if
+                                       integer-length
+                                       first-set-bit
+                                       copy-bit
+                                       bit-field
+                                       copy-bit-field
+                                       rotate-bit-field
+                                       reverse-bit-field)
+                  (integer-length bitwise-length)
+                  (first-set-bit bitwise-first-bit-set)
+                  (bit-field bitwise-bit-field)
+                  (reverse-bit-field bitwise-reverse-bit-field))
          (rename (only (guile) lognot 
                                logand 
                                logior
@@ -60,70 +72,21 @@
         (bitwise-not (logcount ei))
         (logcount ei)))
 
-  (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))
+    ;; The specification states that ei3 should be either 0 or 1.
+    ;; However, other values have been tolerated by both Guile 2.0.x and
+    ;; the sample implementation given the R6RS library document, so for
+    ;; backward compatibility we continue to permit it.
+    (copy-bit ei2 ei1 (logbit? 0 ei3)))
 
   (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))
+    (copy-bit-field ei1 ei4 ei2 ei3))
 
-  (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)))
+    (rotate-bit-field ei1 ei4 ei2 ei3))
 
-  (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))))
+  (define bitwise-arithmetic-shift-left bitwise-arithmetic-shift)
+  (define (bitwise-arithmetic-shift-right ei1 ei2)
+    (bitwise-arithmetic-shift ei1 (- ei2))))

diff --git a/test-suite/tests/r6rs-arithmetic-bitwise.test b/test-suite/tests/r6rs-arithmetic-bitwise.test
index 3b35846..3e23d81 100644 (file)
--- a/test-suite/tests/r6rs-arithmetic-bitwise.test
+++ b/test-suite/tests/r6rs-arithmetic-bitwise.test
@@ -62,7 +62,7 @@
 
 (with-test-prefix "bitwise-copy-bit"
   (pass-if "bitwise-copy-bit simple"
-    (eqv? (bitwise-copy-bit #b010 2 #b111) #b110)))
+    (eqv? (bitwise-copy-bit #b010 2 1) #b110)))
 
 (with-test-prefix "bitwise-bit-field"
   (pass-if "bitwise-bit-field simple"

diff --git a/test-suite/tests/r6rs-arithmetic-fixnums.test b/test-suite/tests/r6rs-arithmetic-fixnums.test
index 60c3b87..2d9b177 100644 (file)
--- a/test-suite/tests/r6rs-arithmetic-fixnums.test
+++ b/test-suite/tests/r6rs-arithmetic-fixnums.test
@@ -184,7 +184,7 @@
 
   (pass-if "fxbit-set? is #f on index of unset bit" (not (fxbit-set? 5 1))))
 
-(with-test-prefix "fxcopy-bit" (pass-if "simple" (fx=? (fxcopy-bit 2 2 7) 6)))
+(with-test-prefix "fxcopy-bit" (pass-if "simple" (fx=? (fxcopy-bit 2 2 1) 6)))
 
 (with-test-prefix "fxbit-field" 
   (pass-if "simple" (fx=? (fxbit-field 50 1 4) 1)))