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

Last change on this file since 13651 was 13651, checked in by Kon Lovett, 11 years ago

Rmvd no-unbound-checks.

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