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

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

Save.

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