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

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

Save.

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