197 lines
6.5 KiB
Scheme
197 lines
6.5 KiB
Scheme
#lang scheme/base
|
|
|
|
(require (only-in rnrs/base-6
|
|
div-and-mod div mod
|
|
div0-and-mod0 div0 mod0)
|
|
rnrs/arithmetic/bitwise-6
|
|
r6rs/private/num-inline
|
|
(for-syntax r6rs/private/inline-rules))
|
|
|
|
(provide fixnum?
|
|
fixnum-width
|
|
least-fixnum
|
|
greatest-fixnum
|
|
fxbit-set?
|
|
fxcopy-bit
|
|
fxcopy-bit-field
|
|
fxbit-field
|
|
fxbit-count
|
|
fxarithmetic-shift
|
|
fxarithmetic-shift-left
|
|
fxarithmetic-shift-right
|
|
fxrotate-bit-field
|
|
fxreverse-bit-field)
|
|
;; Many other provides from macros below
|
|
|
|
(define 64-bit? (fixnum? (expt 2 33)))
|
|
|
|
(define (fixnum-width) (if 64-bit? 63 31))
|
|
(define (least-fixnum) (if 64-bit? (- (expt 2 62)) -1073741824))
|
|
(define (greatest-fixnum) (if 64-bit? (- (expt 2 62) 1) +1073741823))
|
|
|
|
(define-syntax-rule (check v alt)
|
|
(if (fixnum? v)
|
|
v
|
|
alt))
|
|
|
|
(define-inliner define-fx fixnum? "fixnum")
|
|
|
|
(define-fx = fx=? (a b c ...) nocheck)
|
|
(define-fx > fx>? (a b c ...) nocheck)
|
|
(define-fx < fx<? (a b c ...) nocheck)
|
|
(define-fx <= fx<=? (a b c ...) nocheck)
|
|
(define-fx >= fx>=? (a b c ...) nocheck)
|
|
|
|
(define-fx zero? fxzero? (a) nocheck)
|
|
(define-fx positive? fxpositive? (a) nocheck)
|
|
(define-fx negative? fxnegative? (a) nocheck)
|
|
(define-fx odd? fxodd? (a) nocheck)
|
|
(define-fx even? fxeven? (a) nocheck)
|
|
|
|
(define-fx max fxmax (a b ...) nocheck)
|
|
(define-fx min fxmin (a b ...) nocheck)
|
|
|
|
(define-fx + fx+ (a b) check)
|
|
(define-fx * fx* (a b) check)
|
|
(define-fx - fx- [(a) (a b)] check)
|
|
|
|
(provide fxdiv-and-mod
|
|
fxdiv0-and-mod0)
|
|
(define (fxdiv-and-mod a b)
|
|
(unless (fixnum? a)
|
|
(raise-type-error 'fxdiv-and-mod "fixnum" a))
|
|
(unless (fixnum? b)
|
|
(raise-type-error 'fxdiv-and-mod "fixnum" b))
|
|
(div-and-mod a b))
|
|
(define-fx div fxdiv (a b) nocheck)
|
|
(define-fx mod fxmod (a b) nocheck)
|
|
(define (fxdiv0-and-mod0 a b)
|
|
(unless (fixnum? a)
|
|
(raise-type-error 'fxdiv0-and-mod0 "fixnum" a))
|
|
(unless (fixnum? b)
|
|
(raise-type-error 'fxdiv0-and-mod0 "fixnum" b))
|
|
(div0-and-mod0 a b))
|
|
(define-fx div0 fxdiv0 (a b) nocheck)
|
|
(define-fx mod0 fxmod0 (a b) nocheck)
|
|
|
|
(define-syntax-rule (define-carry fx/carry (a b c) expr)
|
|
(begin
|
|
(provide fx/carry)
|
|
(define (fx/carry a b c)
|
|
(unless (fixnum? a)
|
|
(raise-type-error 'fx/carry "fixnum" a))
|
|
(unless (fixnum? a)
|
|
(raise-type-error 'fx/carry "fixnum" b))
|
|
(unless (fixnum? a)
|
|
(raise-type-error 'fx/carry "fixnum" b))
|
|
(let-values ([(d m) (div0-and-mod0 expr
|
|
(arithmetic-shift 1 (fixnum-width)))])
|
|
(values m d)))))
|
|
|
|
(define-carry fx+/carry (a b c) (+ a b c))
|
|
(define-carry fx-/carry (a b c) (- a b c))
|
|
(define-carry fx*/carry (a b c) (+ (* a b) c))
|
|
|
|
(define-fx bitwise-not fxnot (a) nocheck)
|
|
(define-fx bitwise-and fxand (a b ...) nocheck)
|
|
(define-fx bitwise-ior fxior (a b ...) nocheck)
|
|
(define-fx bitwise-xor fxxor (a b ...) nocheck)
|
|
|
|
(define-syntax-rule (fixnum-bitwise-if a b c)
|
|
(bitwise-ior (bitwise-and a b)
|
|
(bitwise-and (bitwise-not a) c)))
|
|
(define-fx fixnum-bitwise-if fxif (a b c) nocheck)
|
|
|
|
(define-fx bitwise-length fxlength (a) nocheck)
|
|
(define-fx bitwise-first-bit-set fxfirst-bit-set (a) nocheck)
|
|
|
|
(define (fxbit-set? n bit)
|
|
(unless (fixnum? n)
|
|
(raise-type-error 'fxbit-set? "fixnum" n))
|
|
(bitwise-bit-set? n bit))
|
|
|
|
(define (fxbit-count n)
|
|
(unless (fixnum? n)
|
|
(raise-type-error 'fxbit-count "fixnum" n))
|
|
(bitwise-bit-count n))
|
|
|
|
(define (fxcopy-bit n pos bit)
|
|
(unless (fixnum? n)
|
|
(raise-type-error 'fxcopy-bit "fixnum" n))
|
|
(unless (and (exact-nonnegative-integer? pos)
|
|
(< pos (fixnum-width)))
|
|
(raise-type-error 'fxcopy-bit "exact integer in [0, 30]" pos))
|
|
(bitwise-copy-bit n pos bit))
|
|
|
|
(define (fxcopy-bit-field n start end m)
|
|
(unless (fixnum? n)
|
|
(raise-type-error 'fxcopy-bit-field "fixnum" n))
|
|
(unless (and (exact-nonnegative-integer? end)
|
|
(< end (fixnum-width)))
|
|
(raise-type-error 'fxcopy-bit-field "exact integer in [0, 30]" end))
|
|
(unless (fixnum? m)
|
|
(raise-type-error 'fxcopy-bit-field "fixnum" m))
|
|
(bitwise-copy-bit-field n start end m))
|
|
|
|
(define (fxbit-field n start end)
|
|
(unless (fixnum? n)
|
|
(raise-type-error 'fxbit-field "fixnum" n))
|
|
(unless (and (exact-nonnegative-integer? end)
|
|
(< end (fixnum-width)))
|
|
(raise-type-error 'fxbit-field "exact integer in [0, 30]" end))
|
|
(bitwise-bit-field n start end))
|
|
|
|
(define-syntax-rule (define-shifter fxarithmetic-shift r6rs:fxarithmetic-shift
|
|
lower-bound bounds adjust)
|
|
(begin
|
|
(provide fxarithmetic-shift)
|
|
(define-syntax fxarithmetic-shift
|
|
(inline-rules
|
|
r6rs:fxarithmetic-shift
|
|
[(_ a b)
|
|
(let ([t1 a]
|
|
[t2 b])
|
|
(if (and (fixnum? a)
|
|
(and (exact-integer? b) (<= lower-bound b 30)))
|
|
(let ([v (arithmetic-shift a (adjust b))])
|
|
(if (fixnum? v)
|
|
v
|
|
(r6rs:fxarithmetic-shift t1 t2)))
|
|
(r6rs:fxarithmetic-shift t1 t2)))]))
|
|
(define (r6rs:fxarithmetic-shift a b)
|
|
(unless (fixnum? a)
|
|
(raise-type-error 'fxarithmetic-shift "fixnum" a))
|
|
(unless (and (exact-integer? b) (<= lower-bound b 30))
|
|
(raise-type-error 'fxarithmetic-shift bounds b))
|
|
(let ([v (arithmetic-shift a (adjust b))])
|
|
(if (fixnum? v)
|
|
v
|
|
(implementation-restriction 'fxarithmetic-shift v))))))
|
|
|
|
(define-shifter fxarithmetic-shift r6rs:fxarithmetic-shift
|
|
-30 "exact integer in [-30, 30]" values)
|
|
(define-shifter fxarithmetic-shift-left r6rs:fxarithmetic-shift-left
|
|
0 "exact integer in [0, 30]" values)
|
|
(define-shifter fxarithmetic-shift-right r6rs:fxarithmetic-shift-right
|
|
0 "exact integer in [0, 30]" -)
|
|
|
|
|
|
(define (fxrotate-bit-field n start end count)
|
|
(unless (fixnum? n)
|
|
(raise-type-error 'fxrotate-bit-field "fixnum" n))
|
|
(unless (and (exact-nonnegative-integer? end)
|
|
(< end (fixnum-width)))
|
|
(raise-type-error 'fxrotate-bit-field "exact integer in [0, 30]" end))
|
|
(unless (and (exact-nonnegative-integer? count)
|
|
(< count (fixnum-width)))
|
|
(raise-type-error 'fxrotate-bit-field "exact integer in [0, 30]" count))
|
|
(bitwise-rotate-bit-field n start end count))
|
|
|
|
(define (fxreverse-bit-field n start end)
|
|
(unless (fixnum? n)
|
|
(raise-type-error 'fxrotate-bit-field "fixnum" n))
|
|
(unless (and (exact-nonnegative-integer? end)
|
|
(< end (fixnum-width)))
|
|
(raise-type-error 'fxrotate-bit-field "exact integer in [0, 30]" end))
|
|
(bitwise-reverse-bit-field n start end))
|