204 lines
7.1 KiB
Racket
204 lines
7.1 KiB
Racket
#lang scheme/base
|
|
|
|
(require (only-in rnrs/base-6
|
|
div-and-mod div mod
|
|
div0-and-mod0 div0 mod0)
|
|
(prefix-in core: scheme/fixnum)
|
|
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
|
|
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=? core:fx= (a b c ...) nocheck)
|
|
(define-fx > fx>? core:fx> (a b c ...) nocheck)
|
|
(define-fx < fx<? core:fx< (a b c ...) nocheck)
|
|
(define-fx <= fx<=? core:fx<= (a b c ...) nocheck)
|
|
(define-fx >= fx>=? core:fx>= (a b c ...) nocheck)
|
|
|
|
(define-fx zero? fxzero? #f (a) nocheck)
|
|
(define-fx positive? fxpositive? #f (a) nocheck)
|
|
(define-fx negative? fxnegative? #f (a) nocheck)
|
|
(define-fx odd? fxodd? #f (a) nocheck)
|
|
(define-fx even? fxeven? #f (a) nocheck)
|
|
|
|
(define-fx max fxmax core:fxmax (a b ...) nocheck)
|
|
(define-fx min fxmin core:fxmin (a b ...) nocheck)
|
|
|
|
(define-fx + fx+ core:fx+ (a b) check)
|
|
(define-fx * fx* core:fx* (a b) check)
|
|
(define-fx - fx- core: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))
|
|
(let-values ([(d m) (div-and-mod a b)])
|
|
(check d (implementation-restriction 'div-and-mod d))
|
|
(values d m)))
|
|
(define-fx div fxdiv #f (a b) check)
|
|
(define-fx mod fxmod #f (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))
|
|
(let-values ([(d m) (div0-and-mod0 a b)])
|
|
(check d (implementation-restriction 'div0-and-mod0 d))
|
|
(values d m)))
|
|
(define-fx div0 fxdiv0 #f (a b) check)
|
|
(define-fx mod0 fxmod0 #f (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))
|
|
|
|
(provide (rename-out [core:fxnot fxnot]))
|
|
(define-fx bitwise-and fxand core:fxand (a b ...) nocheck)
|
|
(define-fx bitwise-ior fxior core:fxior (a b ...) nocheck)
|
|
(define-fx bitwise-xor fxxor core: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 #f (a b c) nocheck)
|
|
|
|
(define-fx bitwise-length fxlength #f (a) nocheck)
|
|
(define-fx bitwise-first-bit-set fxfirst-bit-set #f (a) nocheck)
|
|
|
|
(define positive-fixnum-width-bounds
|
|
(string-append "exact integer in [0, " (number->string (- (fixnum-width) 1)) "]"))
|
|
|
|
(define fixnum-width-bounds
|
|
(string-append "exact integer in [ " (number->string (- 1 (fixnum-width)))
|
|
", " (number->string (- (fixnum-width) 1)) "]"))
|
|
|
|
(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 positive-fixnum-width-bounds 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 positive-fixnum-width-bounds 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 positive-fixnum-width-bounds 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? t1)
|
|
(and (exact-integer? t2) (<= lower-bound t2 (- (fixnum-width) 1))))
|
|
(let ([v (arithmetic-shift t1 (adjust t2))])
|
|
(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 (- (fixnum-width) 1)))
|
|
(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
|
|
(- 1 (fixnum-width)) fixnum-width-bounds values)
|
|
(provide (rename-out [core:fxlshift fxarithmetic-shift-left]
|
|
[core:fxrshift fxarithmetic-shift-right]))
|
|
|
|
(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 positive-fixnum-width-bounds end))
|
|
(unless (and (exact-nonnegative-integer? count)
|
|
(< count (fixnum-width)))
|
|
(raise-type-error 'fxrotate-bit-field positive-fixnum-width-bounds 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 positive-fixnum-width-bounds end))
|
|
(bitwise-reverse-bit-field n start end))
|