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

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

Save.

File size: 15.5 KB
Line 
1;;;; err5rs-arithmetic-fixnums.scm
2;;;; Kon Lovett, Mar '09
3
4
5;;; Prelude
6
7(declare
8  (usual-integrations)
9  (disable-interrupts)
10  (arithmetic-type fixnum)
11  (inline)
12  #;(local)
13  (no-bound-checks)
14  (no-procedure-checks)
15  (bound-to-procedure
16    ##sys#check-exact
17    ##sys#signal-hook
18    ##sys#string-append ) )
19
20;;
21
22(require-library err5rs-arithmetic-bitwise)
23
24(include "chicken-primitive-object-inlines")
25
26;TODO - add to chicken-primitive-object-inline
27
28(define-inline (%< x y) ((##core#primitive "C_lessp") x y))
29(define-inline (%<= x y) ((##core#primitive "C_less_or_equal_p") x y))
30(define-inline (%> x y) ((##core#primitive "C_greaterp") x y))
31(define-inline (%>= x y) ((##core#primitive "C_greater_or_equal_p") x y))
32
33(define-inline (%+ x y) ((##core#primitive "C_plus") x y))
34(define-inline (%- x y) ((##core#primitive "C_minus") x y))
35(define-inline (%* x y) ((##core#primitive "C_times") x y))
36(define-inline (%/ x y) ((##core#primitive "C_divide") x y))
37
38(define-inline (%quotient x y) ((##core#primitive "C_quotient") x y))
39
40(define-inline (%arithmetic-shift x d) (##core#inline_allocate ("C_a_i_arithmetic_shift" 4) x d))
41
42;;
43
44(define-inline (%fixnum-zero-division-error loc fx1 fx2)
45  (##sys#signal-hook #:arithmetic-error loc "division by zero" fx1 fx2) )
46
47(define-inline (%fixnum-representation-error loc fx1 fx2)
48  (##sys#signal-hook #:arithmetic-error loc "results not representable as fixnums" fx1 fx2) )
49
50(define-inline (%check-fixnum loc obj) (##sys#check-exact obj loc))
51
52(define-inline (%check-non-negative-fixnum loc obj)
53  (unless (and (%fixnum? obj) (%fx<= 0 obj))
54    (##sys#signal-hook #:type-error loc "bad argument type - not a non-negative fixnum" obj) ) )
55
56(define-inline (%check-fixnum<= loc fx1 fx2)
57  (unless (%fx<= fx1 fx2)
58    (##sys#signal-hook #:bounds-error loc "not a fixnum interval" fx1 fx2) ) )
59
60(define-inline (%check-fixnum-bits loc fx)
61  (unless (%fx<= fx fixnum-bits)
62    (##sys#signal-hook #:bounds-error loc "out of fixnum range" fx) ) )
63
64(define *fixnum-bits-end* (%fx+ fixnum-bits 1))
65
66(define-inline (%check-fixnum-bits+1 loc fx)
67  (unless (%fx<= fx *fixnum-bits-end*)
68    (##sys#signal-hook #:bounds-error loc "out of fixnum range" fx) ) )
69
70(define-inline (%check-zero-division loc fx1 fx2)
71  (when (%fx= 0 fx2)
72    (%fixnum-zero-division-error loc fx1 fx2) ) )
73
74;;
75
76;Note - argument order is (func acc cur) & not (func cur acc) as in (fold func).
77
78(define-inline (%fxfold-1 loc func init lyst)
79  (%check-fixnum loc init)
80  (let loop ((ls lyst) (acc init))
81    (if (%null? ls) acc
82        (let ((cur (%car ls)))
83          (%check-fixnum loc cur)
84          (loop (%cdr ls) (func acc cur)) ) ) ) )
85
86(define-inline (%fxand-fold-1 loc func init lyst)
87  (%check-fixnum loc init)
88  (let loop ((ls lyst) (acc init))
89    (or (%null? ls)
90        (let ((cur (%car ls)))
91          (%check-fixnum loc cur)
92          (and (func acc cur)
93               (loop (%cdr ls) cur) ) ) ) ) )
94
95;;
96
97(define-inline (%fxdiv0-and-mod0 fxn fxd)
98  (let* ((quo (%quotient fxn fxd))
99         (rem (%- fxn (%* quo fxd))))
100    (cond ((%>= fxd 0)
101           (if (%< (%* rem 2) fxd)
102               (if (%<= (%* rem -2) fxd) (values quo rem)
103                   (values (%- quo 1) (%+ rem fxd)) )
104               (values (%+ quo 1) (%- rem fxd)) ) )
105          ((%> (%* rem -2) fxd)
106           (if (%>= (%* rem 2) fxd) (values quo rem)
107               (values (%+ quo 1) (%- rem fxd)) ) )
108          (else
109           (values (%- quo 1) (%+ rem fxd)) ) ) ) )
110
111(define-inline (%fxdiv0 fxn fxd)
112  (let* ((quo (%quotient fxn fxd))
113         (rem (%- fxn (%* quo fxd))))
114    (cond ((%>= fxd 0)
115           (if (%< (%* rem 2) fxd)
116               (if (%<= (%* rem -2) fxd) quo
117                   (%- quo 1) )
118               (%+ quo 1) ) )
119          ((%> (%* rem -2) fxd)
120           (if (%>= (%* rem 2) fxd) quo
121               (%+ quo 1) ) )
122          (else
123           (%- quo 1) ) ) ) )
124
125(define-inline (%fxmod0 fxn fxd)
126  (let* ((quo (%quotient fxn fxd))
127         (rem (%- fxn (%* quo fxd))))
128    (cond ((%>= fxd 0)
129           (if (%< (%* rem 2) fxd)
130               (if (%<= (%* rem -2) fxd) rem
131                   (%+ rem fxd) )
132               (%- rem fxd) ) )
133          ((%> (%* rem -2) fxd)
134           (if (%>= (%* rem 2) fxd) rem
135               (%- rem fxd) ) )
136          (else
137           (%+ rem fxd) ) ) ) )
138
139;;
140
141(define-inline (%string-append s1 s2) (##sys#string-append s1 s2))
142
143
144;;;
145
146(module err5rs-arithmetic-fixnums (;export
147  ; ERR5RS
148  ;;fixnum? - from chicken
149  fixnum-width least-fixnum greatest-fixnum
150  fx=? fx<? fx>? fx<=? fx>=? fxcompare
151  fxzero? fxpositive? fxnegative? fxodd? fxeven?
152  fxmax fxmin fxmax-and-min
153  fxabs
154  fxdiv fxdiv-and-mod fxdiv0 fxmod0 fxdiv0-and-mod0
155  fx*/carry fx+/carry fx-/carry
156  fxadd1 fxsub1
157  fxmodulo fxquotient fxremainder
158  fxarithmetic-shift fxarithmetic-shift-left fxarithmetic-shift-right
159  fx- ;;fx+ fx* fx/ - from chicken
160  fxand fxior fxxor
161  fxif
162  fxbit-count
163  fxlength
164  fxfirst-bit-set fxlast-bit-set
165  fxbit-set?
166  fxcopy-bit
167  fxbit-field
168  fxcopy-bit-field
169  fxrotate-bit-field
170  fxreverse-bit-field
171  ; Extras
172  fixnum->string
173  fxif-not
174  fxnegate
175  fxpow2log2
176  fx-# fx+# fx*# fx/#)
177
178(import scheme
179        (rename chicken
180         (fxmax chicken:fxmax)
181         (fxmin chicken:fxmin)
182         (fx- chicken:fx-)
183         (fxand chicken:fxand)
184         (fxior chicken:fxior)
185         (fxxor chicken:fxxor))
186        foreign)
187
188
189;;; Procedures wrapping primitive-inlines for fold operations
190
191(define (*fx= x y) (%fx= x y))
192(define (*fx< x y) (%fx< x y))
193(define (*fx> x y) (%fx> x y))
194(define (*fx>= x y) (%fx>= x y))
195(define (*fx<= x y) (%fx<= x y))
196(define (*fxmax x y) (%fxmax x y))
197(define (*fxmin x y) (%fxmin x y))
198(define (*fxand x y) (%fxand x y))
199(define (*fxior x y) (%fxor x y))
200(define (*fxxor x y) (%fxxor x y))
201(define (*fx+ x y) (%fx+ x y))
202(define (*fx- x y) (%fx- x y))
203(define (*fx* x y) (%fx* x y))
204(define (*fx/ x y) (%fx/ x y))
205
206
207;;;
208
209(define *fixnum-negated-precision* (%fxneg fixnum-precision))
210
211
212;;;
213
214(define (fixnum-width) fixnum-precision)
215
216(define (least-fixnum) most-negative-fixnum)
217
218(define (greatest-fixnum) most-positive-fixnum)
219
220
221;;;
222
223(define (fx=? fx . fxs)
224  (%fxand-fold-1 'fx=? *fx= fx fxs) )
225
226(define (fx<? fx . fxs)
227  (%fxand-fold-1 'fx<? *fx< fx fxs) )
228
229(define (fx>? fx . fxs)
230  (%fxand-fold-1 'fx>? *fx> fx fxs) )
231
232(define (fx<=? fx . fxs)
233  (%fxand-fold-1 'fx<=? *fx<= fx fxs) )
234
235(define (fx>=? fx . fxs)
236  (%fxand-fold-1 'fx>=? *fx>= fx fxs) )
237
238(define (fxcompare fx1 fx2)
239  (%check-fixnum 'fxcompare fx1)
240  (%check-fixnum 'fxcompare fx2)
241  (cond ((%fx= fx1 fx2)   0)
242        ((%fx< fx1 fx2)   -1)
243        (else             1) ) )
244
245(define (fxmax fx . fxs)
246  (%fxfold-1 'fxmax *fxmax fx fxs) )
247
248(define (fxmin fx . fxs)
249  (%fxfold-1 'fxmin *fxmin fx fxs) )
250
251(define (fxmax-and-min fx . fxs)
252  (%check-fixnum 'fxmax-and-min fx)
253  (let loop ((fxs fxs) (mx fx) (mn fx))
254    (if (%null? fxs) (values mx mn)
255        (let ((cur (%car fxs)))
256          (%check-fixnum 'fxmax-and-min cur)
257          (loop (%cdr fxs) (%fxmax mx cur) (%fxmin mn cur)) ) ) ) )
258
259
260;;;
261
262(define (fxzero? fx)
263  (%check-fixnum 'fxzero? fx)
264  (%fx= 0 fx) )
265
266(define (fxpositive? fx)
267  (%check-fixnum 'fxpositive? fx)
268  (%fx< 0 fx) )
269
270(define (fxnegative? fx)
271  (%check-fixnum 'fxnegative? fx)
272  (%fx< fx 0) )
273
274(define (fxodd? fx)
275  (%check-fixnum 'fxodd? fx)
276  (%fx= 1 (%fxand fx 1)) )
277
278(define (fxeven? fx)
279  (%check-fixnum 'fxeven? fx)
280  (%fx= 0 (%fxand fx 1)) )
281
282
283;;;
284
285(define (fxabs fx)
286  (%check-fixnum 'fxabs fx)
287  (if (%fx< fx 0) (%fxneg fx)
288      fx ) )
289
290(define (fxdiv fxn fxd)
291  (%check-fixnum 'fxdiv fxn)
292  (%check-fixnum 'fxdiv fxd)
293  (%check-zero-division 'fxdiv fxn fxd)
294  (%fx/ fxn fxd) )
295
296(define (fxdiv-and-mod fxn fxd)
297  (%check-fixnum 'fxdiv-and-mod fxn)
298  (%check-fixnum 'fxdiv-and-mod fxd)
299  (%check-zero-division 'fxdiv fxn fxd)
300  (values (%fx/ fxn fxd) (%fxmod fxn fxd)) )
301
302(define (fxdiv0 fxn fxd)
303  (%check-fixnum 'fxdiv0 fxn)
304  (%check-fixnum 'fxdiv0 fxd)
305  (%check-zero-division 'fxdiv0 fxn fxd)
306  (let ((d (%fxdiv0 fxn fxd)))
307    (if (%fixnum? d) d
308        (%fixnum-representation-error 'fxdiv0 fxn fxd) ) ) )
309
310(define (fxmod0 fxn fxd)
311  (%check-fixnum 'fxmod0 fxn)
312  (%check-fixnum 'fxmod0 fxd)
313  (%check-zero-division 'fxmod0 fxn fxd)
314  (let ((m (%fxmod0 fxn fxd)))
315    (if (%fixnum? m) m
316        (%fixnum-representation-error 'fxmod0 fxn fxd) ) ) )
317
318(define (fxdiv0-and-mod0 fxn fxd)
319  (%check-fixnum 'fxdiv0-and-mod0 fxn)
320  (%check-fixnum 'fxdiv0-and-mod0 fxd)
321  (%check-zero-division 'fxdiv0-and-mod0 fxn fxd)
322  (let-values (((d m) (%fxdiv0-and-mod0 fxn fxd)))
323    (if (and (%fixnum? d) (%fixnum? m)) (values d m)
324        (%fixnum-representation-error 'fxdiv0-and-mod0 fxn fxd) ) ) )
325
326(define (fx*/carry fx1 fx2 fx3)
327  (%check-fixnum 'fx*/carry fx1)
328  (%check-fixnum 'fx*/carry fx2)
329  (%check-fixnum 'fx*/carry fx3)
330  (let ((res (%fx+ (%fx* fx1 fx2) fx3)))
331    (values res (%arithmetic-shift (%+ (%* fx1 fx2) (%- fx3 res)) *fixnum-negated-precision*) ) ) )
332
333(define (fx+/carry fx1 fx2 fx3)
334  (%check-fixnum 'fx+/carry fx1)
335  (%check-fixnum 'fx+/carry fx2)
336  (%check-fixnum 'fx+/carry fx3)
337  (let ((res (%fx+ (%fx+ fx1 fx2) fx3)))
338    (values res (%arithmetic-shift (%+ (%+ fx1 fx2) (%- fx3 res)) *fixnum-negated-precision*) ) ) )
339
340(define (fx-/carry fx1 fx2 fx3)
341  (%check-fixnum 'fx-/carry fx1)
342  (%check-fixnum 'fx-/carry fx2)
343  (%check-fixnum 'fx-/carry fx3)
344  (let ((res (%fx- (%fx- fx1 fx2) fx3)))
345    (values res (%arithmetic-shift (%- (%- fx1 fx2) (%+ res fx3)) *fixnum-negated-precision*) ) ) )
346
347(define (fxadd1 fx)
348  (%check-fixnum 'fxadd1 fx)
349  (%fx+ fx 1) )
350
351(define (fxsub1 fx)
352  (%check-fixnum 'fxsub1 fx)
353  (%fx- fx 1) )
354
355(define (fxquotient fxn fxd)
356  (%check-fixnum 'fxquotient fxn)
357  (%check-fixnum 'fxquotient fxd)
358  (%check-zero-division 'fxquotient fxn fxd)
359  (%fx/ fxn fxd) )
360
361(define (fxremainder fxn fxd)
362  (%check-fixnum 'fxremainder fxn)
363  (%check-fixnum 'fxremainder fxd)
364  (%check-zero-division 'fxremainder fxn fxd)
365  (%fx- fxn (%fx* (%fx/ fxn fxd) fxd)) )
366
367(define (fxmodulo fxn fxd)
368  (%check-fixnum 'fxmodulo fxn)
369  (%check-fixnum 'fxmodulo fxd)
370  (%check-zero-division 'fxmodulo fxn fxd)
371  (%fxmod fxn fxd) )
372
373(define (fxarithmetic-shift fx amount)
374  (%check-fixnum 'fxarithmetic-shift fx)
375  (%check-fixnum 'fxarithmetic-shift amount)
376  (if (%fx< 0 amount) (%fxshr fx (%fxneg amount))
377      (%fxshl fx amount) ) )
378
379(define (fxarithmetic-shift-left fx amount)
380  (%check-fixnum 'fxarithmetic-shift-left fx)
381  (%check-non-negative-fixnum 'fxarithmetic-shift-left amount)
382  (%fxshl fx amount) )
383
384(define (fxarithmetic-shift-right fx amount)
385  (%check-fixnum 'fxarithmetic-shift-right fx)
386  (%check-non-negative-fixnum 'fxarithmetic-shift-right amount)
387  (%fxshr fx amount) )
388
389(define (fx- fx . maybe-fx)
390  (%check-fixnum 'fx- fx)
391  (if (%null? maybe-fx) (%fxneg fx)
392      (let ((fx2 (%car maybe-fx)))
393        (%check-fixnum 'fx- fx2)
394        (%fx- fx fx2) ) ) )
395
396
397;;;
398
399(define (fxand fx . fxs)
400  (%fxfold-1 'fxand *fxand fx fxs) )
401
402(define (fxior fx . fxs)
403  (%fxfold-1 'fxior *fxior fx fxs) )
404
405(define (fxxor fx . fxs)
406  (%fxfold-1 'fxxor *fxxor fx fxs) )
407
408
409;;;
410
411(define (fxif mask true false)
412  (%check-fixnum 'fxif mask)
413  (%check-fixnum 'fxif true)
414  (%check-fixnum 'fxif false)
415  (*bitwise-if mask true false) )
416
417(define (fxbit-count fx)
418  (%check-fixnum 'fxbit-count fx)
419  (*bitwise-bit-count fx) )
420
421(define (fxlength fx)
422  (%check-fixnum 'fxlength fx)
423  (*bitwise-length fx) )
424
425(define (fxfirst-bit-set fx)
426  (%check-fixnum 'fxfirst-bit-set fx)
427  (*bitwise-first-bit-set fx) )
428
429(define (fxlast-bit-set fx)
430  (%check-fixnum 'fxlast-bit-set fx)
431  (*bitwise-last-bit-set fx) )
432
433(define (fxbit-set? fx index)
434  (%check-fixnum 'fxbit-set? fx)
435  (%check-non-negative-fixnum 'fxbit-set? index)
436  (%check-fixnum-bits 'fxbit-set? index)
437  (*bitwise-bit-set? fx index) )
438
439(define (fxcopy-bit fx index bit)
440  (%check-fixnum 'fxcopy-bit fx)
441  (%check-non-negative-fixnum 'fxcopy-bit index)
442  (%check-fixnum-bits 'fxcopy-bit index)
443  (%check-fixnum 'fxcopy-bit bit)
444  (*bitwise-copy-bit fx index bit) )
445
446(define (fxbit-field fx start end)
447  (%check-fixnum 'fxbit-field fx)
448  (%check-non-negative-fixnum 'fxbit-field start)
449  (%check-non-negative-fixnum 'fxbit-field end)
450  (%check-fixnum<= 'fxbit-field start end)
451  (%check-fixnum-bits 'fxbit-field start)
452  (%check-fixnum-bits+1 'fxbit-field end)
453  (*bitwise-bit-field fx start end) )
454
455(define (fxcopy-bit-field fxto start end fxfrom)
456  (%check-fixnum 'fxcopy-bit-field fxto)
457  (%check-non-negative-fixnum 'fxcopy-bit-field start)
458  (%check-non-negative-fixnum 'fxcopy-bit-field end)
459  (%check-fixnum<= 'fxcopy-bit-field start end)
460  (%check-fixnum-bits 'fxcopy-bit-field start)
461  (%check-fixnum-bits+1 'fxcopy-bit-field end)
462  (%check-fixnum 'fxcopy-bit-field fxfrom)
463  (*bitwise-copy-bit-field fxto start end fxfrom) )
464
465(define (fxrotate-bit-field fx start end count)
466  (%check-fixnum 'fxrotate-bit-field fx)
467  (%check-non-negative-fixnum 'fxrotate-bit-field start)
468  (%check-non-negative-fixnum 'fxrotate-bit-field end)
469  (%check-fixnum<= 'fxrotate-bit-field start end)
470  (%check-fixnum-bits 'fxrotate-bit-field start)
471  (%check-fixnum-bits+1 'fxrotate-bit-field end)
472  (%check-non-negative-fixnum 'fxrotate-bit-field count)
473  (unless (%fx<= count (%fx- end start))
474    (##sys#signal-hook #:bounds-error 'fxrotate-bit-field "outside of interval" count start end) )
475  (*bitwise-rotate-bit-field fx start end count) )
476
477(define (fxreverse-bit-field fx start end)
478  (%check-fixnum 'fxreverse-bit-field fx)
479  (%check-non-negative-fixnum 'fxreverse-bit-field start)
480  (%check-non-negative-fixnum 'fxreverse-bit-field end)
481  (%check-fixnum<= 'fxreverse-bit-field start end)
482  (%check-fixnum-bits 'fxreverse-bit-field start)
483  (%check-fixnum-bits+1 'fxreverse-bit-field end)
484  (*bitwise-reverse-bit-field fx start end) )
485
486
487;;; Extras
488
489(define fixnum->string
490  (let ((digits "0123456789ABCDEF"))
491    (lambda (fx #!optional (radix 10))
492      (define (fx-digits fx from to)
493        (if (%fx= 0 fx) (values (%make-string from #\#) to)
494            (let* ((quo (%fx/ fx radix))
495                   (digit (%string-ref digits (%fx- fx (%fx* quo radix)))))
496              (let-values (((str to) (fx-digits quo (%fx+ from 1) to)))
497                (%string-set! str to digit)
498                (values str (%fx+ to 1)) ) ) ) )
499      (define (fx->str fx)
500        (cond ((%fx= 0 fx)
501               (%make-string 1 #\0))
502              ((%fx< 0 fx)
503               (let ((str (fx-digits fx 0 0)))
504                 (noop str) ; force reference
505                 str ) )
506              ((%fx= most-negative-fixnum fx)
507               (%string-append (fx->str (%fx/ fx radix)) (fx->str (%fx- radix (%fxmod fx radix)))) )
508              (else
509               (let ((str (fx-digits (%fxneg fx) 1 1)))
510                 (%string-set! str 0 #\-)
511                 str ) ) ) )
512      (%check-fixnum 'fixnum->string fx)
513      (case radix
514        ((2 8 10 16)
515          (fx->str fx))
516        (else
517          (##sys#signal-hook #:type-error 'fixnum->string "bad argument type - invalid radix" radix) ) ) ) ) )
518
519(define (fxif-not mask true false)
520  (%check-fixnum 'fxif-not mask)
521  (%check-fixnum 'fxif-not true)
522  (%check-fixnum 'fxif-not false)
523  (*bitwise-if-not mask true false) )
524
525(define (fxnegate fx)
526  (%check-fixnum 'fxnegate fx)
527  (%fxneg fx) )
528
529(define (fxpow2log2 fx)
530  (%check-fixnum 'fxpow2log2 fx)
531  (*pow2log2 fx) )
532
533(define (fx-# fx . fxs)
534  (%check-fixnum 'fx-# fx)
535  (if (%null? fxs) (%fxneg fx)
536      (%fxfold-1 'fx-# *fx- fx fxs) ) )
537
538(define (fx+# fx . fxs)
539  (%check-fixnum 'fx+# fx)
540  (if (%null? fxs) fx
541      (%fxfold-1 'fx+# *fx+ fx fxs) ) )
542
543(define (fx*# fx . fxs)
544  (%check-fixnum 'fx*# fx)
545  (if (%null? fxs) fx
546      (%fxfold-1 'fx*# *fx* fx fxs) ) )
547
548(define (fx/# fx . fxs)
549  (%check-fixnum 'fx/# fx)
550  (if (%null? fxs) fx
551      (%fxfold-1 'fx/# *fx/ fx fxs) ) )
552
553) ;module err5rs-arithmetic-fixnums
Note: See TracBrowser for help on using the repository browser.