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

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

Update inlines. Testing.

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