>From c2afe44e9de376b7e3dc2f1f53fc18adbfe63552 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 26 Jan 2011 07:37:32 -0500 Subject: [PATCH] Fix R6RS `div', `mod', `div-and-mod', `div0', `mod0', and `div0-and-mod0' * module/rnrs/base.scm (div, mod, div-and-mod): Implement these properly (though admittedly inefficiently). Previously, `div' and `mod' were aliases of R5RS `quotient' and `modulo', although they have different semantics. R6RS `mod' is supposed to return a non-negative number less than the absolute value of the divisor, but R5RS `modulo' returns a number of the same sign as the divisor (or zero). R6RS `div' is supposed to return (floor (/ x y)), but R5RS `quotient' returns (truncate (/ x y)). For example, R6RS states that (div-and-mod 123 -10) should return -12 and 3, but previously it returned -12 and -7. (div0, mod0, div0-and-mod0): Implement these properly (though admittedly inefficiently). For example, R6RS states that (div0-and-mod0 123 -10) should return -12 and 3, but previously it returned -12 and -7. * test-suite/tests/r6rs-base.test: Add test cases for `div', `mod', `div-and-mod', `div0', `mod0', and `div0-and-mod0'. * test-suite/tests/r6rs-arithmetic-fixnums.test: Remove incorrect tests, and add proper test cases for `fxdiv', `fxmod', `fxdiv-and-mod', `fxdiv0', `fxmod0', and `fxdiv0-and-mod0'. --- NEWS | 14 ++++ module/rnrs/base.scm | 27 +++++--- test-suite/tests/r6rs-arithmetic-fixnums.test | 82 +++++++++++++++++------- test-suite/tests/r6rs-base.test | 81 ++++++++++++++++++++++++ 4 files changed, 170 insertions(+), 34 deletions(-) diff --git a/NEWS b/NEWS index 56cf88d..f2178f6 100644 --- a/NEWS +++ b/NEWS @@ -68,6 +68,20 @@ NaNs are neither finite nor infinite. *** R6RS base library changes +**** `div', `mod', and `div-and-mod' now implemented correctly + +These functions are now implemented correctly (though admittedly +inefficiently). Previously, `div' and `mod' were aliases of R5RS +`quotient' and `modulo', although they have different semantics. +For example, R6RS states that (div-and-mod 123 -10) should return +-12 and 3, but previously it returned -12 and -7. + +**** `div0', `mod0', and `div0-and-mod0' now implemented correctly + +These functions are now implemented correctly (though admittedly +inefficiently). R6RS states that (div0-and-mod0 123 -10) should +return -12 and 3, but previously it returned -12 and -7. + **** `infinite?' changes `infinite?' now returns #t for non-real complex infinities, and throws diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm index 04a7e23..f4f1c86 100644 --- a/module/rnrs/base.scm +++ b/module/rnrs/base.scm @@ -74,8 +74,6 @@ syntax-rules identifier-syntax) (import (rename (except (guile) error raise) - (quotient div) - (modulo mod) (inf? infinite?) (exact->inexact inexact) (inexact->exact exact)) @@ -119,20 +117,29 @@ (define (vector-map proc . vecs) (list->vector (apply map (cons proc (map vector->list vecs))))) - (define (div-and-mod x y) (let ((q (div x y)) (r (mod x y))) (values q r))) + (define (div x y) + (cond ((positive? y) (floor (/ x y))) + ((negative? y) (ceiling (/ x y))) + (else (raise (make-assertion-violation))))) + + (define (mod x y) + (- x (* y (div x y)))) + + (define (div-and-mod x y) + (let ((q (div x y))) + (values q (- x (* y q))))) (define (div0 x y) - (call-with-values (lambda () (div0-and-mod0 x y)) (lambda (q r) q))) + (cond ((positive? y) (floor (+ 1/2 (/ x y)))) + ((negative? y) (ceiling (+ -1/2 (/ x y)))) + (else (raise (make-assertion-violation))))) (define (mod0 x y) - (call-with-values (lambda () (div0-and-mod0 x y)) (lambda (q r) r))) + (- x (* y (div0 x y)))) (define (div0-and-mod0 x y) - (call-with-values (lambda () (div-and-mod x y)) - (lambda (q r) - (cond ((< r (abs (/ y 2))) (values q r)) - ((negative? y) (values (- q 1) (+ r y))) - (else (values (+ q 1) (+ r y))))))) + (let ((q (div0 x y))) + (values q (- x (* y q))))) (define raise (@ (rnrs exceptions) raise)) diff --git a/test-suite/tests/r6rs-arithmetic-fixnums.test b/test-suite/tests/r6rs-arithmetic-fixnums.test index fed72eb..4bf20a9 100644 --- a/test-suite/tests/r6rs-arithmetic-fixnums.test +++ b/test-suite/tests/r6rs-arithmetic-fixnums.test @@ -1,6 +1,6 @@ ;;; arithmetic-fixnums.test --- Test suite for R6RS (rnrs arithmetic bitwise) -;; Copyright (C) 2010 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011 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 @@ -118,35 +118,69 @@ (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)))) + (let ((tests '(( 123 10 12 3 ) + ( 123 -10 -12 3 ) + (-123 10 -13 7 ) + (-123 -10 13 7 ) + ( 12 3 4 0 ) + ( 12 -3 -4 0 ) + ( -12 3 -4 0 ) + ( -12 -3 4 0 )))) + (pass-if "fxdiv-and-mod" + (for-each (lambda (quad) + (apply + (lambda (x y q r) + (call-with-values + (lambda () (fxdiv-and-mod x y)) + (lambda (qq rr) + (if (not (and (eqv? q qq) + (eqv? r rr) + (eqv? q (fxdiv x y)) + (eqv? r (fxmod x y)) + (>= r 0) + (< r (abs y)) + (fx=? x (+ r (* y q))))) + (begin + (pk x y q r) + (throw 'fail)))))) + quad)) + tests) + #t))) (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)))) - + (let ((tests '(( 123 10 12 3 ) + ( 123 -10 -12 3 ) + (-123 10 -12 -3 ) + (-123 -10 12 -3 ) + ( 12 3 4 0 ) + ( 12 -3 -4 0 ) + ( -12 3 -4 0 ) + ( -12 -3 4 0 )))) + (pass-if "fxdiv0-and-mod0" + (for-each (lambda (quad) + (apply + (lambda (x y q r) + (call-with-values + (lambda () (fxdiv0-and-mod0 x y)) + (lambda (qq rr) + (if (not (and (eqv? q qq) + (eqv? r rr) + (eqv? q (fxdiv0 x y)) + (eqv? r (fxmod0 x y)) + (>= r (* -1/2 (abs y))) + (< r (* 1/2 (abs y))) + (fx=? x (+ r (* y q))))) + (begin + (pk x y q r) + (throw 'fail)))))) + quad)) + tests) + #t))) ;; 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 +;; UPDATE: div and mod implementations are now working properly -mhw (with-test-prefix "fx+/carry" (pass-if "simple" (throw 'unresolved))) diff --git a/test-suite/tests/r6rs-base.test b/test-suite/tests/r6rs-base.test index 1509b04..7a5895a 100644 --- a/test-suite/tests/r6rs-base.test +++ b/test-suite/tests/r6rs-base.test @@ -172,3 +172,84 @@ (pass-if (not (integer-valued? +0.01i))) (pass-if (not (integer-valued? -inf.0i)))) +(with-test-prefix "div-and-mod" + (let ((tests '(( 123 10 12 3 ) + ( 123 -10 -12 3 ) + (-123 10 -13 7 ) + (-123 -10 13 7 ) + ( 12 3 4 0 ) + ( 12 -3 -4 0 ) + ( -12 3 -4 0 ) + ( -12 -3 4 0 ) + ( 8.5 4 2.0 0.5 ) + ( 8.5 -4 -2.0 0.5 ) + (-8.5 4 -3.0 3.5 ) + (-8.5 -4 3.0 3.5 ) + ( 8.75 4.5 1.0 4.25 ) + ( 8.75 -4.5 -1.0 4.25 ) + (-8.75 4.5 -2.0 0.25 ) + (-8.75 -4.5 2.0 0.25 ) + ( 8.875 4.5 1.0 4.375) + ( 9 4.5 2.0 0.0 ) + ( 9.125 4.5 2.0 0.125)))) + (pass-if "div-and-mod" + (for-each (lambda (quad) + (apply + (lambda (x y q r) + (call-with-values + (lambda () (div-and-mod x y)) + (lambda (qq rr) + (if (not (and (eqv? q qq) + (eqv? r rr) + (eqv? q (div x y)) + (eqv? r (mod x y)) + (>= r 0) + (< r (abs y)) + (= x (+ r (* y q))))) + (begin + (pk x y q r) + (throw 'fail)))))) + quad)) + tests) + #t))) + +(with-test-prefix "div0-and-mod0" + (let ((tests '(( 123 10 12 3 ) + ( 123 -10 -12 3 ) + (-123 10 -12 -3 ) + (-123 -10 12 -3 ) + ( 12 3 4 0 ) + ( 12 -3 -4 0 ) + ( -12 3 -4 0 ) + ( -12 -3 4 0 ) + ( 8.5 4 2.0 0.5 ) + ( 8.5 -4 -2.0 0.5 ) + (-8.5 4 -2.0 -0.5 ) + (-8.5 -4 2.0 -0.5 ) + ( 8.75 4.5 2.0 -0.25 ) + ( 8.75 -4.5 -2.0 -0.25 ) + (-8.75 4.5 -2.0 0.25 ) + (-8.75 -4.5 2.0 0.25 ) + ( 6.875 4.5 2.0 -2.125) + ( 6.75 4.5 2.0 -2.25 ) + ( 6.625 4.5 1.0 2.125)))) + (pass-if "div0-and-mod0" + (for-each (lambda (quad) + (apply + (lambda (x y q r) + (call-with-values + (lambda () (div0-and-mod0 x y)) + (lambda (qq rr) + (if (not (and (eqv? q qq) + (eqv? r rr) + (eqv? q (div0 x y)) + (eqv? r (mod0 x y)) + (>= r (* -1/2 (abs y))) + (< r (* 1/2 (abs y))) + (= x (+ r (* y q))))) + (begin + (pk x y q r) + (throw 'fail)))))) + quad)) + tests) + #t))) -- 1.5.6.5