SCM_SWAP (x, y);
goto big_inum;
}
+ else if (SCM_REALP (y) && scm_is_integer (y))
+ goto handle_inexacts;
else
return scm_wta_dispatch_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
}
scm_remember_upto_here_2 (x, y);
return scm_i_normbig (result);
}
+ else if (SCM_REALP (y) && scm_is_integer (y))
+ goto handle_inexacts;
+ else
+ SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
+ }
+ else if (SCM_REALP (x) && scm_is_integer (x))
+ {
+ if (SCM_I_INUMP (y) || SCM_BIGP (y)
+ || (SCM_REALP (y) && scm_is_integer (y)))
+ {
+ handle_inexacts:
+ return scm_exact_to_inexact (scm_gcd (scm_inexact_to_exact (x),
+ scm_inexact_to_exact (y)));
+ }
else
return scm_wta_dispatch_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
}
SCM
scm_lcm (SCM n1, SCM n2)
{
- if (SCM_UNBNDP (n2))
- {
- if (SCM_UNBNDP (n1))
- return SCM_I_MAKINUM (1L);
- n2 = SCM_I_MAKINUM (1L);
- }
-
- if (SCM_UNLIKELY (!(SCM_I_INUMP (n1) || SCM_BIGP (n1))))
- return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG1, s_lcm);
-
- if (SCM_UNLIKELY (!(SCM_I_INUMP (n2) || SCM_BIGP (n2))))
- return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm);
+ if (SCM_UNLIKELY (SCM_UNBNDP (n2)))
+ return SCM_UNBNDP (n1) ? SCM_INUM1 : scm_abs (n1);
- if (SCM_I_INUMP (n1))
+ if (SCM_LIKELY (SCM_I_INUMP (n1)))
{
- if (SCM_I_INUMP (n2))
+ if (SCM_LIKELY (SCM_I_INUMP (n2)))
{
SCM d = scm_gcd (n1, n2);
if (scm_is_eq (d, SCM_INUM0))
else
return scm_abs (scm_product (n1, scm_quotient (n2, d)));
}
- else
+ else if (SCM_LIKELY (SCM_BIGP (n2)))
{
/* inum n1, big n2 */
inumbig:
return result;
}
}
+ else if (SCM_REALP (n2) && scm_is_integer (n2))
+ goto handle_inexacts;
+ else
+ return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm);
}
- else
+ else if (SCM_LIKELY (SCM_BIGP (n1)))
{
/* big n1 */
if (SCM_I_INUMP (n2))
SCM_SWAP (n1, n2);
goto inumbig;
}
- else
+ else if (SCM_LIKELY (SCM_BIGP (n2)))
{
SCM result = scm_i_mkbig ();
mpz_lcm(SCM_I_BIG_MPZ (result),
/* shouldn't need to normalize b/c lcm of 2 bigs should be big */
return result;
}
+ else if (SCM_REALP (n2) && scm_is_integer (n2))
+ goto handle_inexacts;
+ else
+ return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm);
}
+ else if (SCM_REALP (n1) && scm_is_integer (n1))
+ {
+ if (SCM_I_INUMP (n2) || SCM_BIGP (n2)
+ || (SCM_REALP (n2) && scm_is_integer (n2)))
+ {
+ handle_inexacts:
+ return scm_exact_to_inexact (scm_lcm (scm_inexact_to_exact (n1),
+ scm_inexact_to_exact (n2)));
+ }
+ else
+ return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm);
+ }
+ else
+ return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG1, s_lcm);
}
/* Emulating 2's complement bignums with sign magnitude arithmetic:
double xx = SCM_REAL_VALUE (x);
double yy = SCM_REAL_VALUE (y);
- /* For purposes of max: +inf.0 > nan > everything else, per R6RS */
+ /* For purposes of max: nan > +inf.0 > everything else,
+ per the R6RS errata */
if (xx > yy)
return x;
else if (SCM_LIKELY (xx < yy))
return y;
/* If neither (xx > yy) nor (xx < yy), then
either they're equal or one is a NaN */
- else if (SCM_UNLIKELY (isnan (xx)))
- return DOUBLE_IS_POSITIVE_INFINITY (yy) ? y : x;
- else if (SCM_UNLIKELY (isnan (yy)))
- return DOUBLE_IS_POSITIVE_INFINITY (xx) ? x : y;
+ else if (SCM_UNLIKELY (xx != yy))
+ return (xx != xx) ? x : y; /* Return the NaN */
/* xx == yy, but handle signed zeroes properly */
else if (double_is_non_negative_zero (yy))
return y;
double xx = SCM_REAL_VALUE (x);
double yy = SCM_REAL_VALUE (y);
- /* For purposes of min: -inf.0 < nan < everything else, per R6RS */
+ /* For purposes of min: nan < -inf.0 < everything else,
+ per the R6RS errata */
if (xx < yy)
return x;
else if (SCM_LIKELY (xx > yy))
return y;
/* If neither (xx < yy) nor (xx > yy), then
either they're equal or one is a NaN */
- else if (SCM_UNLIKELY (isnan (xx)))
- return DOUBLE_IS_NEGATIVE_INFINITY (yy) ? y : x;
- else if (SCM_UNLIKELY (isnan (yy)))
- return DOUBLE_IS_NEGATIVE_INFINITY (xx) ? x : y;
+ else if (SCM_UNLIKELY (xx != yy))
+ return (xx != xx) ? x : y; /* Return the NaN */
/* xx == yy, but handle signed zeroes properly */
else if (double_is_non_negative_zero (xx))
return y;
(only (guile) inf?)
(rnrs arithmetic fixnums (6))
(rnrs base (6))
+ (rnrs control (6))
(rnrs conditions (6))
(rnrs exceptions (6))
(rnrs lists (6))
(rnrs r5rs (6)))
- (define (flonum? obj) (and (number? obj) (inexact? obj)))
+ (define (flonum? obj) (and (real? obj) (inexact? obj)))
(define (assert-flonum . args)
(or (for-all flonum? args) (raise (make-assertion-violation))))
(define (assert-iflonum . args)
(or (for-all (lambda (i) (and (flonum? i) (integer? i))) args)
(raise (make-assertion-violation))))
+ (define (ensure-flonum z)
+ (cond ((real? z) z)
+ ((zero? (imag-part z)) (real-part z))
+ (else +nan.0)))
+
(define (real->flonum x)
(or (real? x) (raise (make-assertion-violation)))
(exact->inexact x))
(define (flnegative? fl) (assert-flonum fl) (negative? fl))
(define (flodd? ifl) (assert-iflonum ifl) (odd? ifl))
(define (fleven? ifl) (assert-iflonum ifl) (even? ifl))
- (define (flfinite? fl) (assert-flonum fl) (not (inf? fl)))
+ (define (flfinite? fl) (assert-flonum fl) (not (or (inf? fl) (nan? fl))))
(define (flinfinite? fl) (assert-flonum fl) (inf? fl))
(define (flnan? fl) (assert-flonum fl) (nan? fl))
(apply assert-flonum flargs)
(apply min flargs)))
- (define (fl+ fl1 . args)
- (let ((flargs (cons fl1 args)))
- (apply assert-flonum flargs)
- (apply + flargs)))
+ (define (fl+ . args)
+ (apply assert-flonum args)
+ (if (null? args) 0.0 (apply + args)))
- (define (fl* fl1 . args)
- (let ((flargs (cons fl1 args)))
- (apply assert-flonum flargs)
- (apply * flargs)))
+ (define (fl* . args)
+ (apply assert-flonum args)
+ (if (null? args) 1.0 (apply * args)))
(define (fl- fl1 . args)
(let ((flargs (cons fl1 args)))
(define (flround fl) (assert-flonum fl) (round fl))
(define (flexp fl) (assert-flonum fl) (exp fl))
- (define* (fllog fl #:optional fl2)
- (assert-flonum fl)
- (cond ((fl=? fl -inf.0) +nan.0)
- (fl2 (begin (assert-flonum fl2) (/ (log fl) (log fl2))))
- (else (log fl))))
+ (define fllog
+ (case-lambda
+ ((fl)
+ (assert-flonum fl)
+ ;; add 0.0 to fl, to change -0.0 to 0.0,
+ ;; so that (fllog -0.0) will be -inf.0, not -inf.0+pi*i.
+ (ensure-flonum (log (+ fl 0.0))))
+ ((fl fl2)
+ (assert-flonum fl fl2)
+ (ensure-flonum (/ (log (+ fl 0.0))
+ (log (+ fl2 0.0)))))))
(define (flsin fl) (assert-flonum fl) (sin fl))
(define (flcos fl) (assert-flonum fl) (cos fl))
(define (fltan fl) (assert-flonum fl) (tan fl))
- (define (flasin fl) (assert-flonum fl) (asin fl))
- (define (flacos fl) (assert-flonum fl) (acos fl))
- (define* (flatan fl #:optional fl2)
- (assert-flonum fl)
- (if fl2 (begin (assert-flonum fl2) (atan fl fl2)) (atan fl)))
-
- (define (flsqrt fl) (assert-flonum fl) (sqrt fl))
- (define (flexpt fl1 fl2) (assert-flonum fl1 fl2) (expt fl1 fl2))
+ (define (flasin fl) (assert-flonum fl) (ensure-flonum (asin fl)))
+ (define (flacos fl) (assert-flonum fl) (ensure-flonum (acos fl)))
+ (define flatan
+ (case-lambda
+ ((fl) (assert-flonum fl) (atan fl))
+ ((fl fl2) (assert-flonum fl fl2) (atan fl fl2))))
+
+ (define (flsqrt fl) (assert-flonum fl) (ensure-flonum (sqrt fl)))
+ (define (flexpt fl1 fl2) (assert-flonum fl1 fl2) (ensure-flonum (expt fl1 fl2)))
(define-condition-type &no-infinities
&implementation-restriction
(pass-if "n = fixnum-min - 1"
(eqv? (- (- fixnum-min 1)) (gcd (- fixnum-min 1) (- fixnum-min 1)))))
+ (with-test-prefix "flonum arguments"
+
+ (pass-if-equal "flonum"
+ 15.0
+ (gcd -15.0))
+
+ (pass-if-equal "flonum/flonum"
+ 3.0
+ (gcd 6.0 -15.0))
+
+ (pass-if-equal "flonum/fixnum"
+ 3.0
+ (gcd 6.0 -15))
+
+ (pass-if-equal "fixnum/flonum"
+ 3.0
+ (gcd -6 15.0))
+
+ (pass-if-equal "flonum/bignum"
+ 2.0
+ (gcd -6.0 (expt 2 fixnum-bit)))
+
+ (pass-if-equal "bignum/flonum"
+ 3.0
+ (gcd (- (expt 3 fixnum-bit)) 6.0)))
+
;; Are wrong type arguments detected correctly?
)
;; FIXME: more tests?
;; (some of these are already in r4rs.test)
(pass-if (documented? lcm))
- (pass-if (= (lcm) 1))
- (pass-if (= (lcm 32 -36) 288))
+ (pass-if-equal 1 (lcm))
+ (pass-if-equal 15 (lcm -15))
+ (pass-if-equal 288 (lcm 32 -36))
+
+ (with-test-prefix "flonum arguments"
+
+ (pass-if-equal "flonum"
+ 15.0
+ (lcm -15.0))
+
+ (pass-if-equal "flonum/flonum"
+ 30.0
+ (lcm 6.0 -15.0))
+
+ (pass-if-equal "flonum/fixnum"
+ 30.0
+ (lcm 6.0 -15))
+
+ (pass-if-equal "fixnum/flonum"
+ 30.0
+ (lcm -6 15.0))
+
+ (pass-if "flonum/bignum"
+ (let ((want (* 3.0 (expt 2 fixnum-bit)))
+ (got (lcm -6.0 (expt 2 fixnum-bit))))
+ (and (inexact? got)
+ (test-eqv? 1.0 (/ want got)))))
+
+ (pass-if "bignum/flonum"
+ (let ((want (* 2.0 (expt 3 fixnum-bit)))
+ (got (lcm (- (expt 3 fixnum-bit)) 6.0)))
+ (and (inexact? got)
+ (test-eqv? 1.0 (/ want got))))))
+
(let ((big-n 115792089237316195423570985008687907853269984665640564039457584007913129639936) ; 2 ^ 256
(lcm-of-big-n-and-11 1273712981610478149659280835095566986385969831322046204434033424087044426039296))
(pass-if (= lcm-of-big-n-and-11 (lcm big-n 11)))
(pass-if (eqv? 5/2 (max 5/2 2))))
(with-test-prefix "infinities and NaNs"
- ;; +inf.0 beats everything else, including NaNs
+ ;; +inf.0 beats everything except NaNs
(pass-if (eqv? +inf.0 (max +inf.0 123 )))
(pass-if (eqv? +inf.0 (max 123 +inf.0 )))
(pass-if (eqv? +inf.0 (max +inf.0 -123.3 )))
(pass-if (eqv? +inf.0 (max (- big*2) +inf.0 )))
(pass-if (eqv? +inf.0 (max +inf.0 +inf.0 )))
(pass-if (eqv? +inf.0 (max +inf.0 +inf.0 )))
- (pass-if (eqv? +inf.0 (max +inf.0 +nan.0 )))
- (pass-if (eqv? +inf.0 (max +nan.0 +inf.0 )))
(pass-if (eqv? +inf.0 (max +inf.0 +inf.0 )))
- ;; NaNs beat everything except +inf.0
+ ;; NaNs beat everything
(pass-if (real-nan? (max +nan.0 123 )))
(pass-if (real-nan? (max 123 +nan.0 )))
(pass-if (real-nan? (max +nan.0 123.3 )))
(pass-if (real-nan? (max +nan.0 -inf.0 )))
(pass-if (real-nan? (max -inf.0 +nan.0 )))
(pass-if (real-nan? (max +nan.0 +nan.0 )))
+ (pass-if (real-nan? (max +inf.0 +nan.0 )))
+ (pass-if (real-nan? (max +nan.0 +inf.0 )))
;; -inf.0 always loses, except against itself
(pass-if (eqv? -inf.0 (max -inf.0 -inf.0 )))
(pass-if (eqv? 2 (min 5/2 2))))
(with-test-prefix "infinities and NaNs"
- ;; -inf.0 beats everything else, including NaNs
+ ;; -inf.0 beats everything except NaNs
(pass-if (eqv? -inf.0 (min -inf.0 123 )))
(pass-if (eqv? -inf.0 (min 123 -inf.0 )))
(pass-if (eqv? -inf.0 (min -inf.0 -123.3 )))
(pass-if (eqv? -inf.0 (min (- big*2) -inf.0 )))
(pass-if (eqv? -inf.0 (min -inf.0 +inf.0 )))
(pass-if (eqv? -inf.0 (min +inf.0 -inf.0 )))
- (pass-if (eqv? -inf.0 (min -inf.0 +nan.0 )))
- (pass-if (eqv? -inf.0 (min +nan.0 -inf.0 )))
(pass-if (eqv? -inf.0 (min -inf.0 -inf.0 )))
- ;; NaNs beat everything except -inf.0
+ ;; NaNs beat everything
(pass-if (real-nan? (min +nan.0 123 )))
(pass-if (real-nan? (min 123 +nan.0 )))
(pass-if (real-nan? (min +nan.0 123.3 )))
(pass-if (real-nan? (min +nan.0 +inf.0 )))
(pass-if (real-nan? (min +inf.0 +nan.0 )))
(pass-if (real-nan? (min +nan.0 +nan.0 )))
+ (pass-if (real-nan? (min -inf.0 +nan.0 )))
+ (pass-if (real-nan? (min +nan.0 -inf.0 )))
;; +inf.0 always loses, except against itself
(pass-if (eqv? +inf.0 (min +inf.0 +inf.0 )))
(pass-if "flonum? is #t on flonum"
(flonum? 1.5))
- (pass-if "flonum? is #f on non-flonum"
+ (pass-if "flonum? is #f on complex"
+ (not (flonum? 1.5+0.0i)))
+
+ (pass-if "flonum? is #f on exact integer"
(not (flonum? 3))))
(with-test-prefix "real->flonum"
(flfinite? 2.0))
(pass-if "flfinite? is #f on infinities"
- (and (not (flfinite? +inf.0)) (not (flfinite? -inf.0)))))
+ (and (not (flfinite? +inf.0)) (not (flfinite? -inf.0))))
+
+ (pass-if "flfinite? is #f on NaNs"
+ (not (flfinite? +nan.0))))
(with-test-prefix "flinfinite?"
(pass-if "flinfinite? is #t on infinities"
(pass-if "simple" (fl=? (flmin -1.0 0.0 2.0) -1.0)))
(with-test-prefix "fl+"
- (pass-if "simple" (fl=? (fl+ 2.141 1.0 0.1) 3.241)))
+ (pass-if "simple" (fl=? (fl+ 2.141 1.0 0.1) 3.241))
+ (pass-if "zero args" (fl=? (fl+) 0.0)))
(with-test-prefix "fl*"
- (pass-if "simple" (fl=? (fl* 1.0 2.0 3.0 1.5) 9.0)))
+ (pass-if "simple" (fl=? (fl* 1.0 2.0 3.0 1.5) 9.0))
+ (pass-if "zero args" (fl=? (fl*) 1.0)))
(with-test-prefix "fl-"
(pass-if "unary fl- negates argument" (fl=? (fl- 2.0) -2.0))
(with-test-prefix "fllog"
(pass-if "unary fllog returns natural log"
- (let ((l (fllog 2.718281828459045)))
- (and (fl<=? 0.9 l) (fl>=? 1.1 l))))
+ (reasonably-close? (fllog 2.718281828459045) 1.0))
(pass-if "infinities"
(and (fl=? (fllog +inf.0) +inf.0)
(flnan? (fllog -inf.0))))
- (pass-if "zeroes" (fl=? (fllog 0.0) -inf.0))
+ (pass-if "negative argument"
+ (flnan? (fllog -1.0)))
+
+ (pass-if "zero" (fl=? (fllog 0.0) -inf.0))
+ (pass-if "negative zero" (fl=? (fllog -0.0) -inf.0))
+ (pass-if "negative zero with base" (fl=? (fllog -0.0 0.5) +inf.0))
(pass-if "binary fllog returns log in specified base"
(fl=? (fllog 8.0 2.0) 3.0)))
(with-test-prefix "flasin"
(pass-if "simple"
(and (reasonably-close? (flasin 1.0) (/ fake-pi 2))
- (reasonably-close? (flasin 0.5) (/ fake-pi 6)))))
+ (reasonably-close? (flasin 0.5) (/ fake-pi 6))))
+ (pass-if "out of range"
+ (flnan? (flasin 2.0))))
(with-test-prefix "flacos"
(pass-if "simple"
(and (fl=? (flacos 1.0) 0.0)
- (reasonably-close? (flacos 0.5) (/ fake-pi 3)))))
+ (reasonably-close? (flacos 0.5) (/ fake-pi 3))))
+ (pass-if "out of range"
+ (flnan? (flacos 2.0))))
(with-test-prefix "flatan"
(pass-if "unary flatan"
(with-test-prefix "flsqrt"
(pass-if "simple" (fl=? (flsqrt 4.0) 2.0))
-
+ (pass-if "negative" (flnan? (flsqrt -1.0)))
(pass-if "infinity" (fl=? (flsqrt +inf.0) +inf.0))
-
(pass-if "negative zero" (fl=? (flsqrt -0.0) -0.0)))
-(with-test-prefix "flexpt" (pass-if "simple" (fl=? (flexpt 2.0 3.0) 8.0)))
+(with-test-prefix "flexpt"
+ (pass-if "simple" (fl=? (flexpt 2.0 3.0) 8.0))
+ (pass-if "negative squared" (fl=? (flexpt -2.0 2.0) 4.0))
+ (pass-if "negative cubed" (fl=? (flexpt -2.0 3.0) -8.0))
+ (pass-if "negative to non-integer power" (flnan? (flexpt -2.0 2.5))))
(with-test-prefix "fixnum->flonum"
(pass-if "simple" (fl=? (fixnum->flonum 100) 100.0)))
HCoop / bpt / guile.git / commitdiff