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

Last change on this file since 13604 was 13604, checked in by Kon Lovett, 12 years ago

Save.

File size: 13.8 KB
Line 
1;;;; flonum-extras.scm
2;;;; Kon Lovett, Mar '09
3
4
5;;; Prelude
6
7(declare
8        (usual-integrations)
9        (generic)
10  (disable-interrupts)
11        (no-bound-checks)
12        (no-procedure-checks-for-usual-bindings)
13        (bound-to-procedure
14          ##sys#signal-hook
15          ##sys#check-integer
16          ##sys#flonum-fraction
17          ##sys#floor
18          ##sys#ceiling
19          ##sys#exact->inexact )
20  (export
21    ; Checked
22    real->flonum
23    fixnum->flonum
24    fl=?
25    fl<?
26    fl>?
27    fl<=?
28    fl>=?
29    flcompare
30    flinteger?
31    flzero?
32    flpositive?
33    flnegative?
34    flodd?
35    fleven?
36    flfinite?
37    flinfinite?
38    flnan?
39    fl+
40    fl*
41    fl-
42    fl/
43    flmax
44    flmin
45    flmax-and-min
46    flabs
47    flfraction
48    flfloor
49    flceiling
50    flround
51    fltruncate
52    fldiv
53    flmod
54    fldiv-and-mod
55    fldiv0
56    flmod0
57    fldiv0-and-mod0
58    flexp
59    fllog
60    flsin
61    flcos
62    fltan
63    flasin
64    flacos
65    flatan
66    flsqrt
67    flexpt
68    flnumerator
69    fldenominator
70    ; Unchecked
71    %fp=
72    %fp<
73    %fp>
74    %fp>=
75    %fp<=
76    %fpmax
77    %fpmin
78    %fp+
79    %fp-
80    %fp*
81    %fp/
82    ) )
83
84(require-library mathh)
85
86(include "chicken-primitive-object-inlines")
87
88;;;
89
90(define (check-flonum loc obj)
91  (unless (##core#inline "C_i_flonump" obj)
92    (##sys#signal-hook #:type-error loc "bad argument type - not a flonum" obj) ) )
93
94(define (check-non-negative-integer loc obj)
95  (##sys#check-integer obj loc)
96  (unless ((##core#primitive "C_lessp") 0 obj)
97    (##sys#signal-hook #:type-error loc "bad argument type - not a non-negative integer" obj) ) )
98
99;;;
100
101(define-inline (%fold1 loc func init lyst)
102  (check-flonum loc init)
103  (let loop ([acc init] [lyst lyst])
104          (if (null? lyst)
105              acc
106              (let ([cur (car lyst)])
107          (check-flonum loc cur)
108          (loop (func acc cur) (cdr lyst)) ) ) ) )
109
110(define-inline (%and-fold1 loc func init lyst)
111  (check-flonum loc init)
112  (let loop ([prv init] [lyst lyst])
113          (or (null? lyst)
114        (let ([cur (car lyst)])
115          (check-flonum loc cur)
116                (and (func prv cur)
117               (loop cur (cdr lyst)) ) ) ) ) )
118
119;;;
120
121(define %fpfrac ##sys#flonum-fraction)
122
123(define %fptrunc ##sys#truncate)
124
125(define %fpfloor ##sys#floor)
126
127(define %fpceil ##sys#ceiling)
128
129(define-inline (%fprnd fp)
130  (if (##core#inline "C_flonum_equalp" 0.0 fp)
131      0.0
132      (%fptrunc (##core#inline_allocate ("C_a_i_flonum_plus" 4)
133                 fp
134                 (if (##core#inline "C_flonum_lessp" 0.0 fp) 0.5 -0.5))) ) )
135
136(define-inline (%fpquo fpn fpd)
137  (%fptrunc (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpn fpd)) )
138
139(define-inline (%fprem fpn fpd)
140  (##core#inline_allocate ("C_a_i_flonum_difference" 4)
141   fpn
142   (##core#inline_allocate ("C_a_i_flonum_times" 4)
143    (%fptrunc (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpn fpd))
144    fpd)) )
145
146(define-inline (%fpquo-and-rem fpn fpd)
147  (let ([quo (%fpquo fpn fpd)])
148    (values quo
149            (##core#inline_allocate ("C_a_i_flonum_difference" 4)
150             fpn
151             (##core#inline_allocate ("C_a_i_flonum_times" 4) quo fpd))) ) )
152
153(define-inline (%fpinteger? fp)
154  (##core#inline "C_flonum_equalp" 0.0 (%fpfrac fp)) )
155
156(define-inline (%fpnan? fp)
157  (not (##core#inline "C_flonum_equalp" fp fp)) )
158
159(define (%fp= x y)
160  (##core#inline "C_flonum_equalp" x y) )
161
162(define (%fp< x y)
163  (or (and (##core#inline "C_flonum_equalp" -0.0 x)
164           (##core#inline "C_flonum_equalp" 0.0 y))
165      (##core#inline "C_flonum_lessp" x y) ) )
166
167(define (%fp<= x y)
168  (or (and (##core#inline "C_flonum_equalp" -0.0 x)
169           (##core#inline "C_flonum_equalp" 0.0 y))
170      (##core#inline "C_flonum_less_or_equal_p" x y) ) )
171
172(define (%fp> x y)
173  (or (and (##core#inline "C_flonum_equalp" 0.0 x)
174           (##core#inline "C_flonum_equalp" -0.0 y))
175      (##core#inline "C_flonum_greaterp" x y) ) )
176
177(define (%fp>= x y)
178  (or (and (##core#inline "C_flonum_equalp" 0.0 x)
179           (##core#inline "C_flonum_equalp" -0.0 y))
180      (##core#inline "C_flonum_greater_or_equal_p" x y) ) )
181
182(define (%fpmax x y)
183  (##core#inline "C_i_flonum_max" x y) )
184
185(define (%fpmin x y)
186  (##core#inline "C_i_flonum_min" x y) )
187
188(define (%fp+ x y)
189  (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y) )
190
191(define (%fp- x y)
192  (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y) )
193
194(define (%fp* x y)
195  (##core#inline_allocate ("C_a_i_flonum_times" 4) x y) )
196
197(define (%fp/ x y)
198  (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y) )
199
200(define-inline (%fpdiv0-and-mod0 fpn fpd)
201  (let-values ([(quo rem) (%fpquo-and-rem fpn fpd)])
202    (cond [(##core#inline "C_flonum_greater_or_equal_p" fpd 0.0)
203            (if (##core#inline "C_flonum_lessp"
204                 rem
205                 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd 2.0))
206                (if (##core#inline "C_flonum_greater_or_equal_p"
207                     rem
208                     (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd -2.0))
209                    (values quo rem)
210                    (values (##core#inline_allocate ("C_a_i_flonum_difference" 4) quo 1.0)
211                            (##core#inline_allocate ("C_a_i_flonum_plus" 4) rem fpd)) )
212                (values (##core#inline_allocate ("C_a_i_flonum_plus" 4) quo 1.0)
213                        (##core#inline_allocate ("C_a_i_flonum_difference" 4) rem fpd)) ) ]
214          [(##core#inline "C_flonum_lessp"
215            rem
216            (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd -2.0))
217            (if (##core#inline "C_flonum_greater_or_equal_p"
218                 rem
219                 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd 2.0))
220                (values quo rem)
221                (values (##core#inline_allocate ("C_a_i_flonum_plus" 4) quo 1.0)
222                        (##core#inline_allocate ("C_a_i_flonum_difference" 4) rem fpd)) ) ]
223          [else
224            (values (##core#inline_allocate ("C_a_i_flonum_difference" 4) quo 1.0)
225                    (##core#inline_allocate ("C_a_i_flonum_plus" 4) rem fpd)) ] ) ) )
226
227(define-inline (%fpdiv0 fpn fpd)
228  (let-values ([(quo rem) (%fpquo-and-rem fpn fpd)])
229    (cond [(##core#inline "C_flonum_greater_or_equal_p" fpd 0.0)
230            (if (##core#inline "C_flonum_lessp"
231                 rem
232                 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd 2.0))
233                (if (##core#inline "C_flonum_greater_or_equal_p"
234                     rem
235                     (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd -2.0))
236                    quo
237                    (##core#inline_allocate ("C_a_i_flonum_difference" 4) quo 1.0) )
238                (##core#inline_allocate ("C_a_i_flonum_plus" 4) quo 1.0) ) ]
239          [(##core#inline "C_flonum_lessp"
240            rem
241            (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd -2.0))
242            (if (##core#inline "C_flonum_greater_or_equal_p"
243                 rem
244                 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd 2.0))
245                quo
246                (##core#inline_allocate ("C_a_i_flonum_plus" 4) quo 1.0) ) ]
247          [else
248            (##core#inline_allocate ("C_a_i_flonum_difference" 4) quo 1.0) ] ) ) )
249
250(define-inline (%fpmod0 fpn fpd)
251  (let ([rem (%fprem fpn fpd)])
252    (cond [(##core#inline "C_flonum_greater_or_equal_p" fpd 0.0)
253            (if (##core#inline "C_flonum_lessp"
254                 rem
255                 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd 2.0))
256                (if (##core#inline "C_flonum_greater_or_equal_p"
257                     rem
258                     (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd -2.0))
259                    rem
260                    (##core#inline_allocate ("C_a_i_flonum_plus" 4) rem fpd) )
261                (##core#inline_allocate ("C_a_i_flonum_difference" 4) rem fpd) ) ]
262          [(##core#inline "C_flonum_lessp"
263            rem
264            (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd -2.0))
265            (if (##core#inline "C_flonum_greater_or_equal_p"
266                 rem
267                 (##core#inline_allocate ("C_a_i_flonum_quotient" 4) fpd 2.0))
268                rem
269                (##core#inline_allocate ("C_a_i_flonum_difference" 4) rem fpd) )]
270          [else
271            (##core#inline_allocate ("C_a_i_flonum_plus" 4) rem fpd) ] ) ) )
272
273;;;
274
275(define (real->flonum value)
276  (if (##core#inline "C_i_flonump" value)
277      value
278      (##sys#exact->inexact value) ) )
279
280(define (fixnum->flonum fx)
281  (if (##core#inline "C_fixnump" fx)
282      (##sys#exact->inexact fx)
283      (##sys#signal-hook #:type-error 'fixnum->flonum
284                         "bad argument type - not a fixnum" fx) ) )
285
286;;;
287
288(define (fl=? fl . rest)
289        (%and-fold1 'fl=? %fp= fl rest) )
290
291(define (fl<? fl . rest)
292        (%and-fold1 'fl<? %fp< fl rest) )
293
294(define (fl>? fl . rest)
295        (%and-fold1 'fl>? %fp> fl rest) )
296
297(define (fl<=? fl . rest)
298        (%and-fold1 'fl<=? %fp<= fl rest) )
299
300(define (fl>=? fl . rest)
301        (%and-fold1 'fl>=? %fp>= fl rest) )
302
303(define (flcompare fl1 fl2)
304  (check-flonum 'flcompare fl1)
305  (check-flonum 'flcompare fl2)
306        (cond [(##core#inline "C_flonum_equalp" fl1 fl2)
307                (cond [(##core#inline "C_flonum_equalp" -0.0 fl1)
308                  (if (##core#inline "C_flonum_equalp" -0.0 fl1)
309                      0
310                      1) ]
311                      [(##core#inline "C_flonum_equalp" -0.0 fl2)
312                        (if (##core#inline "C_flonum_equalp" 0.0 fl1)
313                            -1
314                            0) ]
315                      [else
316                        0 ] ) ]
317              [(##core#inline "C_flonum_lessp" fl1 fl2)
318                -1 ]
319              [else
320                1 ] ) )
321
322(define (flmax fl . rest)
323        (%fold1 'flmax %fpmax fl rest) )
324
325(define (flmin fl . rest)
326        (%fold1 'flmin %fpmin fl rest) )
327
328(define (flmax-and-min fl . rest)
329  (check-flonum 'flmax-and-min fl)
330        (let loop ([mx fl]
331                   [mn fl]
332                   [lyst rest])
333          (if (null? lyst)
334              (values mx mn)
335              (let ([cur (car lyst)])
336                (check-flonum 'flmax-and-min cur)
337          (loop (##core#inline "C_i_flonum_max" mx cur)
338                (##core#inline "C_i_flonum_min" mn cur)
339                (cdr lyst)) ) ) ) )
340
341;;;
342
343(define (flinteger? fl)
344  (check-flonum 'flinteger? fl)
345  (%fpinteger? fl) )
346
347(define (flzero? fl)
348  (check-flonum 'flzero? fl)
349        (##core#inline "C_flonum_equalp" 0.0 fl) )
350
351(define (flpositive? fl)
352  (check-flonum 'flpositive? fl)
353        (##core#inline "C_flonum_lessp" 0.0 fl) )
354
355(define (flnegative? fl)
356  (check-flonum 'flnegative? fl)
357        (or (##core#inline "C_flonum_equalp" -0.0 fl)
358      (##core#inline "C_flonum_lessp" fl 0.0) ) )
359
360(define (flodd? fl)
361  (check-flonum 'flodd? fl)
362  (not (##core#inline "C_flonum_equalp" 0.0 (fpmod fl 2.0))) )
363
364(define (fleven? fl)
365  (check-flonum 'fleven? fl)
366  (##core#inline "C_flonum_equalp" 0.0 (fpmod fl 2.0)) )
367
368(define (flfinite? fl)
369  (check-flonum 'flfinite? fl)
370  (##core#inline "C_i_finitep" fl) )
371
372(define (flinfinite? fl)
373  (check-flonum 'flinfinite? fl)
374  (not (##core#inline "C_i_finitep" fl)) )
375
376(define (flnan? fl)
377  (check-flonum 'flnan? fl)
378  (%fpnan? fl) )
379
380;;;
381
382(define (fl+ fl . rest)
383        (%fold1 'fl+ %fp+ fl rest) )
384
385(define (fl* fl . rest)
386        (%fold1 'fl* %fp* fl rest) )
387
388(define (fl- fl . rest)
389  (or (and (null? rest)
390           (##core#inline_allocate ("C_a_i_flonum_negate" 4) fl) )
391      (%fold1 'fl- %fp- fl rest) ) )
392
393(define (fl/ fl . rest)
394  (or (and (null? rest)
395           (##core#inline_allocate ("C_a_i_flonum_quotient" 4) 1.0 fl) )
396        (%fold1 'fl/ %fp/ fl rest) ) )
397
398(define (flabs fl)
399  (check-flonum 'flabs fl)
400  (##core#inline_allocate ("C_a_i_abs" 4) fl) )
401
402(define (flfraction fl)
403  (check-flonum 'flfraction fl)
404  (%fpfrac fl) )
405
406(define (fltruncate fl)
407  (check-flonum 'fltruncate fl)
408  (%fptrunc fl) )
409
410(define (flfloor fl)
411  (check-flonum 'flfloor fl)
412  (%fpfloor fl) )
413
414(define (flceiling fl)
415  (check-flonum 'flceiling fl)
416  (%fpceil fl) )
417
418(define (flround fl)
419  (check-flonum 'flround fl)
420  (%fprnd fl) )
421
422(define (fldiv fln fld)
423  (check-flonum 'fldiv fln)
424  (check-flonum 'fldiv fld)
425  (%fpquo fln fld) )
426
427(define (flmod fln fld)
428  (check-flonum 'flmod fln)
429  (check-flonum 'flmod fld)
430  (%fprem fln fld) )
431
432(define (fldiv-and-mod fln fld)
433  (check-flonum 'fldiv-and-mod fln)
434  (check-flonum 'fldiv-and-mod fld)
435  (%fpquo-and-rem fln fld) )
436
437(define (fldiv0 fln fld)
438  (check-flonum 'fldiv0 fln)
439  (check-flonum 'fldiv0 fld)
440  (%fpdiv0 fln fld) )
441
442(define (flmod0 fln fld)
443  (check-flonum 'flmod0 fln)
444  (check-flonum 'flmod0 fld)
445  (%fpmod0 fln fld) )
446
447(define (fldiv0-and-mod0 fln fld)
448  (check-flonum 'fldiv0-and-mod0 fln)
449  (check-flonum 'fldiv0-and-mod0 fld)
450  (%fpdiv0-and-mod0 fln fld) )
451
452(define (flexp fl)
453  (check-flonum 'flexp fl)
454  (##core#inline_allocate ("C_a_i_exp" 4) fl) )
455
456(define (fllog fl . rest)
457  (check-flonum 'fllog fl)
458  (if (null? rest)
459      (##core#inline_allocate ("C_a_i_log" 4) fl)
460      (let ([base (car rest)])
461        (check-non-negative-integer 'fllog base)
462        ((make-log/base base) fl) ) ) )
463
464(define (flsin fl)
465  (check-flonum 'flsin fl)
466  (##core#inline_allocate ("C_a_i_sin" 4) fl) )
467
468(define (flcos fl)
469  (check-flonum 'flcos fl)
470  (##core#inline_allocate ("C_a_i_cos" 4) fl) )
471
472(define (fltan fl)
473  (check-flonum 'fltan fl)
474  (##core#inline_allocate ("C_a_i_tan" 4) fl) )
475
476(define (flasin fl)
477  (check-flonum 'flasin fl)
478  (##core#inline_allocate ("C_a_i_asin" 4) fl) )
479
480(define (flacos fl)
481  (check-flonum 'flacos fl)
482  (##core#inline_allocate ("C_a_i_acos" 4) fl) )
483
484(define (flatan fl . rest)
485  (check-flonum 'flatan fl)
486  (if (null? rest)
487      (##core#inline_allocate ("C_a_i_atan" 4) fl)
488      (let ([fld (car rest)])
489        (check-flonum 'flatan fld)
490        (##core#inline_allocate ("C_a_i_atan2" 4) fl fld) ) ) )
491
492(define (flsqrt fl)
493  (check-flonum 'flsqrt fl)
494  (##core#inline_allocate ("C_a_i_sqrt" 4) fl) )
495
496(define (flexpt fl exp)
497  (check-flonum 'flexpt fl)
498  (check-flonum 'flexpt exp)
499  (or (and (= 2.0 fl)
500           (ldexp 1.0 exp) )
501      ((##core#primitive "C_expt") fl exp) ) )
502
503(define (flnumerator fl)
504  (check-flonum 'flnumerator fl)
505  fl )
506
507(define (fldenominator fl)
508  (check-flonum 'fldenominator fl)
509  (if (%fpnan? fl)
510      fl
511      1.0 ) )
Note: See TracBrowser for help on using the repository browser.