1 ;;; flonums.scm --- The R6RS flonums arithmetic library
3 ;; Copyright (C) 2010 Free Software Foundation, Inc.
5 ;; This library is free software; you can redistribute it and/or
6 ;; modify it under the terms of the GNU Lesser General Public
7 ;; License as published by the Free Software Foundation; either
8 ;; version 3 of the License, or (at your option) any later version.
10 ;; This library is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;; Lesser General Public License for more details.
15 ;; You should have received a copy of the GNU Lesser General Public
16 ;; License along with this library; if not, write to the Free Software
17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
20 (library (rnrs arithmetic flonums (6))
24 fl=? fl<? fl<=? fl>? fl>=?
26 flinteger? flzero? flpositive? flnegative? flodd? fleven? flfinite?
45 flfloor flceiling fltruncate flround
47 flexp fllog flsin flcos fltan flacos flasin flatan
52 make-no-infinities-violation
53 no-infinities-violation?
56 make-no-nans-violation
60 (import (ice-9 optargs)
62 (rnrs arithmetic fixnums (6))
69 (define (flonum? obj) (and (number? obj) (inexact? obj)))
70 (define (assert-flonum . args)
71 (or (for-all flonum? args) (raise (make-assertion-violation))))
72 (define (assert-iflonum . args)
73 (or (for-all (lambda (i) (and (flonum? i) (integer? i))) args)
74 (raise (make-assertion-violation))))
76 (define (real->flonum x)
77 (or (real? x) (raise (make-assertion-violation)))
80 (define (fl=? . args) (apply assert-flonum args) (apply = args))
81 (define (fl<? . args) (apply assert-flonum args) (apply < args))
82 (define (fl<=? . args) (apply assert-flonum args) (apply <= args))
83 (define (fl>? . args) (apply assert-flonum args) (apply > args))
84 (define (fl>=? . args) (apply assert-flonum args) (apply >= args))
86 (define (flinteger? fl) (assert-flonum fl) (integer? fl))
87 (define (flzero? fl) (assert-flonum fl) (zero? fl))
88 (define (flpositive? fl) (assert-flonum fl) (positive? fl))
89 (define (flnegative? fl) (assert-flonum fl) (negative? fl))
90 (define (flodd? ifl) (assert-iflonum ifl) (odd? ifl))
91 (define (fleven? ifl) (assert-iflonum ifl) (even? ifl))
92 (define (flfinite? fl) (assert-flonum fl) (not (inf? fl)))
93 (define (flinfinite? fl) (assert-flonum fl) (inf? fl))
94 (define (flnan? fl) (assert-flonum fl) (nan? fl))
96 (define (flmax fl1 . args)
97 (let ((flargs (cons fl1 args)))
98 (apply assert-flonum flargs)
101 (define (flmin fl1 . args)
102 (let ((flargs (cons fl1 args)))
103 (apply assert-flonum flargs)
106 (define (fl+ fl1 . args)
107 (let ((flargs (cons fl1 args)))
108 (apply assert-flonum flargs)
111 (define (fl* fl1 . args)
112 (let ((flargs (cons fl1 args)))
113 (apply assert-flonum flargs)
116 (define (fl- fl1 . args)
117 (let ((flargs (cons fl1 args)))
118 (apply assert-flonum flargs)
121 (define (fl/ fl1 . args)
122 (let ((flargs (cons fl1 args)))
123 (apply assert-flonum flargs)
126 (define (flabs fl) (assert-flonum fl) (abs fl))
128 (define (fldiv-and-mod fl1 fl2)
129 (assert-iflonum fl1 fl2)
130 (if (zero? fl2) (raise (make-assertion-violation)))
131 (let ((fx1 (inexact->exact fl1))
132 (fx2 (inexact->exact fl2)))
133 (call-with-values (lambda () (div-and-mod fx1 fx2))
134 (lambda (div mod) (values (exact->inexact div)
135 (exact->inexact mod))))))
137 (define (fldiv fl1 fl2)
138 (assert-iflonum fl1 fl2)
139 (if (zero? fl2) (raise (make-assertion-violation)))
140 (let ((fx1 (inexact->exact fl1))
141 (fx2 (inexact->exact fl2)))
142 (exact->inexact (quotient fx1 fx2))))
144 (define (flmod fl1 fl2)
145 (assert-iflonum fl1 fl2)
146 (if (zero? fl2) (raise (make-assertion-violation)))
147 (let ((fx1 (inexact->exact fl1))
148 (fx2 (inexact->exact fl2)))
149 (exact->inexact (modulo fx1 fx2))))
151 (define (fldiv0-and-mod0 fl1 fl2)
152 (assert-iflonum fl1 fl2)
153 (if (zero? fl2) (raise (make-assertion-violation)))
154 (let* ((fx1 (inexact->exact fl1))
155 (fx2 (inexact->exact fl2)))
156 (call-with-values (lambda () (div0-and-mod0 fx1 fx2))
157 (lambda (q r) (values (real->flonum q) (real->flonum r))))))
159 (define (fldiv0 fl1 fl2)
160 (call-with-values (lambda () (fldiv0-and-mod0 fl1 fl2)) (lambda (q r) q)))
162 (define (flmod0 fl1 fl2)
163 (call-with-values (lambda () (fldiv0-and-mod0 fl1 fl2)) (lambda (q r) r)))
165 (define (flnumerator fl)
170 (else (numerator fl))))
172 (define (fldenominator fl)
177 (else (denominator fl))))
179 (define (flfloor fl) (assert-flonum fl) (floor fl))
180 (define (flceiling fl) (assert-flonum fl) (ceiling fl))
181 (define (fltruncate fl) (assert-flonum fl) (truncate fl))
182 (define (flround fl) (assert-flonum fl) (round fl))
184 (define (flexp fl) (assert-flonum fl) (exp fl))
185 (define* (fllog fl #:optional fl2)
187 (cond ((fl=? fl -inf.0) +nan.0)
188 (fl2 (begin (assert-flonum fl2) (/ (log fl) (log fl2))))
191 (define (flsin fl) (assert-flonum fl) (sin fl))
192 (define (flcos fl) (assert-flonum fl) (cos fl))
193 (define (fltan fl) (assert-flonum fl) (tan fl))
194 (define (flasin fl) (assert-flonum fl) (asin fl))
195 (define (flacos fl) (assert-flonum fl) (acos fl))
196 (define* (flatan fl #:optional fl2)
198 (if fl2 (begin (assert-flonum fl2) (atan fl fl2)) (atan fl)))
200 (define (flsqrt fl) (assert-flonum fl) (sqrt fl))
201 (define (flexpt fl1 fl2) (assert-flonum fl1 fl2) (expt fl1 fl2))
203 (define-condition-type &no-infinities
204 &implementation-restriction
205 make-no-infinities-violation
206 no-infinities-violation?)
208 (define-condition-type &no-nans
209 &implementation-restriction
210 make-no-nans-violation
213 (define (fixnum->flonum fx)
214 (or (fixnum? fx) (raise (make-assertion-violation)))