diff options
-rw-r--r-- | module/Makefile.am | 2 | ||||
-rw-r--r-- | module/rnrs/6/base.scm | 21 | ||||
-rw-r--r-- | module/rnrs/arithmetic/6/fixnums.scm | 255 | ||||
-rw-r--r-- | module/rnrs/arithmetic/6/flonums.scm | 216 | ||||
-rw-r--r-- | test-suite/Makefile.am | 1 | ||||
-rw-r--r-- | test-suite/tests/r6rs-arithmetic-flonums.test | 310 |
6 files changed, 803 insertions, 2 deletions
diff --git a/module/Makefile.am b/module/Makefile.am index 45161200f..a44753562 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -273,6 +273,8 @@ RNRS_SOURCES = \ rnrs/6/syntax-case.scm \ rnrs/6/unicode.scm \ rnrs/arithmetic/6/bitwise.scm \ + rnrs/arithmetic/6/fixnums.scm \ + rnrs/arithmetic/6/flonums.scm \ rnrs/bytevector.scm \ rnrs/io/6/simple.scm \ rnrs/io/ports.scm \ diff --git a/module/rnrs/6/base.scm b/module/rnrs/6/base.scm index e7f52c4a3..4358aa4f7 100644 --- a/module/rnrs/6/base.scm +++ b/module/rnrs/6/base.scm @@ -71,7 +71,24 @@ let-syntax letrec-syntax syntax-rules identifier-syntax) - (import (guile) + (import (rename (guile) (quotient div) (modulo mod)) (rename (only (guile) for-each map) (for-each vector-for-each) (map vector-map)) - (srfi srfi-11))) + (srfi srfi-11)) + + (define (div-and-mod x y) (let ((q (div x y)) (r (mod x y))) (values q r))) + + (define (div0 x y) + (call-with-values (lambda () (div0-and-mod0 x y)) (lambda (q r) q))) + + (define (mod0 x y) + (call-with-values (lambda () (div0-and-mod0 x y)) (lambda (q r) r))) + + (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))))))) + +) diff --git a/module/rnrs/arithmetic/6/fixnums.scm b/module/rnrs/arithmetic/6/fixnums.scm new file mode 100644 index 000000000..2c8b716da --- /dev/null +++ b/module/rnrs/arithmetic/6/fixnums.scm @@ -0,0 +1,255 @@ +;;; fixnums.scm --- The R6RS fixnums arithmetic 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 fixnums (6)) + (export fixnum? + + fixnum-width + least-fixnum + greatest-fixnum + + fx=? + fx>? + fx<? + fx>=? + fx<=? + + fxzero? + fxpositive? + fxnegative? + fxodd? + fxeven? + + fxmax + fxmin + + fx+ + fx* + fx- + + fxdiv-and-mod + fxdiv + fxmod + fxdiv0-and-mod0 + fxdiv0 + fxmod0 + + fx+/carry + fx-/carry + fx*/carry + + fxand + fxior + fxxor + fxif + + fxbit-count + fxlength + fxfirst-bit-set + fxbit-set? + fxcopy-bit + fxbit-field + fxcopy-bit-field + + fxarithmetic-shift + fxarithmetic-shift-left + fxarithmetic-shift-right + + 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)) + (ice-9 optargs) + (rnrs base (6)) + (rnrs arithmetic bitwise (6)) + (rnrs conditions (6)) + (rnrs exceptions (6))) + + (define fixnum-width (round (/ (log (+ greatest-fixnum 1)) (log 2)))) + + (define (fixnum? obj) + (and (exact? obj) + (integer? obj) + (>= obj least-fixnum) + (<= obj greatest-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)))) + + (define (fx=? fx1 fx2 . rst) + (let ((args (cons* fx1 fx2 rst))) + (apply assert-fixnum args) + (apply = args))) + + (define (fx>? fx1 fx2 . rst) + (let ((args (cons* fx1 fx2 rst))) + (apply assert-fixnum args) + (apply > args))) + + (define (fx<? fx1 fx2 . rst) + (let ((args (cons* fx1 fx2 rst))) + (apply assert-fixnum rst) + (apply < args))) + + (define (fx>=? fx1 fx2 . rst) + (let ((args (cons* fx1 fx2 rst))) + (apply assert-fixnum rst) + (apply >= args))) + + (define (fx<=? fx1 fx2 . rst) + (let ((args (cons* fx1 fx2 rst))) + (apply assert-fixnum rst) + (apply <= args))) + + (define (fxzero? fx) (assert-fixnum fx) (zero? fx)) + (define (fxpositive? fx) (assert-fixnum fx) (positive? fx)) + (define (fxnegative? fx) (assert-fixnum fx) (negative? fx)) + (define (fxodd? fx) (assert-fixnum fx) (odd? fx)) + (define (fxeven? fx) (assert-fixnum fx) (even? fx)) + + (define (fxmax fx1 fx2 . rst) + (let ((args (cons* fx1 fx2 rst))) + (assert-fixnum args) + (apply max args))) + + (define (fxmin fx1 fx2 . rst) + (let ((args (cons* fx1 fx2 rst))) + (assert-fixnum args) + (apply min args))) + + (define (fx+ fx1 fx2) + (assert-fixnum fx1 fx2) (let ((r (+ fx1 fx2))) (assert-fixnum-result r) r)) + + (define (fx* fx1 fx2) + (assert-fixnum fx1 fx2) (let ((r (* fx1 fx2))) (assert-fixnum-result r) 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) + (if (zero? fx2) (raise (make-assertion-violation))) + (let ((r (quotient x1 x2))) (assert-fixnum-result r) r)) + + (define (fxmod x1 x2) + (assert-fixnum x1 x2) + (if (zero? fx2) (raise (make-assertion-violation))) + (let ((r (modulo x1 x2))) (assert-fixnum-result r) 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))) + + (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)) + + (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)) + + (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)))) + + (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))))) + (values s0 s1))) + + (define (fx-/carry fx1 fx2 fx3) + (assert-fixnum fx1 fx2 fx3) + (let* ((d (- fx1 fx2 fx3)) + (d0 (mod0 d (expt 2 (fixnum-width)))) + (d1 (div0 d (expt 2 (fixnum-width))))) + (values d0 d1))) + + (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))))) + (values s0 s1))) + + (define (fxnot fx) (assert-fixnum fx) (lognot fx)) + (define (fxand . args) (apply assert-fixnum args) (apply logand args)) + (define (fxior . args) (apply assert-fixnum args) (apply logior args)) + (define (fxxor . args) (apply assert-fixnum args) (apply logxor args)) + + (define (fxif fx1 fx2 fx3) + (assert-fixnum fx1 fx2 fx3) + (bitwise-if fx1 fx2 fx2)) + + (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 (fxcopy-bit fx1 fx2 fx3) + (assert-fixnum fx1 fx2 fx3) + (bitwise-copy-bit fx1 fx2 fx3)) + + (define (fxbit-field fx1 fx2 fx3) + (assert-fixnum fx1 fx2 fx3) + (bitwise-bit-field fx1 fx2 fx3)) + + (define (fxcopy-bit-field fx1 fx2 fx3 fx4) + (assert-fixnum fx1 fx2 fx3 fx4) + (bitwise-copy-bit-field fx1 fx2 fx3 fx4)) + + (define (fxarithmetic-shift fx1 fx2) (assert-fixnum fx1 fx2) (ash fx1 fx2)) + (define fxarithmetic-shift-left fxarithmetic-shift) + + (define (fxarithmetic-shift-right fx1 fx2) + (assert-fixnum fx1 fx2) (ash fx2 (- fx2))) + + (define (fxrotate-bit-field fx1 fx2 fx3 fx4) + (assert-fixnum fx1 fx2 fx3 fx4) + (bitwise-rotate-bit-field fx1 fx2 fx3 fx4)) + + (define (fxreverse-bit-field fx1 fx2 fx3) + (assert-fixnum fx1 fx2 fx3) + (bitwise-reverse-bit-field fx1 fx2 fx3)) + +) diff --git a/module/rnrs/arithmetic/6/flonums.scm b/module/rnrs/arithmetic/6/flonums.scm new file mode 100644 index 000000000..4fadbd00a --- /dev/null +++ b/module/rnrs/arithmetic/6/flonums.scm @@ -0,0 +1,216 @@ +;;; flonums.scm --- The R6RS flonums arithmetic 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 flonums (6)) + (export flonum? + real->flonum + + fl=? fl<? fl<=? fl>? fl>=? + + flinteger? flzero? flpositive? flnegative? flodd? fleven? flfinite? + flinfinite? flnan? + + flmax flmin + + fl+ fl* fl- fl/ + + flabs + + fldiv-and-mod + fldiv + flmod + fldiv0-and-mod0 + fldiv0 + flmod0 + + flnumerator + fldenominator + + flfloor flceiling fltruncate flround + + flexp fllog flsin flcos fltan flacos flasin flatan + + flsqrt flexpt + + &no-infinities + make-no-infinities-violation + no-infinities-violation? + + &no-nans + make-no-nans-violation + no-nans-violation? + + fixnum->flonum) + (import (ice-9 optargs) + (only (guile) inf?) + (rnrs arithmetic fixnums (6)) + (rnrs base (6)) + (rnrs conditions (6)) + (rnrs exceptions (6)) + (rnrs lists (6)) + (rnrs r5rs (6))) + + (define (flonum? obj) (and (number? 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 (real->flonum x) + (or (real? x) (raise (make-assertion-violation))) + (exact->inexact x)) + + (define (fl=? . args) (apply assert-flonum args) (apply = args)) + (define (fl<? . args) (apply assert-flonum args) (apply < args)) + (define (fl<=? . args) (apply assert-flonum args) (apply <= args)) + (define (fl>? . args) (apply assert-flonum args) (apply > args)) + (define (fl>=? . args) (apply assert-flonum args) (apply >= args)) + + (define (flinteger? fl) (assert-flonum fl) (integer? fl)) + (define (flzero? fl) (assert-flonum fl) (zero? fl)) + (define (flpositive? fl) (assert-flonum fl) (positive? fl)) + (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 (flinfinite? fl) (assert-flonum fl) (inf? fl)) + (define (flnan? fl) (assert-flonum fl) (nan? fl)) + + (define (flmax fl1 . args) + (let ((flargs (cons fl1 args))) + (apply assert-flonum flargs) + (apply max flargs))) + + (define (flmin fl1 . args) + (let ((flargs (cons fl1 args))) + (apply assert-flonum flargs) + (apply min flargs))) + + (define (fl+ fl1 . args) + (let ((flargs (cons fl1 args))) + (apply assert-flonum flargs) + (apply + flargs))) + + (define (fl* fl1 . args) + (let ((flargs (cons fl1 args))) + (apply assert-flonum flargs) + (apply * flargs))) + + (define (fl- fl1 . args) + (let ((flargs (cons fl1 args))) + (apply assert-flonum flargs) + (apply - flargs))) + + (define (fl/ fl1 . args) + (let ((flargs (cons fl1 args))) + (apply assert-flonum flargs) + (apply / flargs))) + + (define (flabs fl) (assert-flonum fl) (abs fl)) + + (define (fldiv-and-mod fl1 fl2) + (assert-iflonum fl1 fl2) + (if (zero? fl2) (raise (make-assertion-violation))) + (let ((fx1 (inexact->exact fl1)) + (fx2 (inexact->exact fl2))) + (call-with-values (lambda () (div-and-mod fx1 fx2)) + (lambda (div mod) (values (exact->inexact div) + (exact->inexact mod)))))) + + (define (fldiv fl1 fl2) + (assert-iflonum fl1 fl2) + (if (zero? fl2) (raise (make-assertion-violation))) + (let ((fx1 (inexact->exact fl1)) + (fx2 (inexact->exact fl2))) + (exact->inexact (quotient fx1 fx2)))) + + (define (flmod fl1 fl2) + (assert-iflonum fl1 fl2) + (if (zero? fl2) (raise (make-assertion-violation))) + (let ((fx1 (inexact->exact fl1)) + (fx2 (inexact->exact fl2))) + (exact->inexact (modulo fx1 fx2)))) + + (define (fldiv0-and-mod0 fl1 fl2) + (assert-iflonum fl1 fl2) + (if (zero? fl2) (raise (make-assertion-violation))) + (let* ((fx1 (inexact->exact fl1)) + (fx2 (inexact->exact fl2))) + (call-with-values (lambda () (div0-and-mod0 fx1 fx2)) + (lambda (q r) (values (real->flonum q) (real->flonum r)))))) + + (define (fldiv0 fl1 fl2) + (call-with-values (lambda () (fldiv0-and-mod0 fl1 fl2)) (lambda (q r) q))) + + (define (flmod0 fl1 fl2) + (call-with-values (lambda () (fldiv0-and-mod0 fl1 fl2)) (lambda (q r) r))) + + (define (flnumerator fl) + (assert-flonum fl) + (case fl + ((+inf.0) +inf.0) + ((-inf.0) -inf.0) + (else (numerator fl)))) + + (define (fldenominator fl) + (assert-flonum fl) + (case fl + ((+inf.0) 1.0) + ((-inf.0) 1.0) + (else (denominator fl)))) + + (define (flfloor fl) (assert-flonum fl) (floor fl)) + (define (flceiling fl) (assert-flonum fl) (ceiling fl)) + (define (fltruncate fl) (assert-flonum fl) (truncate fl)) + (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 (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-condition-type &no-infinities + &implementation-restriction + make-no-infinities-violation + no-infinities-violation?) + + (define-condition-type &no-nans + &implementation-restriction + make-no-nans-violation + no-nans-violation?) + + (define (fixnum->flonum fx) + (or (fixnum? fx) (raise (make-assertion-violation))) + (exact->inexact fx)) +) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index cde33d42c..8892030c6 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -77,6 +77,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/r4rs.test \ tests/r5rs_pitfall.test \ tests/r6rs-arithmetic-bitwise.test \ + tests/r6rs-arithmetic-flonums.test \ tests/r6rs-conditions.test \ tests/r6rs-control.test \ tests/r6rs-enums.test \ diff --git a/test-suite/tests/r6rs-arithmetic-flonums.test b/test-suite/tests/r6rs-arithmetic-flonums.test new file mode 100644 index 000000000..873447be2 --- /dev/null +++ b/test-suite/tests/r6rs-arithmetic-flonums.test @@ -0,0 +1,310 @@ +;;; arithmetic-flonums.test --- Test suite for R6RS (rnrs arithmetic flonums) + +;; 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-flonums) + :use-module ((rnrs arithmetic flonums) :version (6)) + :use-module ((rnrs conditions) :version (6)) + :use-module ((rnrs exceptions) :version (6)) + :use-module (test-suite lib)) + +(define fake-pi 3.14159265) +(define (reasonably-close? x y) (< (abs (- x y)) 0.0000001)) + +(with-test-prefix "flonum?" + (pass-if "flonum? is #t on flonum" + (flonum? 1.5)) + + (pass-if "flonum? is #f on non-flonum" + (not (flonum? 3)))) + +(with-test-prefix "real->flonum" + (pass-if "simple" + (flonum? (real->flonum 3)))) + +(with-test-prefix "fl=?" + (pass-if "fl=? is #t for eqv inputs" + (fl=? 3.0 3.0 3.0)) + + (pass-if "fl=? is #f for non-eqv inputs" + (not (fl=? 1.5 0.0 3.0))) + + (pass-if "+inf.0 is fl= to itself" + (fl=? +inf.0 +inf.0)) + + (pass-if "0.0 and -0.0 are fl=" + (fl=? 0.0 -0.0))) + +(with-test-prefix "fl<?" + (pass-if "fl<? is #t for monotonically < inputs" + (fl<? 1.0 2.0 3.0)) + + (pass-if "fl<? is #f for non-monotonically < inputs" + (not (fl<? 2.0 2.0 1.4)))) + +(with-test-prefix "fl<=?" + (pass-if "fl<=? is #t for monotonically < or = inputs" + (fl<=? 1.0 1.2 1.2)) + + (pass-if "fl<=? is #f non-monotonically < or = inputs" + (not (fl<=? 2.0 1.0 0.9)))) + +(with-test-prefix "fl>?" + (pass-if "fl>? is #t for monotonically > inputs" + (fl>? 3.0 2.0 1.0)) + + (pass-if "fl>? is #f for non-monotonically > inputs" + (not (fl>? 1.0 1.0 1.2)))) + +(with-test-prefix "fl>=?" + (pass-if "fl>=? is #t for monotonically > or = inputs" + (fl>=? 3.0 2.0 2.0)) + + (pass-if "fl>=? is #f for non-monotonically > or = inputs" + (not (fl>=? 1.0 1.2 1.2)))) + +(with-test-prefix "flinteger?" + (pass-if "flinteger? is #t on integer flomnums" + (flinteger? 1.0)) + + (pass-if "flinteger? is #f on non-integer flonums" + (not (flinteger? 1.5)))) + +(with-test-prefix "flzero?" + (pass-if "flzero? is #t for 0.0 and -0.0" + (and (flzero? 0.0) (flzero? -0.0))) + + (pass-if "flzero? is #f for non-zero flonums" + (not (flzero? 1.0)))) + +(with-test-prefix "flpositive?" + (pass-if "flpositive? is #t on positive flonum" + (flpositive? 1.0)) + + (pass-if "flpositive? is #f on negative flonum" + (not (flpositive? -1.0))) + + (pass-if "0.0 and -0.0 are not flpositive" + (and (not (flpositive? 0.0)) (not (flpositive? -0.0))))) + +(with-test-prefix "flnegative?" + (pass-if "flnegative? is #t on negative flonum" + (flnegative? -1.0)) + + (pass-if "flnegative? is #f on positive flonum" + (not (flnegative? 1.0))) + + (pass-if "0.0 and -0.0 are not flnegative" + (and (not (flnegative? 0.0)) (not (flnegative? -0.0))))) + +(with-test-prefix "flodd?" + (pass-if "&assertion raised on non-integer flonum" + (guard (condition ((assertion-violation? condition) #t) (else #f)) + (begin (flodd? 1.5) #f))) + + (pass-if "flodd? is #t on odd flonums" + (flodd? 3.0)) + + (pass-if "flodd? is #f on even flonums" + (not (flodd? 2.0)))) + +(with-test-prefix "fleven?" + (pass-if "&assertion raised on non-integer flonum" + (guard (condition ((assertion-violation? condition) #t) (else #f)) + (begin (fleven? 1.5) #f))) + + (pass-if "fleven? is #t on even flonums" + (fleven? 2.0)) + + (pass-if "fleven? is #f on odd flonums" + (not (fleven? 3.0)))) + +(with-test-prefix "flfinite?" + (pass-if "flfinite? is #t on non-infinite flonums" + (flfinite? 2.0)) + + (pass-if "flfinite? is #f on infinities" + (and (not (flfinite? +inf.0)) (not (flfinite? -inf.0))))) + +(with-test-prefix "flinfinite?" + (pass-if "flinfinite? is #t on infinities" + (and (flinfinite? +inf.0) (flinfinite? -inf.0))) + + (pass-if "flinfinite? is #f on non-infinite flonums" + (not (flinfinite? 2.0)))) + +(with-test-prefix "flnan?" + (pass-if "flnan? is #t on NaN and -NaN" + (and (flnan? +nan.0) (flnan? -nan.0))) + + (pass-if "flnan? is #f on non-NaN values" + (not (flnan? 1.5)))) + +(with-test-prefix "flmax" + (pass-if "simple" (fl=? (flmax 1.0 3.0 2.0) 3.0))) + +(with-test-prefix "flmin" + (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))) + +(with-test-prefix "fl*" + (pass-if "simple" (fl=? (fl* 1.0 2.0 3.0 1.5) 9.0))) + +(with-test-prefix "fl-" + (pass-if "unary fl- negates argument" (fl=? (fl- 2.0) -2.0)) + + (pass-if "simple" (fl=? (fl- 10.5 6.0 0.5) 4.0))) + +(with-test-prefix "fl/" + (pass-if "unary fl/ returns multiplicative inverse" (fl=? (fl/ 10.0) 0.1)) + + (pass-if "simple" (fl=? (fl/ 10.0 2.0 2.0) 2.5))) + +(with-test-prefix "flabs" + (pass-if "simple" (and (fl=? (flabs -1.0) 1.0) (fl=? (flabs 1.23) 1.23)))) + +(with-test-prefix "fldiv-and-mod" + (pass-if "simple" + (call-with-values (lambda () (fldiv-and-mod 5.0 2.0)) + (lambda (div mod) (fl=? div 2.0) (fl=? mod 1.0))))) + +(with-test-prefix "fldiv" + (pass-if "simple" (fl=? (fldiv 5.0 2.0) 2.0))) + +(with-test-prefix "flmod" + (pass-if "simple" (fl=? (flmod 5.0 2.0) 1.0))) + +(with-test-prefix "fldiv0-and-mod0" + (pass-if "simple" + (call-with-values (lambda () (fldiv0-and-mod0 -123.0 10.0)) + (lambda (div mod) + (or (and (fl=? div -12.0) (fl=? mod -3.0)) + (throw 'unresolved)))))) + +(with-test-prefix "fldiv0" + (pass-if "simple" (or (fl=? (fldiv0 -123.0 10.0) -12.0) (throw 'unresolved)))) + +(with-test-prefix "flmod0" + (pass-if "simple" (or (fl=? (flmod0 -123.0 10.0) -3.0) (throw 'unresolved)))) + +(with-test-prefix "flnumerator" + (pass-if "simple" (fl=? (flnumerator 0.5) 1.0)) + + (pass-if "infinities" + (and (fl=? (flnumerator +inf.0) +inf.0) + (fl=? (flnumerator -inf.0) -inf.0))) + + (pass-if "negative zero" (fl=? (flnumerator -0.0) -0.0))) + +(with-test-prefix "fldenominator" + (pass-if "simple" (fl=? (fldenominator 0.5) 2.0)) + + (pass-if "infinities" + (and (fl=? (fldenominator +inf.0) 1.0) + (fl=? (fldenominator -inf.0) 1.0))) + + (pass-if "zero" (fl=? (fldenominator 0.0) 1.0))) + +(with-test-prefix "flfloor" + (pass-if "simple" + (and (fl=? (flfloor -4.3) -5.0) + (fl=? (flfloor 3.5) 3.0)))) + +(with-test-prefix "flceiling" + (pass-if "simple" + (and (fl=? (flceiling -4.3) -4.0) + (fl=? (flceiling 3.5) 4.0)))) + +(with-test-prefix "fltruncate" + (pass-if "simple" + (and (fl=? (fltruncate -4.3) -4.0) + (fl=? (fltruncate 3.5) 3.0)))) + +(with-test-prefix "flround" + (pass-if "simple" + (and (fl=? (flround -4.3) -4.0) + (fl=? (flround 3.5) 4.0)))) + +(with-test-prefix "flexp" + (pass-if "infinities" + (and (fl=? (flexp +inf.0) +inf.0) + (fl=? (flexp -inf.0) 0.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)))) + + (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 "binary fllog returns log in specified base" + (fl=? (fllog 8.0 2.0) 3.0))) + +(with-test-prefix "flsin" + (pass-if "simple" + (and (reasonably-close? (flsin (/ fake-pi 2)) 1.0) + (reasonably-close? (flsin (/ fake-pi 6)) 0.5)))) + +(with-test-prefix "flcos" + (pass-if "simple" + (and (fl=? (flcos 0.0) 1.0) (reasonably-close? (flcos (/ fake-pi 3)) 0.5)))) + +(with-test-prefix "fltan" + (pass-if "simple" + (and (reasonably-close? (fltan (/ fake-pi 4)) 1.0) + (reasonably-close? (fltan (/ (* 3 fake-pi) 4)) -1.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))))) + +(with-test-prefix "flacos" + (pass-if "simple" + (and (fl=? (flacos 1.0) 0.0) + (reasonably-close? (flacos 0.5) (/ fake-pi 3))))) + +(with-test-prefix "flatan" + (pass-if "unary flatan" + (and (reasonably-close? (flatan 1.0) (/ fake-pi 4)) + (reasonably-close? (flatan -1.0) (/ fake-pi -4)))) + + (pass-if "infinities" + (and (reasonably-close? (flatan -inf.0) -1.5707963267949) + (reasonably-close? (flatan +inf.0) 1.5707963267949))) + + (pass-if "binary flatan" + (and (reasonably-close? (flatan 3.5 3.5) (/ fake-pi 4))))) + +(with-test-prefix "flsqrt" + (pass-if "simple" (fl=? (flsqrt 4.0) 2.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 "fixnum->flonum" + (pass-if "simple" (fl=? (fixnum->flonum 100) 100.0))) |