mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-07-01 15:20:34 +02:00
Implementation and test cases for the R6RS (rnrs arithmetic flonums)
library. * module/Makefile.am: Add rnrs/arithmetic/6/fixnums.scm and rnrs/arithmetic/6/flonums.scm to RNRS_SOURCES. * module/rnrs/6/base.scm: (div-and-mod, div0, mod0, div0-and-mod0): New functions; this `div' implementation is not quite right, but we'll come back to it later. * module/rnrs/arithmetic/6/fixnums.scm: New file. * module/rnrs/arithmetic/6/flonums.scm: New file. * test-suite/Makefile.am: Add tests/r6rs-arithmetic-flonums.test to SCM_TESTS. * test-suite/tests/r6rs-arithmetic-flonums.test: New file.
This commit is contained in:
Julian Graham
parent
15ce5cafbc
commit
b01818d752
6 changed files with 803 additions and 2 deletions
|
|
@ -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 \
|
||||
|
|
|
|||
|
|
@ -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)))))))
|
||||
|
||||
)
|
||||
|
|
|
|||
255
module/rnrs/arithmetic/6/fixnums.scm
Normal file
255
module/rnrs/arithmetic/6/fixnums.scm
Normal file
|
|
@ -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))
|
||||
|
||||
)
|
||||
216
module/rnrs/arithmetic/6/flonums.scm
Normal file
216
module/rnrs/arithmetic/6/flonums.scm
Normal file
|
|
@ -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))
|
||||
)
|
||||
|
|
@ -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 \
|
||||
|
|
|
|||
310
test-suite/tests/r6rs-arithmetic-flonums.test
Normal file
310
test-suite/tests/r6rs-arithmetic-flonums.test
Normal file
|
|
@ -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)))
|
||||
Loading…
Add table
Add a link
Reference in a new issue