summaryrefslogtreecommitdiff
path: root/module/rnrs/arithmetic/flonums.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/rnrs/arithmetic/flonums.scm')
-rw-r--r--module/rnrs/arithmetic/flonums.scm203
1 files changed, 203 insertions, 0 deletions
diff --git a/module/rnrs/arithmetic/flonums.scm b/module/rnrs/arithmetic/flonums.scm
new file mode 100644
index 000000000..e3f3ce714
--- /dev/null
+++ b/module/rnrs/arithmetic/flonums.scm
@@ -0,0 +1,203 @@
+;;; flonums.scm --- The R6RS flonums arithmetic library
+
+;; Copyright (C) 2010, 2011, 2013 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 control (6))
+ (rnrs conditions (6))
+ (rnrs exceptions (6))
+ (rnrs lists (6))
+ (rnrs r5rs (6)))
+
+ (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 (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 (or (inf? fl) (nan? 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+ . args)
+ (apply assert-flonum args)
+ (if (null? args) 0.0 (apply + args)))
+
+ (define (fl* . args)
+ (apply assert-flonum args)
+ (if (null? args) 1.0 (apply * args)))
+
+ (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)
+ (div-and-mod fl1 fl2))
+
+ (define (fldiv fl1 fl2)
+ (assert-iflonum fl1 fl2)
+ (div fl1 fl2))
+
+ (define (flmod fl1 fl2)
+ (assert-iflonum fl1 fl2)
+ (mod fl1 fl2))
+
+ (define (fldiv0-and-mod0 fl1 fl2)
+ (assert-iflonum fl1 fl2)
+ (div0-and-mod0 fl1 fl2))
+
+ (define (fldiv0 fl1 fl2)
+ (assert-iflonum fl1 fl2)
+ (div0 fl1 fl2))
+
+ (define (flmod0 fl1 fl2)
+ (assert-iflonum fl1 fl2)
+ (mod0 fl1 fl2))
+
+ (define (flnumerator fl) (assert-flonum fl) (numerator fl))
+ (define (fldenominator fl) (assert-flonum fl) (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
+ (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) (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
+ 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))
+)