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

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

Save.

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