[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.9-44-g93da406

[Mark H Weaver]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=93da406f331a1849f05e63387442b9aaf33f9540

The branch, stable-2.0 has been updated
       via  93da406f331a1849f05e63387442b9aaf33f9540 (commit)
      from  eba5c07715f556d3c27b85afb01baa8a189d7849 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 93da406f331a1849f05e63387442b9aaf33f9540
Author: Mark H Weaver <address@hidden>
Date:   Sun Jul 21 10:00:48 2013 -0400

    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.

-----------------------------------------------------------------------

Summary of changes:
 module/rnrs/arithmetic/bitwise.scm            |   81 +++++++------------------
 test-suite/tests/r6rs-arithmetic-bitwise.test |    2 +-
 test-suite/tests/r6rs-arithmetic-fixnums.test |    2 +-
 3 files changed, 24 insertions(+), 61 deletions(-)

diff --git a/module/rnrs/arithmetic/bitwise.scm 
b/module/rnrs/arithmetic/bitwise.scm
index 0acbc8c..5f66cf1 100644
--- 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
--- 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
--- 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)))


hooks/post-receive
-- 
GNU Guile