scsh-0.6/scheme/big/bigbit.scm

208 lines
6.3 KiB
Scheme

; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; Bitwise logical operators on bignums.
(define-opcode-extension bitwise-not &bitwise-not)
(define-opcode-extension bitwise-and &bitwise-and)
(define-opcode-extension bitwise-ior &bitwise-ior)
(define-opcode-extension bitwise-xor &bitwise-xor)
(define-opcode-extension arithmetic-shift &arithmetic-shift)
(define (integer-bitwise-not m)
;; (integer+ (integer-negate m) -1)
(integer- -1 m))
(define (integer-bitwise-and m n)
(if (or (integer= 0 m) (integer= 0 n))
0
(integer-bitwise-op bitwise-and m n)))
(define (integer-bitwise-ior m n)
(cond ((integer= 0 m) n)
((integer= 0 n) m)
(else
(integer-bitwise-op bitwise-ior m n))))
(define (integer-bitwise-xor m n)
(cond ((integer= 0 m) n)
((integer= 0 n) m)
(else
(integer-bitwise-op bitwise-xor m n))))
(define (integer-bitwise-op op m n)
(let ((m (integer->bignum m))
(n (integer->bignum n)))
(let ((finish (lambda (sign-bit mag-op)
(let ((mag (mag-op op
(bignum-magnitude m)
(bignum-magnitude n))))
(make-integer (if (= 0 sign-bit) 1 -1)
(if (= 0 sign-bit)
mag
(negate-magnitude mag)))))))
(if (>= (bignum-sign m) 0)
(if (>= (bignum-sign n) 0)
(finish (op 0 0) magnitude-bitwise-binop-pos-pos)
(finish (op 0 1) magnitude-bitwise-binop-pos-neg))
(if (>= (bignum-sign n) 0)
(finish (op 0 1) magnitude-bitwise-binop-neg-pos)
(finish (op 1 1) magnitude-bitwise-binop-neg-neg))))))
(define radix-mask (- radix 1))
(define (magnitude-bitwise-binop-pos-pos op m n)
(let recur ((m m) (n n))
(if (and (zero-magnitude? m) (zero-magnitude? n))
m
(adjoin-digit (bitwise-and (op (low-digit m) (low-digit n)) radix-mask)
(recur (high-digits m) (high-digits n))))))
; Same as the above, except that one magnitude is that of a negative number.
(define (magnitude-bitwise-binop-neg-pos op m n)
(magnitude-bitwise-binop-pos-neg op n m))
(define (magnitude-bitwise-binop-pos-neg op m n)
(let recur ((m m) (n n) (carry 1))
(if (and (zero-magnitude? n) (zero-magnitude? m))
(integer->magnitude (op 0 carry))
(call-with-values
(lambda ()
(negate-low-digit n carry))
(lambda (n-digit carry)
(adjoin-digit (op (low-digit m) n-digit)
(recur (high-digits m)
(high-digits n)
carry)))))))
; Now both M and N are magnitudes of negative numbers.
(define (magnitude-bitwise-binop-neg-neg op m n)
(let recur ((m m) (n n) (m-carry 1) (n-carry 1))
(if (and (zero-magnitude? n) (zero-magnitude? m))
(integer->magnitude (op m-carry n-carry))
(call-with-values
(lambda ()
(negate-low-digit m m-carry))
(lambda (m-digit m-carry)
(call-with-values
(lambda ()
(negate-low-digit n n-carry))
(lambda (n-digit n-carry)
(adjoin-digit (op m-digit n-digit)
(recur (high-digits m)
(high-digits n)
m-carry
n-carry)))))))))
(define (negate-low-digit m carry)
(let ((m (+ (bitwise-and (bitwise-not (low-digit m))
radix-mask)
carry)))
(if (>= m radix)
(values (- m radix) 1)
(values m 0))))
(define (negate-magnitude m)
(let recur ((m m) (carry 1))
(if (zero-magnitude? m)
(integer->magnitude carry)
(call-with-values
(lambda ()
(negate-low-digit m carry))
(lambda (next carry)
(adjoin-digit next
(recur (high-digits m) carry)))))))
; arithmetic-shift
(define (integer-arithmetic-shift m n)
(let ((m (integer->bignum m)))
(make-integer (bignum-sign m)
(cond ((> n 0)
(shift-left-magnitude (bignum-magnitude m) n))
((= 1 (bignum-sign m))
(shift-right-pos-magnitude (bignum-magnitude m) n))
(else
(shift-right-neg-magnitude (bignum-magnitude m) n))))))
(define (shift-left-magnitude mag n)
(if (< n log-radix)
(let ((mask (- (arithmetic-shift 1 (- log-radix n)) 1)))
(let recur ((mag mag)
(low 0))
(if (zero-magnitude? mag)
(adjoin-digit low zero-magnitude)
;; Split the low digit into left and right parts, and shift
(let ((left (arithmetic-shift (low-digit mag)
(- n log-radix))) ;shift right
(right (arithmetic-shift (bitwise-and (low-digit mag) mask)
n)))
(adjoin-digit (bitwise-ior low right)
(recur (high-digits mag)
left))))))
(adjoin-digit 0 (shift-left-magnitude mag (- n log-radix)))))
(define (shift-right-pos-magnitude mag n)
(if (> n (- 0 log-radix))
(let ((mask (- (arithmetic-shift 1 (- 0 n)) 1)))
(let recur ((mag mag))
(let ((low (low-digit mag))
(high (high-digits mag)))
(adjoin-digit
(bitwise-ior (arithmetic-shift low n)
(arithmetic-shift (bitwise-and mask (low-digit high))
(+ n log-radix)))
(if (zero-magnitude? high)
zero-magnitude
(recur high))))))
(shift-right-pos-magnitude (high-digits mag) (+ n log-radix))))
(define (shift-right-neg-magnitude mag n)
(negate-magnitude
(let digit-recur ((mag mag) (n n) (carry 1))
(call-with-values
(lambda ()
(negate-low-digit mag carry))
(lambda (digits carry)
(if (<= n (- 0 log-radix))
(digit-recur (high-digits mag) (+ n log-radix) carry)
(let ((mask (- (arithmetic-shift 1 (- 0 n)) 1)))
(let recur ((mag mag) (low digits) (carry carry))
(let ((high-digits (high-digits mag)))
(call-with-values
(lambda ()
(negate-low-digit high-digits carry))
(lambda (high carry)
(adjoin-digit
(bitwise-ior (arithmetic-shift low n)
(arithmetic-shift (bitwise-and mask high)
(+ n log-radix)))
(if (zero-magnitude? high-digits)
(integer->magnitude carry)
(recur high-digits high carry))))))))))))))
;(define (tst)
; (let* ((m (random))
; (n (bitwise-and m 63))
; (m1 (integer-arithmetic-shift
; (integer-arithmetic-shift m n)
; (- 0 n))))
; (list n m m1 (= m m1))))
;(define random (make-random 17))
(define-method &bitwise-not ((n :integer)) (integer-bitwise-not n))
(define-method &bitwise-and ((n1 :exact-integer) (n2 :exact-integer))
(integer-bitwise-and n1 n2))
(define-method &bitwise-ior ((n1 :exact-integer) (n2 :exact-integer))
(integer-bitwise-ior n1 n2))
(define-method &bitwise-xor ((n1 :exact-integer) (n2 :exact-integer))
(integer-bitwise-xor n1 n2))
(define-method &arithmetic-shift ((n1 :exact-integer) (n2 :exact-integer))
(integer-arithmetic-shift n1 n2))