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

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

Update inlines. Testing.

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