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

Last change on this file was 26757, checked in by Kon Lovett, 8 years ago

Save

File size: 25.0 KB
Line 
1;;;; err5rs-arithmetic-fixnums.scm
2;;;; Kon Lovett, Mar '09
3
4;; Issues
5;;
6;; - No support for the full-numeric-tower. All operations upon core numerics.
7
8;;;
9
10#>
11#define C_WORD_WIDT (C_WORD_SIZE - 1)
12#define C_WORD_PREC (C_WORD_SIZE - (1 + 1))
13
14#if 0
15#define C_WORD_ADD_INVP( si1, si2 ) \
16  (((si1 ^ si2) | (((si1 ^ (~(si1 ^ si2) & (1 << C_WORD_PREC))) + si2) ^ si2)) >= 0)
17#else
18#define C_WORD_ADD_INVP( si1, si2 ) \
19   ( (si1 > 0 && si2 > 0 && si1 > (C_MOST_POSITIVE_FIXNUM - si2)) \
20  || (si1 < 0 && si2 < 0 && si1 < (C_MOST_NEGATIVE_FIXNUM - si2)) )
21#endif
22
23#if 0
24#define C_WORD_SUB_INVP( si1, si2 ) \
25  (((si1 ^ si2) & (((si1 ^ ((si1 ^ si2) & (1 << C_WORD_PREC))) - si2) ^ si2)) < 0)
26#else
27#define C_WORD_SUB_INVP( si1, si2 ) \
28  C_WORD_ADD_INVP( si1, (-si2) )
29#endif
30
31#define C_WORD_MUL_INVP( si1, si2 ) \
32  ((si1 > 0) \
33     ? ((si2 > 0) \
34         ? (si1 > (C_MOST_POSITIVE_FIXNUM / si2)) \
35         : (si2 < (C_MOST_NEGATIVE_FIXNUM / si1))) \
36     : ((si2 > 0) \
37         ? (si1 < (C_MOST_NEGATIVE_FIXNUM / si2)) \
38         : ((si1 != 0) && (si2 < (C_MOST_POSITIVE_FIXNUM / si1)))))
39
40#define C_WORD_DIV_INVP( si1, si2 ) \
41  ((si1 == ((C_word) C_MOST_NEGATIVE_FIXNUM)) && (si2 == ((C_word) -1)))
42<#
43
44;;;
45
46(module err5rs-arithmetic-fixnums
47
48  (;export
49    ;; ERR5RS
50    representation-violation? zero-division-violation?
51    ;fixnum? - from chicken
52    fixnum-width least-fixnum greatest-fixnum
53    fx=? fx<? fx>? fx<=? fx>=?
54    fxzero? fxpositive? fxnegative? fxodd? fxeven?
55    fxmax fxmin fxmax-and-min
56    fxdiv fxmod fxdiv-and-mod
57    fxdiv0 fxmod0 fxdiv0-and-mod0
58    fx*/carry fx+/carry fx-/carry
59    fxarithmetic-shift fxarithmetic-shift-left fxarithmetic-shift-right
60    fx+ fx- fx*
61    fxnot fxand fxior fxxor
62    fxif
63    fxbit-count
64    fxlength
65    fxfirst-bit-set
66    fxbit-set?
67    fxcopy-bit
68    fxbit-field
69    fxcopy-bit-field
70    fxrotate-bit-field
71    fxreverse-bit-field
72    ;; Originals
73    chicken:fxmax chicken:fxmin
74    chicken:fxnot chicken:fxand chicken:fxior chicken:fxxor
75    chicken:fx+ chicken:fx- chicken:fx* chicken:fx/ chicken:fxmod
76    chicken:fxodd? chicken:fxeven?
77    ;; Extras
78    fx<>?
79    fxcompare
80    fxabs
81    fxnegate
82    fxadd1 fxsub1
83    fx/ fxquotient fxremainder
84    fxpow2log2
85    fxif-not
86    fxlast-bit-set
87    fixnum->string
88    ;; Macros
89    ($fx=? -fx=) ($fx<? -fx<) ($fx>? -fx>) ($fx<=? -fx<=) ($fx>=? -fx>=) ($fx<>? -fx<>)
90    ($fxmax -fxmax) ($fxmin -fxmin)
91    ($fx- -fx-) ($fx+ -fx+) ($fx* -fx*) ($fx/ -fx/)
92    ($fxand -fxand) ($fxior -fxior) ($fxxor -fxxor))
93
94  (import
95    scheme
96    (rename chicken
97      (fxodd? chicken:fxodd?)
98      (fxeven? chicken:fxeven?)
99      (fxmax chicken:fxmax)
100      (fxmin chicken:fxmin)
101      (fxnot chicken:fxnot)
102      (fxand chicken:fxand)
103      (fxior chicken:fxior)
104      (fxxor chicken:fxxor)
105      (fx+ chicken:fx+)
106      (fx- chicken:fx-)
107      (fx* chicken:fx*)
108      (fx/ chicken:fx/)
109      (fxmod chicken:fxmod))
110    foreign
111    data-structures
112    condition-utils
113    (only type-errors error-fixnum)
114    (only err5rs-arithmetic-bitwise
115      *bitwise-if *bitwise-if-not
116      *bitwise-bit-count *bitwise-length
117      *bitwise-first-bit-set *bitwise-last-bit-set
118      *bitwise-bit-set? *bitwise-copy-bit
119      *bitwise-bit-field *bitwise-copy-bit-field
120      *bitwise-rotate-bit-field *bitwise-reverse-bit-field
121      *pow2log2))
122
123  (require-library
124    data-structures
125    condition-utils type-errors err5rs-arithmetic-bitwise)
126
127;;; Prelude
128
129(declare
130  (disable-interrupts)
131  (bound-to-procedure
132    ##sys#signal-hook
133    ##sys#string-append ) )
134
135;;
136
137(include "chicken-primitive-object-inlines")
138(include "inline-type-checks")
139
140;;;
141
142;; Argument checking
143
144(cond-expand
145  (unsafe
146
147    (define-inline (%check-fixnum-shift-amount loc obj) (begin))
148    (define-inline (%check-fixnum-bounds-order loc start end) (begin))
149    (define-inline (%check-fixnum-range loc lfx fx hfx) (begin))
150    (define-inline (%check-word-bits-range loc obj) (begin))
151    (define-inline (%check-bits-range loc start end) (begin))
152    (define-inline (%check-fixnum-bits-count loc obj start end) (begin))
153    (define-inline (%check-zero-division loc fx1 fx2) (begin)) )
154
155  (else
156
157    (define-inline (%check-fixnum-shift-amount loc obj)
158      (%check-fixnum loc obj)
159      (unless (let ((amt (if (%fxnegative? obj) (%fxneg obj) obj)))
160                (%fxclosed? 0 amt fixnum-precision))
161        (error-shift-amount loc obj) ) )
162
163    (define-inline (%check-fixnum-bounds-order loc start end)
164      (unless (%fx<= start end) (error-bounds-order loc start end)) )
165
166    (define-inline (%check-fixnum-range loc lfx fx hfx)
167      (unless (%fxclosed? lfx fx hfx) (error-outside-range loc fx lfx hfx)) )
168
169    (define-inline (%check-word-bits-range loc obj)
170      (%check-fixnum loc obj)
171      (%check-fixnum-range loc 0 obj fixnum-precision))
172
173    (define-inline (%check-bits-range loc start end)
174      (%check-fixnum loc start)
175      (%check-fixnum loc end)
176      (%check-fixnum-bounds-order loc start end)
177      ; Inclusive start
178      (%check-fixnum-range loc 0 start fixnum-precision)
179      ; Exclusive end
180      (%check-fixnum-range loc 0 end fixnum-width) )
181
182    (define-inline (%check-fixnum-bits-count loc obj start end)
183      (unless (and (%fixnum? obj) (%fxcardinal? obj)) (error-negative-count loc obj))
184      (unless (%fx< obj (%fx- end start)) (error-bits-count loc obj start end)) )
185
186    (define-inline (%check-zero-division loc fx1 fx2)
187      (when (%fxzero? fx2) (error-zero-division loc fx1 fx2)) ) ) )
188
189;; Fold operations
190
191;Note - argument order is (func acc cur) & not (func cur acc) as in (fold func).
192
193(define-inline (%fxfold loc func init ls)
194  (let loop ((ls ls) (acc init))
195    (if (%null? ls) acc
196      (loop (%cdr ls) (func acc (%car ls))) ) ) )
197
198(define-inline (%fxand-fold loc func init ls)
199  (let loop ((ls ls) (acc init))
200    (or (%null? ls)
201        (let ((cur (%car ls)))
202          (and (func acc cur)
203               (loop (%cdr ls) cur) ) ) ) ) )
204
205;; Arithmetic
206
207;;
208
209(define-inline (%fxdiv/int fxn fxd)
210  (let ((quo (%fx/ fxn fxd)))
211    (cond
212      ((%fx<= (%fx* quo fxd) fxn) quo)
213      ((%fxnegative? fxd)         (%fxadd1 quo))
214      (else                       (%fxsub1 quo)) )
215    #;
216    (cond
217      ((%fxnegative? fxn)
218        (if (%fxnegative? fxd) (%fxadd1 quo)
219          (%fxsub1 quo) ) )
220      ((%fxnegative? fxd)
221        (if (%fxnegative? fxn) (%fxadd1 quo)
222          quo ) )
223      (else
224        quo ) ) ) )
225
226(define-inline (%fxmod/int fxn fxd)
227  #;
228  (let* ((quo (%fx/ fxn fxd))
229         (rem (%fx- fxn (%fx* quo fxd))) )
230    (cond
231      ((%fxcardinal? rem) rem)
232      ((%fxnegative? fxd) (%fx+ rem fxd))
233      (else               (%fx- rem fxd)) ) )
234  (%fxmod fxn (or (and (%fxnegative? fxd) (not (%fx= most-positive-fixnum fxd))
235                       (%fxneg fxd))
236              fxd)) )
237
238(define-inline (%fxdiv-and-mod/int fxn fxd)
239  (let* ((quo (%fx/ fxn fxd))
240         (rem (%fx- fxn (%fx* quo fxd))) )
241    (cond
242      ((%fxcardinal? rem) (values quo rem))
243      ((%fxnegative? fxd) (values (%fxadd1 quo) (%fx+ rem fxd)))
244      (else               (values (%fxsub1 quo) (%fx- rem fxd))) ) ) )
245
246;;
247
248(define-inline (%fxdiv0 fxn fxd)
249  (let* ((quo (%quotient fxn fxd))
250         (rem (%- fxn (%* quo fxd))))
251    (cond
252      ((%<= 0 fxd)
253        (if (%<= fxd (%* rem 2)) (%add1 quo)
254          (if (%<= (%* rem -2) fxd) quo
255            (%sub1 quo) ) ) )
256      ((%< fxd (%* rem -2))
257        (if (%<= fxd (%* rem 2)) quo
258          (%add1 quo) ) )
259      (else
260        (%sub1 quo) ) ) ) )
261
262(define-inline (%fxmod0 fxn fxd)
263  (let* ((quo (%quotient fxn fxd))
264         (rem (%- fxn (%* quo fxd))))
265    (cond
266      ((%<= 0 fxd)
267        (if (%<= fxd (%* rem 2)) (%- rem fxd)
268          (if (%<= (%* rem -2) fxd) rem
269            (%+ rem fxd) ) ) )
270      ((%< fxd (%* rem -2))
271        (if (%<= fxd (%* rem 2)) rem
272          (%- rem fxd) ) )
273      (else
274        (%+ rem fxd) ) ) ) )
275
276(define-inline (%fxdiv0-and-mod0 fxn fxd)
277  (let* ((quo (%quotient fxn fxd))
278         (rem (%- fxn (%* quo fxd))))
279    (cond
280      ((%<= 0 fxd)
281        (if (%<= fxd (%* rem 2)) (values (%add1 quo) (%- rem fxd))
282          (if (%<= (%* rem -2) fxd) (values quo rem)
283            (values (%sub1 quo) (%+ rem fxd)) ) ) )
284      ((%< fxd (%* rem -2))
285        (if (%<= fxd (%* rem 2)) (values quo rem)
286          (values (%add1 quo) (%- rem fxd)) ) )
287      (else
288        (values (%sub1 quo) (%+ rem fxd)) ) ) ) )
289
290;;
291
292;invariant - (fixnum? (floor (* fx (expt 2 amt))))
293; shl: msb + amt <= fixnum-precision
294; shr: msb - amt >= 0
295;
296; We know that amt is-a fixnum in [0 fixnum-precision] by now
297
298(define-inline (%fxshl/check loc fx amt)
299  (if (%fxzero? amt) fx
300    (%fxshl fx amt)
301    #; ;invariant broken
302    (let ((bits (%fx+ (*bitwise-last-bit-set fx) amt)))
303      (cond ((%fx<= bits fixnum-precision) (%fxshl fx amt))
304            (else
305             (error-fixnum-representation loc fx amt) ) ) ) ) )
306
307(define-inline (%fxshr/check loc fx amt)
308  (if (%fxzero? amt) fx
309    (%fxshr fx amt)
310    #; ;invariant broken
311    (let ((bits (%fx- (*bitwise-last-bit-set fx) amt)))
312      (cond ((%fx>= bits 0) (%fxshr fx amt))
313            (else
314             (error-fixnum-representation loc fx amt) ) ) ) ) )
315
316;;
317
318(define-inline (%fxdiv/check loc fxn fxd)
319  (%check-fixnum loc fxn)
320  (%check-fixnum loc fxd)
321  (%check-zero-division loc fxn fxd)
322  (when (invalid-division? fxn fxd) (error-fixnum-representation loc fxn fxd))
323  (%fxdiv/int fxn fxd) )
324
325;;; Conditions
326
327(define (make-arithmetic-condition loc msg args . cnds)
328  (apply make-exn-condition+ loc msg args 'arithmetic cnds) )
329
330; &assertion
331(define (make-zero-division-condition loc fx1 fx2)
332  (make-arithmetic-condition loc "division by zero" (list fx1 fx2) 'division) )
333
334; &implementation-restriction
335(define (make-fixnum-representation-condition loc args)
336  (make-arithmetic-condition loc "result not representable as fixnum" args 'representation) )
337
338; &assertion
339(define zero-division-violation? (make-condition-predicate arithmetic division))
340
341; &implementation-restriction
342(define representation-violation? (make-condition-predicate arithmetic representation))
343
344;;; Errors
345
346(cond-expand
347  (unsafe
348
349    (define (error-radix loc radix) (begin))
350    (define (error-fixnum-representation loc . args) (begin)) )
351
352  (else
353
354    (define (error-radix loc radix)
355      (##sys#signal-hook #:type-error loc "bad argument type - invalid radix" radix) )
356
357    (define (error-outside-range loc obj low high)
358      (##sys#signal-hook #:bounds-error loc "out of range" obj low high) )
359
360    (define (error-bounds-order loc start end)
361      (##sys#signal-hook #:bounds-error loc "bounds reversed" start end) )
362
363    (define (error-negative-count loc count)
364      (##sys#signal-hook #:bounds-error loc "cannot be negative" count) )
365
366    (define (error-bits-count loc count start end)
367      (##sys#signal-hook #:bounds-error loc "too many bits for interval" count start end) )
368
369    (define (error-shift-amount loc amt)
370      (##sys#signal-hook #:bounds-error loc "invalid shift amount" amt) )
371
372    (define (error-zero-division loc fx1 fx2)
373      (abort (make-zero-division-condition loc fx1 fx2)) )
374
375    (define (error-fixnum-representation loc . args)
376      (abort (make-fixnum-representation-condition loc args)) ) ) )
377
378;;; Procedures wrapping primitive-inlines for fold operations
379
380(define (-fx= x y)
381  (%check-fixnum 'fx= x)
382  (%check-fixnum 'fx= y)
383  (%fx= x y) )
384
385(define (-fx< x y)
386  (%check-fixnum 'fx< x)
387  (%check-fixnum 'fx< y)
388  (%fx< x y) )
389
390(define (-fx> x y)
391  (%check-fixnum 'fx> x)
392  (%check-fixnum 'fx> y)
393  (%fx> x y) )
394
395(define (-fx>= x y)
396  (%check-fixnum 'fx>= x)
397  (%check-fixnum 'fx>= y)
398  (%fx>= x y) )
399
400(define (-fx<= x y)
401  (%check-fixnum 'fx<= x)
402  (%check-fixnum 'fx<= y)
403  (%fx<= x y) )
404
405(define (-fx<> x y)
406  (%check-fixnum 'fx<> x)
407  (%check-fixnum 'fx<> y)
408  (not (%fx= x y)) )
409
410(define (-fxmax x y)
411  (%check-fixnum 'fxmax x)
412  (%check-fixnum 'fxmax y)
413  (%fxmax x y) )
414
415(define (-fxmin x y)
416  (%check-fixnum 'fxmin x)
417  (%check-fixnum 'fxmin y)
418  (%fxmin x y) )
419
420(define (-fxand x y)
421  (%check-fixnum 'fxand x)
422  (%check-fixnum 'fxand y)
423  (%fxand x y) )
424
425(define (-fxior x y)
426  (%check-fixnum 'fxior x)
427  (%check-fixnum 'fxior y)
428  (%fxior x y) )
429
430(define (-fxxor x y)
431  (%check-fixnum 'fxxor x)
432  (%check-fixnum 'fxxor y)
433  (%fxxor x y) )
434
435;;
436
437(define fxcarry-bit (foreign-lambda* int ((integer64 x)) "return( x >> C_WORD_WIDT );"))
438
439(define fx+/carry-result
440  (foreign-lambda* int ((int si1) (int si2) (int si3)) "return( si1 + si2 + si3 );"))
441(define fx-/carry-result
442  (foreign-lambda* int ((int si1) (int si2) (int si3)) "return( si1 - si2 - si3 );"))
443(define fx*/carry-result
444  (foreign-lambda* int ((int si1) (int si2) (int si3)) "return( si1 * si2 + si3 );"))
445
446;;
447
448(define invalid-sum?
449  (foreign-lambda* bool ((int si1) (int si2)) "return( C_WORD_ADD_INVP( si1, si2 ) );"))
450(define invalid-difference?
451  (foreign-lambda* bool ((int si1) (int si2)) "return( C_WORD_SUB_INVP( si1, si2 ) );"))
452(define invalid-product?
453  (foreign-lambda* bool ((int si1) (int si2)) "return( C_WORD_MUL_INVP( si1, si2 ) );"))
454
455
456THIS IS A BUG - 'int' should suffice.
457
458
459(define invalid-division?
460  (foreign-lambda* bool ((integer64 si1) (integer64 si2)) "return( C_WORD_DIV_INVP( si1, si2 ) );"))
461
462;;
463
464(define (-fx+ x y)
465  (%check-fixnum 'fx+ x)
466  (%check-fixnum 'fx+ y)
467  (when (invalid-sum? x y) (error-fixnum-representation 'fx+ x y))
468  (%fx+ x y) )
469
470(define (-fx- x #!optional y)
471  (%check-fixnum 'fx- x)
472  (cond (y
473         (%check-fixnum 'fx- y)
474         (when (invalid-difference? x y) (error-fixnum-representation 'fx- x y))
475         (%fx- x y) )
476        ((%fx= x most-negative-fixnum)
477         (error-fixnum-representation 'fx- x) ) ;R6RS says raise &assertion but unsymmetrical
478        (else
479         (%fxneg x) ) ) )
480
481(define (-fx* x y)
482  (%check-fixnum 'fx* x)
483  (%check-fixnum 'fx* y)
484  (when (invalid-product? x y) (error-fixnum-representation 'fx* x y))
485  (%fx* x y) )
486
487(define (-fx/ x y) (%fxdiv/check 'fx/ x y))
488
489;;; ERR5RS
490
491;;
492
493(define (fixnum-width) fixnum-bits)
494(define (least-fixnum) most-negative-fixnum)
495(define (greatest-fixnum) most-positive-fixnum)
496
497;;
498
499(define (fx=? fx . fxs) (%fxand-fold 'fx=? -fx= fx fxs))
500(define (fx<? fx . fxs) (%fxand-fold 'fx<? -fx< fx fxs))
501(define (fx>? fx . fxs) (%fxand-fold 'fx>? -fx> fx fxs))
502(define (fx<=? fx . fxs) (%fxand-fold 'fx<=? -fx<= fx fxs))
503(define (fx>=? fx . fxs) (%fxand-fold 'fx>=? -fx>= fx fxs))
504
505(define (fxmax fx . fxs) (%fxfold 'fxmax -fxmax fx fxs))
506(define (fxmin fx . fxs) (%fxfold 'fxmin -fxmin fx fxs))
507
508(define (fxmax-and-min fx . fxs)
509  (%check-fixnum 'fxmax-and-min fx)
510  (let loop ((fxs fxs) (mx fx) (mn fx))
511    (if (%null? fxs) (values mx mn)
512        (let ((cur (%car fxs)))
513          (%check-fixnum 'fxmax-and-min cur)
514          (loop (%cdr fxs) (%fxmax mx cur) (%fxmin mn cur)) ) ) ) )
515
516;;
517
518(define (fxnot fx)
519  (%check-fixnum 'fxnot fx)
520  (%fxnot fx) )
521
522(define (fxand fx . fxs) (%fxfold 'fxand -fxand fx fxs))
523(define (fxior fx . fxs) (%fxfold 'fxior -fxior fx fxs))
524(define (fxxor fx . fxs) (%fxfold 'fxxor -fxxor fx fxs))
525
526;;
527
528(define (fxzero? fx)
529  (%check-fixnum 'fxzero? fx)
530  (%fxzero? fx) )
531
532(define (fxpositive? fx)
533  (%check-fixnum 'fxpositive? fx)
534  (%fxpositive? fx) )
535
536(define (fxnegative? fx)
537  (%check-fixnum 'fxnegative? fx)
538  (%fxnegative? fx) )
539
540(define (fxodd? fx)
541  (%check-fixnum 'fxodd? fx)
542  (%fxodd? fx) )
543
544(define (fxeven? fx)
545  (%check-fixnum 'fxeven? fx)
546  (%fxeven? fx) )
547
548;;
549
550(define fx+ -fx+)
551(define fx- -fx-)
552(define fx* -fx*)
553(define (fxdiv fxn fxd) (%fxdiv/check 'fxdiv fxn fxd))
554
555(define (fxmod fxn fxd)
556  (%check-fixnum 'fxmod fxn)
557  (%check-fixnum 'fxmod fxd)
558  (%check-zero-division 'fxmod fxn fxd)
559  (%fxmod/int fxn fxd) )
560
561(define (fxdiv-and-mod fxn fxd)
562  (%check-fixnum 'fxdiv-and-mod fxn)
563  (%check-fixnum 'fxdiv-and-mod fxd)
564  (%check-zero-division 'fxdiv fxn fxd)
565  (when (invalid-division? fxn fxd) (error-fixnum-representation 'fxdiv-and-mod fxn fxd))
566  (%fxdiv-and-mod/int fxn fxd) )
567
568;;
569
570(define (fxdiv0 fxn fxd)
571  (%check-fixnum 'fxdiv0 fxn)
572  (%check-fixnum 'fxdiv0 fxd)
573  (%check-zero-division 'fxdiv0 fxn fxd)
574  (when (invalid-division? fxn fxd) (error-fixnum-representation 'fxdiv0 fxn fxd))
575  (let ((d (%fxdiv0 fxn fxd)))
576    (if (%fixnum? d) d
577        (error-fixnum-representation 'fxdiv0 fxn fxd) ) ) )
578
579(define (fxmod0 fxn fxd)
580  (%check-fixnum 'fxmod0 fxn)
581  (%check-fixnum 'fxmod0 fxd)
582  (%check-zero-division 'fxmod0 fxn fxd)
583  (when (invalid-division? fxn fxd) (error-fixnum-representation 'fxmod0 fxn fxd))
584  (let ((m (%fxmod0 fxn fxd)))
585    (if (%fixnum? m) m
586        (error-fixnum-representation 'fxmod0 fxn fxd) ) ) )
587
588(define (fxdiv0-and-mod0 fxn fxd)
589  (%check-fixnum 'fxdiv0-and-mod0 fxn)
590  (%check-fixnum 'fxdiv0-and-mod0 fxd)
591  (%check-zero-division 'fxdiv0-and-mod0 fxn fxd)
592  (when (invalid-division? fxn fxd) (error-fixnum-representation 'fxdiv0-and-mod0 fxn fxd))
593  (let-values (((d m) (%fxdiv0-and-mod0 fxn fxd)))
594    (if (and (%fixnum? d) (%fixnum? m)) (values d m)
595        (error-fixnum-representation 'fxdiv0-and-mod0 fxn fxd) ) ) )
596
597;;
598
599(define (fx+/carry fx1 fx2 fx3)
600  (%check-fixnum 'fx+/carry fx1)
601  (%check-fixnum 'fx+/carry fx2)
602  (%check-fixnum 'fx+/carry fx3)
603  (let ((res (fx+/carry-result fx1 fx2 fx3)))
604    #;(unless (%fixnum? res) (error-fixnum-representation 'fx+/carry fx1 fx2 fx3))
605    (values res (fxcarry-bit (%+ (%+ fx1 fx2) (%- fx3 res)))) ) )
606
607(define (fx-/carry fx1 fx2 fx3)
608  (%check-fixnum 'fx-/carry fx1)
609  (%check-fixnum 'fx-/carry fx2)
610  (%check-fixnum 'fx-/carry fx3)
611  (let ((res (fx-/carry-result fx1 fx2 fx3)))
612    #;(unless (%fixnum? res) (error-fixnum-representation 'fx-/carry fx1 fx2 fx3))
613    (values res (fxcarry-bit (%- (%- fx1 fx2) (%+ res fx3)))) ) )
614
615(define (fx*/carry fx1 fx2 fx3)
616  (%check-fixnum 'fx*/carry fx1)
617  (%check-fixnum 'fx*/carry fx2)
618  (%check-fixnum 'fx*/carry fx3)
619  (let ((res (fx*/carry-result fx1 fx2 fx3)))
620    #;(unless (%fixnum? res) (error-fixnum-representation 'fx*/carry fx1 fx2 fx3))
621    (values res (fxcarry-bit (%+ (%* fx1 fx2) (%- fx3 res)))) ) )
622
623;;
624
625(define (fxarithmetic-shift fx amount)
626  (%check-fixnum 'fxarithmetic-shift fx)
627  (%check-fixnum-shift-amount 'fxarithmetic-shift amount)
628  (if (%fxnegative? amount) (%fxshr/check 'fxarithmetic-shift fx (%fxneg amount))
629      (%fxshl/check 'fxarithmetic-shift fx amount) ) )
630
631(define (fxarithmetic-shift-left fx amount)
632  (%check-fixnum 'fxarithmetic-shift-left fx)
633  (%check-fixnum-shift-amount 'fxarithmetic-shift-left amount)
634  (%fxshl/check 'fxarithmetic-shift-left fx amount) )
635
636(define (fxarithmetic-shift-right fx amount)
637  (%check-fixnum 'fxarithmetic-shift-right fx)
638  (%check-fixnum-shift-amount 'fxarithmetic-shift-right amount)
639  (%fxshr/check 'fxarithmetic-shift-right fx amount) )
640
641;;
642
643(define (fxif mask true false)
644  (%check-fixnum 'fxif mask)
645  (%check-fixnum 'fxif true)
646  (%check-fixnum 'fxif false)
647  (*bitwise-if mask true false) )
648
649(define (fxbit-count fx)
650  (%check-fixnum 'fxbit-count fx)
651  (*bitwise-bit-count fx) )
652
653(define (fxlength fx)
654  (%check-fixnum 'fxlength fx)
655  (*bitwise-length fx) )
656
657(define (fxfirst-bit-set fx)
658  (%check-fixnum 'fxfirst-bit-set fx)
659  (*bitwise-first-bit-set fx) )
660
661(define (fxbit-set? fx index)
662  (%check-fixnum 'fxbit-set? fx)
663  (%check-word-bits-range 'fxbit-set? index)
664  (*bitwise-bit-set? fx index) )
665
666(define (fxcopy-bit fx index bit)
667  (%check-fixnum 'fxcopy-bit fx)
668  (%check-word-bits-range 'fxcopy-bit index)
669  (%check-fixnum 'fxcopy-bit bit)
670  (*bitwise-copy-bit fx index bit) )
671
672(define (fxbit-field fx start end)
673  (%check-fixnum 'fxbit-field fx)
674  (%check-bits-range 'fxbit-field start end)
675  (*bitwise-bit-field fx start end) )
676
677(define (fxcopy-bit-field fxto start end fxfrom)
678  (%check-fixnum 'fxcopy-bit-field fxto)
679  (%check-bits-range 'fxcopy-bit-field start end)
680  (%check-fixnum 'fxcopy-bit-field fxfrom)
681  (*bitwise-copy-bit-field fxto start end fxfrom) )
682
683(define (fxrotate-bit-field fx start end count)
684  (%check-fixnum 'fxrotate-bit-field fx)
685  (%check-bits-range 'fxrotate-bit-field start end)
686  (%check-fixnum-bits-count 'fxrotate-bit-field count start end)
687  (*bitwise-rotate-bit-field fx start end count) )
688
689(define (fxreverse-bit-field fx start end)
690  (%check-fixnum 'fxreverse-bit-field fx)
691  (%check-bits-range 'fxreverse-bit-field start end)
692  (*bitwise-reverse-bit-field fx start end) )
693
694;;; Extras
695
696;;
697
698(define (fx<>? fx . fxs) (%fxand-fold 'fx<>? -fx<> fx fxs))
699
700(define (fxcompare fx1 fx2)
701  (%check-fixnum 'fxcompare fx1)
702  (%check-fixnum 'fxcompare fx2)
703  (cond ((%fx= fx1 fx2)   0)
704        ((%fx< fx1 fx2)   -1)
705        (else             1) ) )
706
707;;
708
709(define (fxabs fx)
710  (%check-fixnum 'fxabs fx)
711  (%fxabs fx) )
712
713(define (fxnegate fx)
714  (%check-fixnum 'fxnegate fx)
715  (%fxneg fx) )
716
717(define (fxadd1 fx)
718  (%check-fixnum 'fxadd1 fx)
719  (when (invalid-sum? fx 1) (error-fixnum-representation 'fxadd1 fx))
720  (%fxadd1 fx) )
721
722(define (fxsub1 fx)
723  (%check-fixnum 'fxsub1 fx)
724  (when (invalid-difference? fx 1) (error-fixnum-representation 'fxsub1 fx))
725  (%fxsub1 fx) )
726
727(define (fx/ fxn fxd) (%fxdiv/check 'fx/ fxn fxd))
728(define (fxquotient fxn fxd) (%fxdiv/check 'fxquotient fxn fxd))
729(define (fxremainder fxn fxd) (%fx- fxn (%fx* (%fxdiv/check 'fxremainder fxn fxd) fxd)))
730
731;;
732
733(define fixnum->string
734  (let ((digits "0123456789ABCDEF"))
735    (lambda (fx #!optional (radix 10))
736
737      (define (fx-digits fx from to)
738        (if (%fxzero? fx) (values (%make-string from #\#) to)
739            (let* ((quo (%fx/ fx radix))
740                   (digit (%string-ref digits (%fx- fx (%fx* quo radix)))))
741              (let-values (((str to) (fx-digits quo (%fx+ from 1) to)))
742                (%string-set! str to digit)
743                (values str (%fx+ to 1)) ) ) ) )
744
745      (define (fx->str fx)
746        (cond ((%fxzero? fx)
747               (%make-string 1 #\0))
748              ((%fxpositive? fx)
749               (let ((str (fx-digits fx 0 0)))
750                 (void str) ; force reference
751                 str ) )
752              ((%fx= most-negative-fixnum fx)
753               (##sys#string-append
754                (fx->str (%fx/ fx radix))
755                (fx->str (%fx- radix (%fxmod fx radix)))) )
756              (else
757               (let ((str (fx-digits (%fxneg fx) 1 1)))
758                 (%string-set! str 0 #\-)
759                 str ) ) ) )
760
761      (%check-fixnum 'fixnum->string fx)
762      (case radix
763        ((2 8 10 16) (fx->str fx))
764        (else (error-radix 'fixnum->string radix) ) ) ) ) )
765
766;;
767
768(define (fxif-not mask true false)
769  (%check-fixnum 'fxif-not mask)
770  (%check-fixnum 'fxif-not true)
771  (%check-fixnum 'fxif-not false)
772  (*bitwise-if-not mask true false) )
773
774(define (fxlast-bit-set fx)
775  (%check-fixnum 'fxlast-bit-set fx)
776  (*bitwise-last-bit-set fx) )
777
778;;
779
780(define (fxpow2log2 fx)
781  (%check-fixnum 'fxpow2log2 fx)
782  (*pow2log2 fx) )
783
784;;
785
786(define-syntax $fx=?
787  (syntax-rules ()
788    ((_ ?x)               #t )
789    ((_ ?x ?y)            (-fx= ?x ?y) )
790    ((_ ?x ?y ?rest ...)  (and (-fx= ?x ?y) ($fx=? ?y ?rest ...)) ) ) )
791
792(define-syntax $fx<?
793  (syntax-rules ()
794    ((_ ?x)               #t )
795    ((_ ?x ?y)            (-fx< ?x ?y) )
796    ((_ ?x ?y ?rest ...)  (and (-fx< ?x ?y) ($fx<? ?y ?rest ...)) ) ) )
797
798(define-syntax $fx>?
799  (syntax-rules ()
800    ((_ ?x)               #t )
801    ((_ ?x ?y)            (-fx> ?x ?y) )
802    ((_ ?x ?y ?rest ...)  (and (-fx> ?x ?y) ($fx>? ?y ?rest ...)) ) ) )
803
804(define-syntax $fx<=?
805  (syntax-rules ()
806    ((_ ?x)               #t )
807    ((_ ?x ?y)            (-fx<= ?x ?y) )
808    ((_ ?x ?y ?rest ...)  (and (-fx<= ?x ?y) ($fx<=? ?y ?rest ...)) ) ) )
809
810(define-syntax $fx>=?
811  (syntax-rules ()
812    ((_ ?x)               #t )
813    ((_ ?x ?y)            (-fx>= ?x ?y) )
814    ((_ ?x ?y ?rest ...)  (and (-fx>= ?x ?y) ($fx>=? ?y ?rest ...)) ) ) )
815
816(define-syntax $fx<>?
817  (syntax-rules ()
818    ((_ ?x)               #f )
819    ((_ ?x ?y)            (-fx<> ?x ?y) )
820    ((_ ?x ?y ?rest ...)  (and (-fx<> ?x ?y) ($fx<>? ?y ?rest ...)) ) ) )
821
822;;
823
824(define-syntax $fxmax
825  (syntax-rules ()
826    ((_ ?x)               ?x )
827    ((_ ?x ?y)            (-fxmax ?x ?y) )
828    ((_ ?x ?y ?rest ...)  (-fxmax ?x ($fxmax ?y ?rest ...)) ) ) )
829
830(define-syntax $fxmin
831  (syntax-rules ()
832    ((_ ?x)               ?x )
833    ((_ ?x ?y)            (-fxmin ?x ?y) )
834    ((_ ?x ?y ?rest ...)  (-fxmin ?x ($fxmin ?y ?rest ...)) ) ) )
835
836;;
837
838(define-syntax $fxand
839  (syntax-rules ()
840    ((_ ?x)               ?x )
841    ((_ ?x ?y)            (-fxand ?x ?y) )
842    ((_ ?x ?y ?rest ...)  (-fxand ?x ($fxand ?y ?rest ...)) ) ) )
843
844(define-syntax $fxior
845  (syntax-rules ()
846    ((_ ?x)               ?x )
847    ((_ ?x ?y)            (-fxior ?x ?y) )
848    ((_ ?x ?y ?rest ...)  (-fxior ?x ($fxior ?y ?rest ...)) ) ) )
849
850(define-syntax $fxxor
851  (syntax-rules ()
852    ((_ ?x)               ?x )
853    ((_ ?x ?y)            (-fxxor ?x ?y) )
854    ((_ ?x ?y ?rest ...)  (-fxxor ?x ($fxxor ?y ?rest ...)) ) ) )
855
856;;
857
858(define-syntax $fx-
859  (syntax-rules ()
860    ((_ ?x)               (-fx- ?x) )
861    ((_ ?x ?y)            (-fx- ?x ?y) )
862    ((_ ?x ?y ?rest ...)  (-fx- ?x ($fx- ?y ?rest ...) ) ) ) )
863
864(define-syntax $fx+
865  (syntax-rules ()
866    ((_ ?x)               ?x )
867    ((_ ?x ?y)            (-fx+ ?x ?y) )
868    ((_ ?x ?y ?rest ...)  (-fx+ ?x ($fx+ ?y ?rest ...) ) ) ) )
869
870(define-syntax $fx*
871  (syntax-rules ()
872    ((_ ?x)               ?x )
873    ((_ ?x ?y)            (-fx* ?x ?y) )
874    ((_ ?x ?y ?rest ...)  (-fx* ?x ($fx* ?y ?rest ...) ) ) ) )
875
876(define-syntax $fx/
877  (syntax-rules ()
878    ((_ ?x)               ?x )
879    ((_ ?x ?y)            (-fx/ ?x ?y) )
880    ((_ ?x ?y ?rest ...)  (-fx/ ?x ($fx/ ?y ?rest ...) ) ) ) )
881
882) ;module err5rs-arithmetic-fixnums
Note: See TracBrowser for help on using the repository browser.