[Guile-commits] GNU Guile branch, wip-r6rs-libraries, updated. release_1-9-8-98-g4b4da0f

[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=4b4da0fb47c7dd056d241e67cacb1112cd831b86

The branch, wip-r6rs-libraries has been updated
       via  4b4da0fb47c7dd056d241e67cacb1112cd831b86 (commit)
      from  e915f7a5bd91d93b5b2a296cdf4355d31fd126b2 (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 4b4da0fb47c7dd056d241e67cacb1112cd831b86
Author: Julian Graham <address@hidden>
Date:   Sun Apr 4 14:53:06 2010 -0400

    Test suite and fixes for R6RS (rnrs arithmetic fixnums).
    
    * module/rnrs/arithmetic/6/fixnums.scm: Fix missing imports;
      (fixnum-width, greatest-fixnum, least-fixnum): Redefine these as
      zero-argument procedures; Fix argument mismatches in several functions.
    * test-suite/Makefile.am: Add tests/r6rs-arithmetic-fixnums.test to
      SCM_TESTS.
    * test-suite/tests/r6rs-arithmetic-fixnums.test: New file.

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

Summary of changes:
 module/rnrs/arithmetic/6/fixnums.scm          |  101 +++++++-----
 test-suite/Makefile.am                        |    1 +
 test-suite/tests/r6rs-arithmetic-fixnums.test |  211 +++++++++++++++++++++++++
 3 files changed, 269 insertions(+), 44 deletions(-)
 create mode 100644 test-suite/tests/r6rs-arithmetic-fixnums.test

diff --git a/module/rnrs/arithmetic/6/fixnums.scm 
b/module/rnrs/arithmetic/6/fixnums.scm
index 2c8b716..cda1933 100644
--- a/module/rnrs/arithmetic/6/fixnums.scm
+++ b/module/rnrs/arithmetic/6/fixnums.scm
@@ -54,6 +54,7 @@
          fx-/carry
          fx*/carry
 
+         fxnot
          fxand
          fxior
          fxxor
@@ -73,34 +74,39 @@
 
          fxrotate-bit-field
          fxreverse-bit-field)
-  (import (rename (only (guile) logand
-                               logbit?
-                               logcount
-                               logior
-                               lognot
-                               most-positive-fixnum 
-                               most-negative-fixnum)
-                 (most-positive-fixnum greatest-fixnum)
-                 (most-negative-fixnum least-fixnum))
+  (import (only (guile) ash
+                       cons*
+                       inexact->exact
+                       logand
+                       logbit?
+                       logcount
+                       logior
+                       lognot
+                       logxor
+                       most-positive-fixnum 
+                       most-negative-fixnum)
          (ice-9 optargs)
          (rnrs base (6))
          (rnrs arithmetic bitwise (6))
          (rnrs conditions (6))
-         (rnrs exceptions (6)))
+         (rnrs exceptions (6))
+         (rnrs lists (6)))
 
-  (define fixnum-width (round (/ (log (+ greatest-fixnum 1)) (log 2))))
+  (define fixnum-width 
+    (let ((w (round (/ (log (+ most-positive-fixnum 1)) (log 2)))))
+      (lambda () w)))
+
+  (define (greatest-fixnum) most-positive-fixnum)
+  (define (least-fixnum) most-negative-fixnum)
   
   (define (fixnum? obj) 
-    (and (exact? obj) 
-        (integer? obj) 
-        (>= obj least-fixnum) 
-        (<= obj greatest-fixnum)))
+    (and (integer? obj) 
+        (exact? obj) 
+        (>= obj most-negative-fixnum) 
+        (<= obj most-positive-fixnum)))
 
   (define (assert-fixnum . args)
-    (or (every fixnum? args) (raise (make-assertion-violation))))
-  (define (assert-fixnum-result . args)
-    (or (every fixnum? args)
-       (raise (make-implementation-restriction-violation))))
+    (or (for-all fixnum? args) (raise (make-assertion-violation))))
 
   (define (fx=? fx1 fx2 . rst)
     (let ((args (cons* fx1 fx2 rst)))
@@ -135,67 +141,74 @@
 
   (define (fxmax fx1 fx2 . rst)
     (let ((args (cons* fx1 fx2 rst)))
-      (assert-fixnum args)
+      (apply assert-fixnum args)
       (apply max args)))
 
   (define (fxmin fx1 fx2 . rst)
     (let ((args (cons* fx1 fx2 rst)))
-      (assert-fixnum args)
+      (apply assert-fixnum args)
       (apply min args)))
  
   (define (fx+ fx1 fx2)
-    (assert-fixnum fx1 fx2) (let ((r (+ fx1 fx2))) (assert-fixnum-result r) r))
+    (assert-fixnum fx1 fx2) 
+    (let ((r (+ fx1 fx2))) 
+      (or (fixnum? r) (raise (make-implementation-restriction-violation)))
+      r))
 
   (define (fx* fx1 fx2)
-    (assert-fixnum fx1 fx2) (let ((r (* fx1 fx2))) (assert-fixnum-result r) r))
+    (assert-fixnum fx1 fx2) 
+    (let ((r (* fx1 fx2))) 
+      (or (fixnum? r) (raise (make-implementation-restriction-violation)))
+      r))
 
   (define* (fx- fx1 #:optional fx2)
     (assert-fixnum fx1)
     (if fx2 
        (begin 
          (assert-fixnum fx2) 
-         (let ((r (- fx1 fx2))) (assert-fixnum-result r) r))
-       (let ((r (- fx1))) (assert-fixnum-result r) r)))
-
-  (define (fxdiv x1 x2)
-    (assert-fixnum x1 x2)
+         (let ((r (- fx1 fx2))) 
+           (or (fixnum? r) (raise (make-assertion-violation)))
+           r))
+       (let ((r (- fx1))) 
+         (or (fixnum? r) (raise (make-assertion-violation)))
+         r)))
+
+  (define (fxdiv fx1 fx2)
+    (assert-fixnum fx1 fx2)
     (if (zero? fx2) (raise (make-assertion-violation)))
-    (let ((r (quotient x1 x2))) (assert-fixnum-result r) r))
+    (let ((r (div fx1 fx2))) r))
 
-  (define (fxmod x1 x2)
-    (assert-fixnum x1 x2)
+  (define (fxmod fx1 fx2)
+    (assert-fixnum fx1 fx2)
     (if (zero? fx2) (raise (make-assertion-violation)))
-    (let ((r (modulo x1 x2))) (assert-fixnum-result r) r))
+    (let ((r (mod fx1 fx2))) r))
 
   (define (fxdiv-and-mod fx1 fx2)
     (assert-fixnum fx1 fx2)
     (if (zero? fx2) (raise (make-assertion-violation)))
-    (let ((q (quotient fx1 fx2))
-         (m (modulo fx1 fx2)))
-      (assert-fixnum-result q m)
-      (values q m)))
+    (div-and-mod fx1 fx2))
 
   (define (fxdiv0 fx1 fx2)
     (assert-fixnum fx1 fx2)
     (if (zero? fx2) (raise (make-assertion-violation)))
-    (let ((r (div0 fx1 fx2))) (assert-fixnum-result r) r))
+    (let ((r (div0 fx1 fx2))) r))
   
   (define (fxmod0 fx1 fx2)
     (assert-fixnum fx1 fx2)
     (if (zero? fx2) (raise (make-assertion-violation)))
-    (let ((r (mod0 fx1 fx2))) (assert-fixnum-result r) r))    
+    (let ((r (mod0 fx1 fx2))) r))    
 
   (define (fxdiv0-and-mod0 fx1 fx2)
     (assert-fixnum fx1 fx2)
     (if (zero? fx2) (raise (make-assertion-violation)))
     (call-with-values (lambda () (div0-and-mod0 fx1 fx2))
-      (lambda (q r) (assert-fixnum-result q r) (values q r))))
+      (lambda (q r) (values q r))))
 
   (define (fx+/carry fx1 fx2 fx3)
     (assert-fixnum fx1 fx2 fx3)
     (let* ((s (+ fx1 fx2 fx3))
-          (s0 (mod0 s (expt 2 (fixnum-width))))
-          (s1 (div0 s (expt 2 (fixnum-width)))))
+          (s0 (mod0 s (inexact->exact (expt 2 (fixnum-width)))))
+          (s1 (div0 s (inexact->exact (expt 2 (fixnum-width))))))
       (values s0 s1)))
 
   (define (fx-/carry fx1 fx2 fx3)
@@ -219,12 +232,12 @@
 
   (define (fxif fx1 fx2 fx3) 
     (assert-fixnum fx1 fx2 fx3) 
-    (bitwise-if fx1 fx2 fx2))
+    (bitwise-if fx1 fx2 fx3))
 
   (define (fxbit-count fx) (assert-fixnum fx) (logcount fx))
   (define (fxlength fx) (assert-fixnum fx) (bitwise-length fx))
   (define (fxfirst-bit-set fx) (assert-fixnum fx) (bitwise-first-bit-set fx))
-  (define (fxbit-set? fx1 fx2) (assert-fixnum fx1 fx2) (logbit? fx1 fx2))
+  (define (fxbit-set? fx1 fx2) (assert-fixnum fx1 fx2) (logbit? fx2 fx1))
 
   (define (fxcopy-bit fx1 fx2 fx3) 
     (assert-fixnum fx1 fx2 fx3) 
@@ -242,7 +255,7 @@
   (define fxarithmetic-shift-left fxarithmetic-shift)
 
   (define (fxarithmetic-shift-right fx1 fx2)
-    (assert-fixnum fx1 fx2) (ash fx2 (- fx2)))
+    (assert-fixnum fx1 fx2) (ash fx1 (- fx2)))
 
   (define (fxrotate-bit-field fx1 fx2 fx3 fx4)
     (assert-fixnum fx1 fx2 fx3 fx4)
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index f443a2d..4959768 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -71,6 +71,7 @@ SCM_TESTS = tests/alist.test                  \
            tests/r4rs.test                     \
            tests/r5rs_pitfall.test             \
            tests/r6rs-arithmetic-bitwise.test  \
+           tests/r6rs-arithmetic-fixnums.test  \
            tests/r6rs-arithmetic-flonums.test  \
            tests/r6rs-conditions.test          \
            tests/r6rs-control.test             \
diff --git a/test-suite/tests/r6rs-arithmetic-fixnums.test 
b/test-suite/tests/r6rs-arithmetic-fixnums.test
new file mode 100644
index 0000000..fed72eb
--- /dev/null
+++ b/test-suite/tests/r6rs-arithmetic-fixnums.test
@@ -0,0 +1,211 @@
+;;; arithmetic-fixnums.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-fixnums)
+  :use-module ((rnrs arithmetic fixnums) :version (6))
+  :use-module ((rnrs conditions) :version (6))
+  :use-module ((rnrs exceptions) :version (6))
+  :use-module (test-suite lib))
+
+(with-test-prefix "fixnum?"
+  (pass-if "fixnum? is #t for fixnums" (fixnum? 0))
+
+  (pass-if "fixnum? is #f for non-fixnums" (not (fixnum? 'foo)))
+
+  (pass-if "fixnum? is #f for non-fixnum numbers"
+    (and (not (fixnum? 1.0)) (not (fixnum? (+ (greatest-fixnum) 1))))))
+
+(with-test-prefix "fx=?"
+  (pass-if "fx=? is #t for eqv inputs" (fx=? 3 3 3))
+ 
+  (pass-if "fx=? is #f for non-eqv inputs" (not (fx=? 1 2 3))))
+
+(with-test-prefix "fx>?"
+  (pass-if "fx>? is #t for monotonically > inputs" (fx>? 3 2 1))
+
+  (pass-if "fx>? is #f for non-monotonically > inputs" (not (fx>? 1 2 3))))
+
+(with-test-prefix "fx<?"
+  (pass-if "fx<? is #t for monotonically < inputs" (fx<? 1 2 3))
+
+  (pass-if "fx<? is #t for non-monotonically < inputs" (not (fx<? 3 2 1))))
+
+(with-test-prefix "fx>=?"
+  (pass-if "fx>=? is #t for monotonically > or = inputs" (fx>=? 3 2 2 1))
+
+  (pass-if "fx>=? is #f for non-monotonically > or = inputs" 
+    (not (fx>=? 1 2 3))))
+
+(with-test-prefix "fx<=?"
+  (pass-if "fx<=? is #t for monotonically < or = inputs" (fx<=? 1 2 2 3))
+
+  (pass-if "fx<=? is #f for non-monotonically < or = inputs" 
+    (not (fx<=? 3 2 1))))
+
+(with-test-prefix "fxzero?"
+  (pass-if "fxzero? is #t for zero" (fxzero? 0))
+
+  (pass-if "fxzero? is #f for non-zero fixnums" 
+    (and (not (fxzero? 1)) (not (fxzero? -1)))))
+
+(with-test-prefix "fxpositive?"
+  (pass-if "fxpositive? is #t for positive fixnums" (fxpositive? 1))
+
+  (pass-if "fxpositive? is #f for non-positive fixnums"
+    (and (not (fxpositive? -1))
+        (not (fxpositive? 0)))))
+
+(with-test-prefix "fxnegative?"
+  (pass-if "fxnegative? is #t for negative fixnums" (fxnegative? -1))
+
+  (pass-if "fxnegative? is #f for non-negative fixnums"
+    (and (not (fxnegative? 1))
+        (not (fxnegative? 0)))))
+
+(with-test-prefix "fxodd?"
+  (pass-if "fxodd? is #t for odd fixnums" (fxodd? 1))
+
+  (pass-if "fxodd? is #f for even fixnums" (not (fxodd? 2))))    
+
+(with-test-prefix "fxeven?"
+  (pass-if "fxeven? is #t for even fixnums" (fxeven? 2))
+
+  (pass-if "fxeven? is #f for odd fixnums" (not (fxeven? 1))))
+
+(with-test-prefix "fxmax" (pass-if "simple" (fx=? (fxmax 1 3 2) 3)))
+
+(with-test-prefix "fxmin" (pass-if "simple" (fx=? (fxmin -1 0 2) -1)))
+
+(with-test-prefix "fx+" 
+  (pass-if "simple" (fx=? (fx+ 1 2) 3))
+  
+  (pass-if "&implementation-restriction on non-fixnum result"
+    (guard (condition ((implementation-restriction-violation? condition) #t)
+                     (else #f))
+          (begin (fx+ (greatest-fixnum) 1) #f))))
+
+(with-test-prefix "fx*" 
+  (pass-if "simple" (fx=? (fx* 2 3) 6))
+
+  (pass-if "&implementation-restriction on non-fixnum result"
+    (guard (condition ((implementation-restriction-violation? condition) #t)
+                     (else #f))
+          (begin (fx* (greatest-fixnum) 2) #f))))
+
+(with-test-prefix "fx-" 
+  (pass-if "unary fx- negates argument" (fx=? (fx- 1) -1))
+
+  (pass-if "simple" (fx=? (fx- 3 2) 1))
+
+  (pass-if "&assertion on non-fixnum result"
+    (guard (condition ((assertion-violation? condition) #t) (else #f))
+          (fx- (least-fixnum) 1))))
+
+(with-test-prefix "fxdiv-and-mod"
+  (pass-if "simple"
+    (call-with-values (lambda () (fxdiv-and-mod 123 10))
+      (lambda (d m) 
+       (or (and (fx=? d 12) (fx=? m 3))
+           (throw 'unresolved))))))
+
+(with-test-prefix "fxdiv"
+  (pass-if "simple" (or (fx=? (fxdiv -123 10) -13) (throw 'unresolved))))
+
+(with-test-prefix "fxmod"
+  (pass-if "simple" (or (fx=? (fxmod -123 10) 7) (throw 'unresolved))))
+
+(with-test-prefix "fxdiv0-and-mod0"
+  (pass-if "simple"
+    (call-with-values (lambda () (fxdiv0-and-mod0 -123 10))
+      (lambda (d m)
+       (or (and (fx=? d 12) (fx=? m -3))
+           (throw 'unresolved))))))
+
+(with-test-prefix "fxdiv0"
+  (pass-if "simple" (or (fx=? (fxdiv0 -123 10) 12) (throw 'unresolved))))
+
+(with-test-prefix "fxmod0"
+  (pass-if "simple" (or (fx=? (fxmod0 -123 10) -3) (throw 'unresolved))))
+
+
+;; Without working div and mod implementations and without any example results
+;; from the spec, I have no idea what the results of these functions should
+;; be.  -juliang
+
+(with-test-prefix "fx+/carry" (pass-if "simple" (throw 'unresolved)))
+
+(with-test-prefix "fx-/carry" (pass-if "simple" (throw 'unresolved)))
+
+(with-test-prefix "fx*/carry" (pass-if "simple" (throw 'unresolved)))
+
+(with-test-prefix "fxnot" (pass-if "simple" (fx=? (fxnot 3) -4)))    
+
+(with-test-prefix "fxand" (pass-if "simple" (fx=? (fxand 5 6) 4)))
+
+(with-test-prefix "fxior" (pass-if "simple" (fx=? (fxior 2 4) 6)))
+
+(with-test-prefix "fxxor" (pass-if "simple" (fx=? (fxxor 5 4) 1)))
+
+(with-test-prefix "fxif" (pass-if "simple" (fx=? (fxif 5 3 4) 1)))
+
+(with-test-prefix "fxbit-count" (pass-if "simple" (fx=? (fxbit-count 5) 2)))
+
+(with-test-prefix "fxlength" (pass-if "simple" (fx=? (fxlength 5) 3)))
+
+(with-test-prefix "fxfirst-bit-set"
+  (pass-if "simple"
+    (and (eqv? (fxfirst-bit-set 1) 0)
+         (eqv? (fxfirst-bit-set -4) 2)))
+
+  (pass-if "fxfirst-bit-set is -1 on zero"
+    (and (eqv? (fxfirst-bit-set 0) -1))))
+
+(with-test-prefix "fxbit-set?"
+  (pass-if "fxbit-set? is #t on index of set bit" (fxbit-set? 5 2))
+
+  (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 "fxbit-field" 
+  (pass-if "simple" (fx=? (fxbit-field 50 1 4) 1)))
+
+(with-test-prefix "fxcopy-bit-field" 
+  (pass-if "simple" (fx=? (fxcopy-bit-field 255 2 6 10) 235)))
+
+(with-test-prefix "fxarithmetic-shift"
+  (pass-if "simple"
+    (and (fx=? (fxarithmetic-shift -6 -1) -3)
+         (fx=? (fxarithmetic-shift -5 -1) -3)
+        (fx=? (fxarithmetic-shift -4 -1) -2)
+        (fx=? (fxarithmetic-shift -3 -1) -2)
+        (fx=? (fxarithmetic-shift -2 -1) -1)
+        (fx=? (fxarithmetic-shift -1 -1) -1))))
+
+(with-test-prefix "fxarithmetic-shift-left"
+  (pass-if "simple" (fx=? (fxarithmetic-shift-left -6 -1) -3)))
+
+(with-test-prefix "fxarithmetic-shift-right"
+  (pass-if "simple" (fx=? (fxarithmetic-shift-right -6 1) -3)))
+
+(with-test-prefix "fxrotate-bit-field"
+  (pass-if "simple" (fx=? (fxrotate-bit-field 227 2 6 2) 203)))
+
+(with-test-prefix "fxreverse-bit-field"
+  (pass-if "simple" (fx=? (fxreverse-bit-field 82 1 4) 88)))


hooks/post-receive
-- 
GNU Guile