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

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

Save.

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