[Guile-commits] GNU Guile branch, wip-r6rs-libraries, updated. release_1-9-7-50-g1eb6829

[Julian Graham]

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=1eb68296545965e21c7b007096bf3d3116c5d4ae

The branch, wip-r6rs-libraries has been updated
       via  1eb68296545965e21c7b007096bf3d3116c5d4ae (commit)
      from  42ba29c2ffc509ab131e390d8fdec59bfceed31a (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 1eb68296545965e21c7b007096bf3d3116c5d4ae
Author: Julian Graham <address@hidden>
Date:   Mon Feb 8 09:45:54 2010 -0500

    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.

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

Summary of changes:
 module/rnrs/arithmetic/6/bitwise.scm          |  123 +++++++++++++++++++++++++
 test-suite/tests/r6rs-arithmetic-bitwise.test |   97 +++++++++++++++++++
 2 files changed, 220 insertions(+), 0 deletions(-)
 create mode 100644 module/rnrs/arithmetic/6/bitwise.scm
 create mode 100644 test-suite/tests/r6rs-arithmetic-bitwise.test

diff --git a/module/rnrs/arithmetic/6/bitwise.scm 
b/module/rnrs/arithmetic/6/bitwise.scm
new file mode 100644
index 0000000..b219466
--- /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))))
diff --git a/test-suite/tests/r6rs-arithmetic-bitwise.test 
b/test-suite/tests/r6rs-arithmetic-bitwise.test
new file mode 100644
index 0000000..a61fef8
--- /dev/null
+++ b/test-suite/tests/r6rs-arithmetic-bitwise.test
@@ -0,0 +1,97 @@
+;;; arithmetic-bitwise.test --- Test suite for R6RS (rnrs arithmetic bitwise)
+
+;;      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
+
+
+(define-module (test-suite test-r6rs-arithmetic-bitwise)
+  :use-module ((rnrs arithmetic bitwise) :version (6))
+  :use-module (test-suite lib))
+
+(with-test-prefix "bitwise-not"
+  (pass-if "bitwise-not simple"
+    (eqv? (bitwise-not 3) -4)))
+
+(with-test-prefix "bitwise-and"
+  (pass-if "bitwise-and simple"
+    (eqv? (bitwise-and #b101 #b110) #b100)))
+
+(with-test-prefix "bitwise-ior"
+  (pass-if "bitwise-ior simple"
+    (eqv? (bitwise-ior #b010 #b100) #b110)))
+
+(with-test-prefix "bitwise-xor"
+  (pass-if "bitwise-xor simple"
+    (eqv? (bitwise-xor #b101 #b100) #b001)))
+
+(with-test-prefix "bitwise-if"
+  (pass-if "bitwise-if simple"
+    (eqv? (bitwise-if #b101 #b011 #b100) #b001)))
+
+(with-test-prefix "bitwise-bit-count"
+  (pass-if "bitwise-bit-count simple"
+    (eqv? (bitwise-bit-count #b101) 2)))
+
+(with-test-prefix "bitwise-length"
+  (pass-if "bitwise-length simple"
+    (eqv? (bitwise-length #b101) 3))
+  (pass-if "bitwise-length leading zeros"
+    (eqv? (bitwise-length #b001) 1)))
+
+(with-test-prefix "bitwise-first-bit-set"
+  (pass-if "bitwise-first-bit-set simple"
+    (and (eqv? (bitwise-first-bit-set 1) 0)
+         (eqv? (bitwise-first-bit-set -4) 2)))
+  (pass-if "bitwise-first-bit-set zero"
+    (and (eqv? (bitwise-first-bit-set 0) -1))))
+
+(with-test-prefix "bitwise-copy-bit"
+  (pass-if "bitwise-copy-bit simple"
+    (eqv? (bitwise-copy-bit #b010 2 #b111) #b110)))
+
+(with-test-prefix "bitwise-bit-field"
+  (pass-if "bitwise-bit-field simple"
+    (eqv? (bitwise-bit-field #b110010 1 4) #b001)))
+
+(with-test-prefix "bitwise-copy-bit-field"
+  (pass-if "bitwise-copy-bit-field simple"
+    (eqv? (bitwise-copy-bit-field #b11111111 2 6 #b1010) #b11101011)))
+
+(with-test-prefix "bitwise-arithmetic-shift"
+  (pass-if "bitwise-arithmetic-shift simple"
+    (and (eqv? (bitwise-arithmetic-shift -6 -1) -3)
+         (eqv? (bitwise-arithmetic-shift -5 -1) -3)
+        (eqv? (bitwise-arithmetic-shift -4 -1) -2)
+        (eqv? (bitwise-arithmetic-shift -3 -1) -2)
+        (eqv? (bitwise-arithmetic-shift -2 -1) -1)
+        (eqv? (bitwise-arithmetic-shift -1 -1) -1))))
+
+(with-test-prefix "bitwise-arithmetic-shift-left"
+  (pass-if "bitwise-arithmetic-shift-left simple"
+    (eqv? (bitwise-arithmetic-shift-left -6 -1) -3)))
+
+(with-test-prefix "bitwise-arithmetic-shift-right"
+  (pass-if "bitwise-arithmetic-shift-right simple"
+    (eqv? (bitwise-arithmetic-shift-right -6 1) -3)))
+
+(with-test-prefix "bitwise-rotate-bit-field"
+  (pass-if "bitwise-rotate-bit-field simple"
+    (eqv? (bitwise-rotate-bit-field #b11100011 2 6 2) #b11001011)))
+
+(with-test-prefix "bitwise-reverse-bit-field"
+  (pass-if "bitwise-reverse-bit-field simple"
+    (eqv? (bitwise-reverse-bit-field #b1010010 1 4) #b1011000)))
+


hooks/post-receive
-- 
GNU Guile