source: project/release/3/mathh/trunk/flonum-extras.scm @ 8595

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

Save.

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