Commit | Line | Data |
---|---|---|
b01818d7 JG |
1 | ;;; flonums.scm --- The R6RS flonums arithmetic library |
2 | ||
ff62c168 | 3 | ;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. |
b01818d7 JG |
4 | ;; |
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. | |
9 | ;; | |
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. | |
14 | ;; | |
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 | |
18 | \f | |
19 | ||
20 | (library (rnrs arithmetic flonums (6)) | |
21 | (export flonum? | |
22 | real->flonum | |
23 | ||
24 | fl=? fl<? fl<=? fl>? fl>=? | |
25 | ||
26 | flinteger? flzero? flpositive? flnegative? flodd? fleven? flfinite? | |
27 | flinfinite? flnan? | |
28 | ||
29 | flmax flmin | |
30 | ||
31 | fl+ fl* fl- fl/ | |
32 | ||
33 | flabs | |
34 | ||
35 | fldiv-and-mod | |
36 | fldiv | |
37 | flmod | |
38 | fldiv0-and-mod0 | |
39 | fldiv0 | |
40 | flmod0 | |
41 | ||
42 | flnumerator | |
43 | fldenominator | |
44 | ||
45 | flfloor flceiling fltruncate flround | |
46 | ||
47 | flexp fllog flsin flcos fltan flacos flasin flatan | |
48 | ||
49 | flsqrt flexpt | |
50 | ||
51 | &no-infinities | |
52 | make-no-infinities-violation | |
53 | no-infinities-violation? | |
54 | ||
55 | &no-nans | |
56 | make-no-nans-violation | |
57 | no-nans-violation? | |
58 | ||
59 | fixnum->flonum) | |
60 | (import (ice-9 optargs) | |
61 | (only (guile) inf?) | |
62 | (rnrs arithmetic fixnums (6)) | |
63 | (rnrs base (6)) | |
64 | (rnrs conditions (6)) | |
65 | (rnrs exceptions (6)) | |
66 | (rnrs lists (6)) | |
67 | (rnrs r5rs (6))) | |
68 | ||
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)))) | |
75 | ||
76 | (define (real->flonum x) | |
77 | (or (real? x) (raise (make-assertion-violation))) | |
78 | (exact->inexact x)) | |
79 | ||
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)) | |
85 | ||
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)) | |
95 | ||
96 | (define (flmax fl1 . args) | |
97 | (let ((flargs (cons fl1 args))) | |
98 | (apply assert-flonum flargs) | |
99 | (apply max flargs))) | |
100 | ||
101 | (define (flmin fl1 . args) | |
102 | (let ((flargs (cons fl1 args))) | |
103 | (apply assert-flonum flargs) | |
104 | (apply min flargs))) | |
105 | ||
106 | (define (fl+ fl1 . args) | |
107 | (let ((flargs (cons fl1 args))) | |
108 | (apply assert-flonum flargs) | |
109 | (apply + flargs))) | |
110 | ||
111 | (define (fl* fl1 . args) | |
112 | (let ((flargs (cons fl1 args))) | |
113 | (apply assert-flonum flargs) | |
114 | (apply * flargs))) | |
115 | ||
116 | (define (fl- fl1 . args) | |
117 | (let ((flargs (cons fl1 args))) | |
118 | (apply assert-flonum flargs) | |
119 | (apply - flargs))) | |
120 | ||
121 | (define (fl/ fl1 . args) | |
122 | (let ((flargs (cons fl1 args))) | |
123 | (apply assert-flonum flargs) | |
124 | (apply / flargs))) | |
125 | ||
126 | (define (flabs fl) (assert-flonum fl) (abs fl)) | |
127 | ||
128 | (define (fldiv-and-mod fl1 fl2) | |
129 | (assert-iflonum fl1 fl2) | |
ff62c168 | 130 | (div-and-mod fl1 fl2)) |
b01818d7 JG |
131 | |
132 | (define (fldiv fl1 fl2) | |
133 | (assert-iflonum fl1 fl2) | |
ff62c168 | 134 | (div fl1 fl2)) |
b01818d7 JG |
135 | |
136 | (define (flmod fl1 fl2) | |
137 | (assert-iflonum fl1 fl2) | |
ff62c168 | 138 | (mod fl1 fl2)) |
b01818d7 JG |
139 | |
140 | (define (fldiv0-and-mod0 fl1 fl2) | |
141 | (assert-iflonum fl1 fl2) | |
ff62c168 | 142 | (div0-and-mod0 fl1 fl2)) |
b01818d7 JG |
143 | |
144 | (define (fldiv0 fl1 fl2) | |
ff62c168 MW |
145 | (assert-iflonum fl1 fl2) |
146 | (div0 fl1 fl2)) | |
b01818d7 JG |
147 | |
148 | (define (flmod0 fl1 fl2) | |
ff62c168 MW |
149 | (assert-iflonum fl1 fl2) |
150 | (mod0 fl1 fl2)) | |
b01818d7 JG |
151 | |
152 | (define (flnumerator fl) | |
153 | (assert-flonum fl) | |
154 | (case fl | |
155 | ((+inf.0) +inf.0) | |
156 | ((-inf.0) -inf.0) | |
157 | (else (numerator fl)))) | |
158 | ||
159 | (define (fldenominator fl) | |
160 | (assert-flonum fl) | |
161 | (case fl | |
162 | ((+inf.0) 1.0) | |
163 | ((-inf.0) 1.0) | |
164 | (else (denominator fl)))) | |
165 | ||
166 | (define (flfloor fl) (assert-flonum fl) (floor fl)) | |
167 | (define (flceiling fl) (assert-flonum fl) (ceiling fl)) | |
168 | (define (fltruncate fl) (assert-flonum fl) (truncate fl)) | |
169 | (define (flround fl) (assert-flonum fl) (round fl)) | |
170 | ||
171 | (define (flexp fl) (assert-flonum fl) (exp fl)) | |
172 | (define* (fllog fl #:optional fl2) | |
173 | (assert-flonum fl) | |
174 | (cond ((fl=? fl -inf.0) +nan.0) | |
175 | (fl2 (begin (assert-flonum fl2) (/ (log fl) (log fl2)))) | |
176 | (else (log fl)))) | |
177 | ||
178 | (define (flsin fl) (assert-flonum fl) (sin fl)) | |
179 | (define (flcos fl) (assert-flonum fl) (cos fl)) | |
180 | (define (fltan fl) (assert-flonum fl) (tan fl)) | |
181 | (define (flasin fl) (assert-flonum fl) (asin fl)) | |
182 | (define (flacos fl) (assert-flonum fl) (acos fl)) | |
183 | (define* (flatan fl #:optional fl2) | |
184 | (assert-flonum fl) | |
185 | (if fl2 (begin (assert-flonum fl2) (atan fl fl2)) (atan fl))) | |
186 | ||
187 | (define (flsqrt fl) (assert-flonum fl) (sqrt fl)) | |
188 | (define (flexpt fl1 fl2) (assert-flonum fl1 fl2) (expt fl1 fl2)) | |
189 | ||
190 | (define-condition-type &no-infinities | |
191 | &implementation-restriction | |
192 | make-no-infinities-violation | |
193 | no-infinities-violation?) | |
194 | ||
195 | (define-condition-type &no-nans | |
196 | &implementation-restriction | |
197 | make-no-nans-violation | |
198 | no-nans-violation?) | |
199 | ||
200 | (define (fixnum->flonum fx) | |
201 | (or (fixnum? fx) (raise (make-assertion-violation))) | |
202 | (exact->inexact fx)) | |
203 | ) |