[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, wip-r6rs-libraries, updated. release_1
|
From: |
Julian Graham |
|
Subject: |
[Guile-commits] GNU Guile branch, wip-r6rs-libraries, updated. release_1-9-8-97-ge915f7a |
|
Date: |
Sun, 04 Apr 2010 03:05:57 +0000 |
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=e915f7a5bd91d93b5b2a296cdf4355d31fd126b2
The branch, wip-r6rs-libraries has been updated
via e915f7a5bd91d93b5b2a296cdf4355d31fd126b2 (commit)
via d976caaa6b3d240869c83076dd350ca2442907eb (commit)
from bd8f6ea27b3165835159ee7d497d9ba21b5373f8 (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 e915f7a5bd91d93b5b2a296cdf4355d31fd126b2
Author: Julian Graham <address@hidden>
Date: Sat Apr 3 23:05:46 2010 -0400
Fix typo in license comment.
* test-suite/tests/r6rs-eval.test: Lice6nse => License.
commit d976caaa6b3d240869c83076dd350ca2442907eb
Author: Julian Graham <address@hidden>
Date: Sat Apr 3 23:04:24 2010 -0400
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.
-----------------------------------------------------------------------
Summary of changes:
module/Makefile.am | 2 +
module/rnrs/6/base.scm | 21 ++-
module/rnrs/arithmetic/6/fixnums.scm | 255 ++++++++++++++++++++
module/rnrs/arithmetic/6/flonums.scm | 216 +++++++++++++++++
test-suite/Makefile.am | 1 +
test-suite/tests/r6rs-arithmetic-flonums.test | 310 +++++++++++++++++++++++++
test-suite/tests/r6rs-eval.test | 2 +-
7 files changed, 804 insertions(+), 3 deletions(-)
create mode 100644 module/rnrs/arithmetic/6/fixnums.scm
create mode 100644 module/rnrs/arithmetic/6/flonums.scm
create mode 100644 test-suite/tests/r6rs-arithmetic-flonums.test
diff --git a/module/Makefile.am b/module/Makefile.am
index 6271c13..6a9a34d 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 e7f52c4..4358aa4 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 0000000..2c8b716
--- /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 0000000..4fadbd0
--- /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 849b004..f443a2d 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-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 0000000..873447b
--- /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)))
diff --git a/test-suite/tests/r6rs-eval.test b/test-suite/tests/r6rs-eval.test
index cfc4b6b..30a2e00 100644
--- a/test-suite/tests/r6rs-eval.test
+++ b/test-suite/tests/r6rs-eval.test
@@ -5,7 +5,7 @@
;; 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 Lice6nse, or (at your option) any later version.
+;; 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
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, wip-r6rs-libraries, updated. release_1-9-8-97-ge915f7a,
Julian Graham <=