source: project/release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-flonums.scm @ 14008

Last change on this file since 14008 was 14008, checked in by Kon Lovett, 11 years ago

Save.

File size: 17.7 KB
Line 
1;;;; err5rs-arithmetic-flonums.scm
2;;;; Kon Lovett, Mar '09
3
4;; Issues
5;;
6;; - No support for the full-numeric-tower. All operations upon core numerics.
7
8;;; Prelude
9
10(declare
11        (usual-integrations)
12  (disable-interrupts)
13        (inline)
14        (local)
15        (no-procedure-checks)
16        (bound-to-procedure
17          ##sys#check-exact
18          ##sys#check-inexact
19          ##sys#check-integer
20          ##sys#signal-hook ) )
21
22;;
23
24(include "chicken-primitive-object-inlines")
25
26;;
27
28(cond-expand
29  (unsafe
30
31    (define-inline (%check-fixnum loc obj) #t)
32
33    (define-inline (%check-flonum loc obj) #t)
34
35    #;(define-inline (%check-positive-integer loc obj) #t)
36
37    (define-inline (%check-positive loc obj) #t)
38
39    (define-inline (%check-real loc obj) #t) )
40
41  (else
42
43    (define-inline (%check-fixnum loc obj)
44      (unless (%fixnum? obj) (error-type-fixnum loc obj)) )
45
46    (define-inline (%check-flonum loc obj)
47      (unless (%flonum? obj) (error-type-flonum loc obj)) )
48
49    #;(define-inline (%check-positive-integer loc obj)
50      (unless (and (%integer? obj) (%positive? obj)) (error-type-positive-integer loc obj)) )
51
52    (define-inline (%check-positive loc obj)
53      (unless (and (%number? obj) (%positive? obj)) (error-type-positive loc obj)) )
54
55    (define-inline (%check-real loc obj)
56      (unless (real? obj) (error-type-real loc obj)) ) ) )
57
58;;
59
60;Note - argument order is (func acc cur) & not (func cur acc) as in (fold func).
61
62(define-inline (%fpfold loc func init lyst)
63  (%check-flonum loc init)
64  (let loop ((ls lyst) (acc init))
65          (if (%null? ls) acc
66              (let ((cur (%car ls)))
67          (%check-flonum loc cur)
68          (loop (%cdr ls) (func acc cur)) ) ) ) )
69
70(define-inline (%fpand-fold loc func init lyst)
71  (%check-flonum loc init)
72  (let loop ((ls lyst) (acc init))
73          (or (%null? ls)
74        (let ((cur (%car ls)))
75          (%check-flonum loc cur)
76                (and (func acc cur)
77               (loop (%cdr ls) cur) ) ) ) ) )
78
79;;
80
81(define-inline (%fpnegzero? fp) (and (%fp=? -0.0 fp) (signbit fp)))
82
83(define-inline (%fpzero? fp) (or #;(%fpnegzero? fp) (%fp= 0.0 fp)))
84
85(define-inline (%fpdiv fpn fpd) (%fptruncate (%fp/ fpn fpd)))
86
87(define-inline (%fpmod fpn fpd) (%fp- fpn (%fp* (%fpdiv fpn fpd) fpd)))
88
89(define-inline (%fpdiv-and-mod  fpn fpd)
90  (let ((quo (%fpdiv fpn fpd)))
91    (values quo (%fp- fpn (%fp* quo fpd))) ) )
92
93(define-inline (%fpinteger? obj) (and (%flonum? obj) (%integer? obj)))
94
95(define-inline (%fpnan? fp) (not (%fp= fp fp)))
96
97(define-inline (%fp=? x y) (%fp= x y)) ;unnecessary but symmetrical
98
99(define-inline (%fp<? x y)
100  (and (not (and (%fp= 0.0 x) (%fpnegzero? y)))
101       (or (and (%fpnegzero? x) (%fp= 0.0 y))
102           (%fp< x y) ) ) )
103
104(define-inline (%fp<=? x y)
105  (and (not (and (%fp= 0.0 x) (%fpnegzero? y)))
106       (or (and (%fpnegzero? x) (%fp= 0.0 y))
107           (%fp<= x y) ) ) )
108
109(define-inline (%fp>? x y)
110  (and (not (and (%fpnegzero? x) (%fp= 0.0 y)))
111       (or (and (%fp= 0.0 x) (%fpnegzero? y))
112           (%fp> x y) ) ) )
113
114(define-inline (%fp>=? x y)
115  (and (not (and (%fpnegzero? x) (%fp= 0.0 y)))
116       (or (and (%fp= 0.0 x) (%fpnegzero? y))
117           (%fp>= x y) ) ) )
118
119(define-inline (%fpdiv0-and-mod0 fpn fpd)
120  (let-values (((quo rem) (%fpdiv-and-mod  fpn fpd)))
121    (cond ((%fp<=? 0.0 fpd)
122           (if (%fp<? rem (%fp/ fpd 2.0))
123               (if (%fp<=? (%fp/ fpd -2.0) rem) (values quo rem)
124                   (values (%fp- quo 1.0) (%fp+ rem fpd)) )
125               (values (%fp+ quo 1.0) (%fp- rem fpd)) ) )
126          ((%fp<? rem (%fp/ fpd -2.0))
127           (if (%fp<=? (%fp/ fpd 2.0) rem) (values quo rem)
128               (values (%fp+ quo 1.0) (%fp- rem fpd)) ) )
129          (else
130           (values (%fp- quo 1.0) (%fp+ rem fpd)) ) ) ) )
131
132(define-inline (%fpdiv0 fpn fpd)
133  (let-values (((quo rem) (%fpdiv-and-mod  fpn fpd)))
134    (cond ((%fp<=? 0.0 fpd)
135           (if (%fp<? rem (%fp/ fpd 2.0))
136               (if (%fp<=? (%fp/ fpd -2.0) rem) quo
137                   (%fp- quo 1.0) )
138               (%fp+ quo 1.0) ) )
139          ((%fp<? rem (%fp/ fpd -2.0))
140           (if (%fp<=? (%fp/ fpd 2.0) rem) quo
141               (%fp+ quo 1.0) ) )
142          (else
143           (%fp- quo 1.0) ) ) ) )
144
145(define-inline (%fpmod0 fpn fpd)
146  (let ((rem (%fpmod fpn fpd)))
147    (cond ((%fp<=? 0.0 fpd)
148           (if (%fp<? rem (%fp/ fpd 2.0))
149               (if (%fp<=? (%fp/ fpd -2.0) rem) rem
150                   (%fp+ rem fpd) )
151               (%fp- rem fpd) ) )
152          ((%fp<? rem (%fp/ fpd -2.0))
153           (if (%fp<=? (%fp/ fpd 2.0) rem) rem
154               (%fp- rem fpd) ))
155          (else
156           (%fp+ rem fpd) ) ) ) )
157
158;;;
159
160(module err5rs-arithmetic-flonums (;export
161  ; ERR5RS
162  #;no-infinities-violation? #;make-no-infinities-violation
163  #;no-nans-violation? #;make-no-nans-violation
164  real->flonum fixnum->flonum
165  fl=? fl<? fl>? fl<=? fl>=?
166  flinteger?
167  flzero? flpositive? flnegative? flodd? fleven?
168  flfinite? flinfinite? flnan?
169  fl+ fl* fl- fl/
170  flmax flmin flmax-and-min
171  flabs
172  flfloor flceiling flround fltruncate
173  fldiv flmod fldiv-and-mod fldiv0 flmod0 fldiv0-and-mod0
174  flexp fllog flsin flcos fltan flasin flacos flatan flsqrt flexpt
175  flnumerator fldenominator
176  ; Extras
177  flgcd
178  flonum->fraction
179  fl<>?
180  flcompare
181  flfraction
182  flnegate
183  ; Macros
184  *fl=? *fl<? *fl>? *fl<=? *fl>=? *fl<>?
185  *flmax *flmin
186  *fl- *fl+ *fl* *fl/
187  ; Macro helpers
188  $fp=? $fp<? $fp>? $fp>=? $fp<=? $fp<>?
189  $fpmax $fpmin
190  $fp+ $fp- $fp* $fp/)
191
192(import scheme chicken foreign srfi-1 mathh)
193
194(require-library srfi-1 mathh)
195
196;;; Errors
197
198(cond-expand
199  (unsafe)
200  (else
201
202    (define (error-type-fixnum loc obj)
203      (##sys#signal-hook #:type-error loc "bad argument type - not a fixnum" obj) )
204
205    (define (error-type-flonum loc obj)
206      (##sys#signal-hook #:type-error loc "bad argument type - not a flonum" obj) )
207
208    (define (error-type-real loc obj)
209      (##sys#signal-hook #:type-error loc "bad argument type - not a real" obj) )
210
211    (define (error-type-positive loc obj)
212      (##sys#signal-hook #:type-error loc "bad argument type - not a positive number" obj) ) ) )
213
214;;; Procedures wrapping primitive-inlines for fold operations
215
216(define ($fp=? x y) (%fp=? x y))
217(define ($fp<? x y) (%fp<? x y))
218(define ($fp>? x y) (%fp>? x y))
219(define ($fp<=? x y) (%fp<=? x y))
220(define ($fp>=? x y) (%fp>=? x y))
221(define ($fp<>? x y) (not (%fp=? x y)))
222(define ($fpmax x y) (%fpmax x y))
223(define ($fpmin x y) (%fpmin x y))
224(define ($fp- x y) (%fp- x y))
225(define ($fp+ x y) (%fp+ x y))
226(define ($fp* x y) (%fp* x y))
227(define ($fp/ x y) (%fp/ x y))
228
229;;;
230
231(define maximum-integer-flonum (expt 10.0 flonum-maximum-decimal-exponent)) ;1.0e14
232(define small-epsilon flonum-epsilon) ;5.0e-15
233(define large-epsilon (%fp* small-epsilon 10.0))
234#;(define digits-limit 1.0e12)
235
236(define (*fpgcd fp1 fp2 #!optional (cnvrg-limit 50))
237  (let ((fp1 (%fpabs fp1))
238        (fp2 (%fpabs fp2)) )
239    (let* ((dividend (%fpmax fp1 fp2))
240           (divisor (%fpmin fp1 fp2))
241           (dividend-epsilon (%fp* dividend large-epsilon))
242           (divisor-epsilon (%fp* dividend-epsilon 100.0)) )
243           ; Too small?
244     (cond ((or (%fp<= divisor dividend-epsilon) (%fp<= maximum-integer-flonum dividend))
245            0.0 )
246           (else
247            (let loop ((cnvrg 1) (dividend dividend) (divisor divisor))
248              (let ((remainder (%fpabs (%fpmod dividend divisor))))
249                      ; Not converging?
250                (cond ((%fx= cnvrg cnvrg-limit)
251                       0.0 )
252                      ; Converged, maybe?
253                      ((or (%fp<= remainder dividend-epsilon)
254                           (%fp<= (%fpabs (%fp- divisor remainder)) dividend-epsilon))
255                           ; No it hasn't
256                       (if (and (not (%fpzero? remainder))
257                                (%fp<= divisor divisor-epsilon)) 0.0
258                           divisor ) )
259                      ; Narrow
260                      (else
261                       (loop (%fxadd1 cnvrg) divisor remainder) ) ) ) ) ) ) ) ) )
262
263(define (*fp->fraction fp)
264  (let ((numerator-epsilon (%fp* (%fpabs fp) small-epsilon))
265        (numerator (%fpround fp)) )
266        ; Close to an integer?
267    (if (and (not (%fpzero? numerator))
268             (%fp<= (%fpabs (%fp- numerator fp)) numerator-epsilon)) (values numerator 1.0)
269        (let* ((divisor (*fpgcd fp 1.0))
270               (numerator (%fpround (%fp/ fp divisor)))
271               (denominator (%fpround (%fp/ 1.0 divisor))) )
272                ; Too many digits?
273          (cond #; ;No clipping
274                ((or (%fp<= digits-limit (%fpabs numerator))
275                     (%fp<= digits-limit (%fpabs denominator)))
276                 (values +nan +nan) )
277                ; Absurd denominator?
278                #; ;Ignore
279                ((%fp< denominator 2.0)
280                 (values +nan +nan) )
281                (else
282                 (let ((divisor (*fpgcd numerator denominator)))
283                       ; Fully reduced?
284                   (if (%fp< 1.0 divisor)
285                       ; Whaaat!
286                       (values (%fp/ numerator divisor) (%fp/ denominator divisor))
287                       ; Yes!
288                       (values numerator denominator)
289                       #; ;Ignore
290                       (let* ((check (%fp/ numerator denominator))
291                              (check-epsilon (%fp* (%fpabs check) small-epsilon)))
292                             ; Inaccurate?
293                         (if (%< check-epsilon (%fpabs (%fp- check fp))) (values +nan +nan)
294                             ; Accurate!
295                             (values numerator denominator) ) ) ) ) ) ) ) ) ) )
296
297;;; ERR5RS
298
299;; We can represent NaN & Inf
300
301;;(define (make-no-infinities-violation) )
302;;(define (no-infinities-violation? obj) )
303;;(define (make-no-nans-violation) )
304;;(define (no-nans-violation? obj) )
305
306;;
307
308(define (real->flonum value)
309  (cond ((%flonum? value) value)
310        (else
311         (%check-real 'real->flonum value)
312         (%exact->inexact value) ) ) )
313
314(define (fixnum->flonum fx)
315  (%check-fixnum 'fixnum->flonum fx)
316  (%exact->inexact fx) )
317
318;;
319
320(define (fl=? fp . fps) (%fpand-fold 'fl=? $fp=? fp fps))
321(define (fl<? fp . fps) (%fpand-fold 'fl<? $fp<? fp fps))
322(define (fl>? fp . fps) (%fpand-fold 'fl>? $fp>? fp fps))
323(define (fl<=? fp . fps) (%fpand-fold 'fl<=? $fp<=? fp fps))
324(define (fl>=? fp . fps) (%fpand-fold 'fl>=? $fp>=? fp fps))
325
326;;
327
328(define (flmax fp . fps) (%fpfold 'flmax $fpmax fp fps))
329(define (flmin fp . fps) (%fpfold 'flmin $fpmin fp fps))
330
331(define (flmax-and-min fp . fps)
332  (%check-flonum 'flmax-and-min fp)
333        (let loop ((ls fps) (mx fp) (mn fp))
334          (if (%null? ls) (values mx mn)
335              (let ((cur (%car ls)))
336                (%check-flonum 'flmax-and-min cur)
337          (loop (%cdr ls) (%fpmax mx cur) (%fpmin mn cur)) ) ) ) )
338
339;;
340
341(define (flinteger? fp)
342  (%check-flonum 'flinteger? fp)
343  (%fpinteger? fp) )
344
345(define (flzero? fp)
346  (%check-flonum 'flzero? fp)
347        (%fpzero? fp) )
348
349(define (flpositive? fp)
350  (%check-flonum 'flpositive? fp)
351  (and (not (signbit fp))
352       (not (%fpzero? fp)) ) )
353
354(define (flnegative? fp)
355  (%check-flonum 'flnegative? fp)
356        (signbit fp) )
357
358(define (flodd? fp)
359  (%check-flonum 'flodd? fp)
360  (not (%fp=? 0.0 (%fpmod fp 2.0))) )
361
362(define (fleven? fp)
363  (%check-flonum 'fleven? fp)
364  (%fp=? 0.0 (%fpmod fp 2.0)) )
365
366(define (flfinite? fp)
367  (%check-flonum 'flfinite? fp)
368  (and (not (%fpnan? fp)) (%finite? fp)) )
369
370(define (flinfinite? fp)
371  (%check-flonum 'flinfinite? fp)
372  (not (%finite? fp)) )
373
374(define (flnan? fp)
375  (%check-flonum 'flnan? fp)
376  (%fpnan? fp) )
377
378;;
379
380(define (fl+ fp . fps) (%fpfold 'fl+ $fp+ fp fps))
381
382(define (fl- fp . fps)
383  (if (%null? fps) (%fpnegate fp)
384      (%fpfold 'fl- $fp- fp fps) ) )
385
386(define (fl* fp . fps) (%fpfold 'fl* $fp* fp fps))
387
388(define (fl/ fp . fps)
389  (if (%null? fps) (%fp/ 1.0 fp)
390        (%fpfold 'fl/ $fp/ fp fps) ) )
391
392(define (flabs fp)
393  (%check-flonum 'flabs fp)
394  (%fpabs fp) )
395
396(define (fltruncate fp)
397  (%check-flonum 'fltruncate fp)
398  (%fptruncate fp) )
399
400(define (flfloor fp)
401  (%check-flonum 'flfloor fp)
402  (%fpfloor fp) )
403
404(define (flceiling fp)
405  (%check-flonum 'flceiling fp)
406  (%fpceiling fp) )
407
408(define (flround fp)
409  (%check-flonum 'flround fp)
410  (%fpround fp) )
411
412(define (fldiv fpn fpd)
413  (%check-flonum 'fldiv fpn)
414  (%check-flonum 'fldiv fpd)
415  (%fpdiv fpn fpd) )
416
417(define (flmod fpn fpd)
418  (%check-flonum 'flmod fpn)
419  (%check-flonum 'flmod fpd)
420  (%fpmod fpn fpd) )
421
422(define (fldiv-and-mod fpn fpd)
423  (%check-flonum 'fldiv-and-mod fpn)
424  (%check-flonum 'fldiv-and-mod fpd)
425  (%fpdiv-and-mod  fpn fpd) )
426
427(define (fldiv0 fpn fpd)
428  (%check-flonum 'fldiv0 fpn)
429  (%check-flonum 'fldiv0 fpd)
430  (%fpdiv0 fpn fpd) )
431
432(define (flmod0 fpn fpd)
433  (%check-flonum 'flmod0 fpn)
434  (%check-flonum 'flmod0 fpd)
435  (%fpmod0 fpn fpd) )
436
437(define (fldiv0-and-mod0 fpn fpd)
438  (%check-flonum 'fldiv0-and-mod0 fpn)
439  (%check-flonum 'fldiv0-and-mod0 fpd)
440  (%fpdiv0-and-mod0 fpn fpd) )
441
442(define (flexp fp)
443  (%check-flonum 'flexp fp)
444  (%fpexp fp) )
445
446(define (fllog fp #!optional base)
447  (define log/base  ;memoize log/base functions
448    (let ((bases '()))
449      (lambda (base)
450        (let* ((base (%exact->inexact base))
451               (logfun (%assv base bases)))
452               (if logfun (%cdr logfun)
453                   (let ((func (make-log/base base)))
454                     (set! bases (alist-cons base func bases))
455                     func ) ) ) ) ) )
456  (%check-flonum 'fllog fp)
457  (cond ((%fpnegzero? fp) -0.0)
458        (base
459         (%check-positive 'fllog base)
460         ((log/base base) fp) )
461        (else
462         (%fplog fp) ) ) )
463
464(define (flsin fp)
465  (%check-flonum 'flsin fp)
466  (%fpsin fp) )
467
468(define (flcos fp)
469  (%check-flonum 'flcos fp)
470  (%fpcos fp) )
471
472(define (fltan fp)
473  (%check-flonum 'fltan fp)
474  (%fptan fp) )
475
476(define (flasin fp)
477  (%check-flonum 'flasin fp)
478  (%fpasin fp) )
479
480(define (flacos fp)
481  (%check-flonum 'flacos fp)
482  (%fpacos fp) )
483
484(define (flatan fp #!optional fpd)
485  (%check-flonum 'flatan fp)
486  (cond (fpd
487         (%check-flonum 'flatan fpd)
488         (%fpatan2 fp fpd) )
489        (else
490         (%fpatan fp) ) ) )
491
492(define (flsqrt fp)
493  (%check-flonum 'flsqrt fp)
494  (%fpsqrt fp) )
495
496(define (flexpt fp exp)
497  (%check-flonum 'flexpt fp)
498  (%check-flonum 'flexpt exp)
499  (if (%fp= 2.0 fp) (ldexp 1.0 exp)
500      (%expt fp exp) ) )
501
502;; n / d = fp
503;;
504;; n = fp * d
505;; d = n / fp
506
507(define (flnumerator fp)
508  (%check-flonum 'flnumerator fp)
509  (cond ((or (%integer? fp) (%fpzero? fp) (not (%finite? fp)) (%fpnan? fp))
510         fp )
511        (else
512         (receive (n d) (*fp->fraction fp) n) ) ) )
513
514(define (fldenominator fp)
515  (%check-flonum 'fldenominator fp)
516  (cond ((%fpnan? fp)
517         +nan )
518        ((or (%integer? fp) (%fpzero? fp) (not (%finite? fp)))
519         1.0 )
520        (else
521         (receive (n d) (*fp->fraction fp) d) ) ) )
522
523;;; Extras
524
525(define (flgcd fp1 fp2)
526  (%check-flonum 'flgcd fp1)
527  (%check-flonum 'flgcd fp2)
528  (cond ((or (not (%finite? fp1)) (not (%finite? fp2)))
529         0.0 )
530        ((%fpzero? fp1)
531         fp2 )
532        ((%fpzero? fp2)
533         fp1 )
534        (else
535         (*fpgcd fp1 fp2) ) ) )
536
537(define (flonum->fraction fp)
538  (%check-flonum 'flonum->fraction fp)
539  (cond ((%fpnan? fp)
540         (values +nan +nan) )
541        ((or (%integer? fp) (%fpzero? fp) (not (%finite? fp)))
542         (values fp 1.0) )
543        (else
544         (*fp->fraction fp) ) ) )
545
546(define (fl<>? fp . fps) (%fpand-fold 'fl<>? $fp<>? fp fps))
547
548(define (flcompare fl1 fl2)
549  (%check-flonum 'flcompare fl1)
550  (%check-flonum 'flcompare fl2)
551        (cond ((%fp=? fl1 fl2)
552               (cond ((%fpnegzero? fl1)
553                      (if (%fpnegzero? fl1) 0 1) )
554               ((%fpnegzero? fl2)
555                (if (%fp=? 0.0 fl1) -1 0) )
556                     (else
557                      0 ) ) )
558              ((%fp<? fl1 fl2)
559               -1 )
560              (else
561               1 ) ) )
562
563(define (flfraction fp)
564  (%check-flonum 'flfraction fp)
565  (%fpfraction fp) )
566
567(define (flnegate fp)
568  (%check-flonum 'flnegate fp)
569  (%fpnegate fp) )
570
571;;
572
573(define-syntax *fl=?
574  (syntax-rules ()
575    ((_ ?x)
576      #t )
577    ((_ ?x ?y)
578      ($fp=? ?x ?y) )
579    ((_ ?x ?y ?rest ...)
580      (and ($fp=? ?x ?y) (*fl=? ?y ?rest ...)) ) ) )
581
582(define-syntax *fl<?
583  (syntax-rules ()
584    ((_ ?x)
585      #t )
586    ((_ ?x ?y)
587      ($fp<? ?x ?y) )
588    ((_ ?x ?y ?rest ...)
589      (and ($fp<? ?x ?y) (*fl<? ?y ?rest ...)) ) ) )
590
591(define-syntax *fl>?
592  (syntax-rules ()
593    ((_ ?x)
594      #t )
595    ((_ ?x ?y)
596      ($fp>? ?x ?y) )
597    ((_ ?x ?y ?rest ...)
598      (and ($fp>? ?x ?y) (*fl>? ?y ?rest ...)) ) ) )
599
600(define-syntax *fl<=?
601  (syntax-rules ()
602    ((_ ?x)
603      #t )
604    ((_ ?x ?y)
605      ($fp<=? ?x ?y) )
606    ((_ ?x ?y ?rest ...)
607      (and ($fp<=? ?x ?y) (*fl<=? ?y ?rest ...)) ) ) )
608
609(define-syntax *fl>=?
610  (syntax-rules ()
611    ((_ ?x)
612      #t )
613    ((_ ?x ?y)
614      ($fp>=? ?x ?y) )
615    ((_ ?x ?y ?rest ...)
616      (and ($fp>=? ?x ?y) (*fl>=? ?y ?rest ...)) ) ) )
617
618(define-syntax *fl<>?
619  (syntax-rules ()
620    ((_ ?x)
621      #t )
622    ((_ ?x ?y)
623      ($fp<>? ?x ?y) )
624    ((_ ?x ?y ?rest ...)
625      (and ($fp<>? ?x ?y) (*fl<>? ?y ?rest ...)) ) ) )
626
627;;
628
629(define-syntax *flmax
630  (syntax-rules ()
631    ((_ ?x)
632      ?x )
633    ((_ ?x ?y)
634      ($fpmax ?x ?y) )
635    ((_ ?x ?y ?rest ...)
636      ($fpmax ?x (*flmax ?y ?rest ...)) ) ) )
637
638(define-syntax *flmin
639  (syntax-rules ()
640    ((_ ?x)
641      ?x )
642    ((_ ?x ?y)
643      ($fpmin ?x ?y) )
644    ((_ ?x ?y ?rest ...)
645      ($fpmin ?x (*flmin ?y ?rest ...)) ) ) )
646
647;;
648
649(define-syntax *fl-
650  (syntax-rules ()
651    ((_ ?x)
652      ($fpneg ?x) )
653    ((_ ?x ?y)
654      ($fp- ?x ?y) )
655    ((_ ?x ?y ?rest ...)
656      ($fp- ?x (*fl- ?y ?rest ...) ) ) ) )
657
658(define-syntax *fl+
659  (syntax-rules ()
660    ((_ ?x)
661      ?x )
662    ((_ ?x ?y)
663      ($fp+ ?x ?y) )
664    ((_ ?x ?y ?rest ...)
665      ($fp+ ?x (*fl+ ?y ?rest ...) ) ) ) )
666
667(define-syntax *fl*
668  (syntax-rules ()
669    ((_ ?x)
670      ?x )
671    ((_ ?x ?y)
672      ($fp* ?x ?y) )
673    ((_ ?x ?y ?rest ...)
674      ($fp* ?x (*fl* ?y ?rest ...) ) ) ) )
675
676(define-syntax *fl/
677  (syntax-rules ()
678    ((_ ?x)
679      ?x )
680    ((_ ?x ?y)
681      ($fp/ ?x ?y) )
682    ((_ ?x ?y ?rest ...)
683      ($fp/ ?x (*fl/ ?y ?rest ...) ) ) ) )
684
685) ;module err5rs-arithmetic-flonums
Note: See TracBrowser for help on using the repository browser.