home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-385-Vol-1of3.iso / s / s48.zip / MISC / BIGBIT.SCM < prev    next >
Text File  |  1992-06-19  |  7KB  |  213 lines
  1. ; Copyright (c) 1992 by Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3. ;Date: Sat, 30 May 92 09:43:39 -0400
  4. ;To: jar@cs.cornell.edu
  5. ;Subject: bignum code
  6. ;From: kelsey@corwin.ccs.northeastern.edu
  7.  
  8.  
  9. ; rts/number.scm
  10.  
  11. (define bitwise-not-table      (make-method-table 'bitwise-not))
  12. (define bitwise-and-table      (make-method-table 'bitwise-and))
  13. (define bitwise-ior-table      (make-method-table 'bitwise-ior))
  14. (define bitwise-xor-table      (make-method-table 'bitwise-xor))
  15. (define arithmetic-shift-table (make-method-table 'arithmetic-shift))
  16.  
  17. ; rts/hair.scm
  18.  
  19. (make-opcode-generic! op/bitwise-not      bitwise-not-table)
  20. (make-opcode-generic! op/bitwise-and      bitwise-and-table)
  21. (make-opcode-generic! op/bitwise-ior      bitwise-ior-table)
  22. (make-opcode-generic! op/bitwise-xor      bitwise-xor-table)
  23. (make-opcode-generic! op/arithmetic-shift arithmetic-shift-table)
  24.  
  25.  
  26. ; misc/bitnum.scm
  27.  
  28. (define (integer-bitwise-not m)
  29.   (integer+ (integer-negate m) -1))
  30.  
  31. (define (integer-bitwise-and m n)
  32.   (if (or (integer= 0 m) (integer= 0 n))
  33.       0
  34.       (integer-bitwise-op bitwise-and m n)))
  35.  
  36. (define (integer-bitwise-ior m n)
  37.   (cond ((integer= 0 m) n)
  38.     ((integer= 0 n) m)
  39.     (else
  40.      (integer-bitwise-op bitwise-ior m n))))
  41.  
  42. (define (integer-bitwise-xor m n)
  43.   (cond ((integer= 0 m) n)
  44.     ((integer= 0 n) m)
  45.     (else
  46.      (integer-bitwise-op bitwise-xor m n))))
  47.  
  48. (define (integer-bitwise-op op m n)
  49.   (let ((m (integer->bignum m))
  50.     (n (integer->bignum n)))
  51.     (let ((finish (lambda (sign-bit mag-op)
  52.             (let ((mag (mag-op op
  53.                        (bignum-magnitude m)
  54.                        (bignum-magnitude n))))
  55.               (make-integer (if (= 0 sign-bit) 1 -1)
  56.                     (if (= 0 sign-bit)
  57.                     mag
  58.                     (negate-magnitude mag))
  59.                     (and (bignum-exact? m)
  60.                      (bignum-exact? n)))))))
  61.       (if (>= (bignum-sign m) 0)
  62.       (if (>= (bignum-sign n) 0)
  63.           (finish (op 0 0) magnitude-bitwise-binop-pos-pos)
  64.           (finish (op 0 1) magnitude-bitwise-binop-pos-neg))
  65.       (if (>= (bignum-sign n) 0)
  66.           (finish (op 0 1) magnitude-bitwise-binop-neg-pos)
  67.           (finish (op 1 1) magnitude-bitwise-binop-neg-neg))))))
  68.  
  69. (define radix-mask (- radix 1))
  70.  
  71. (define (magnitude-bitwise-binop-pos-pos op m n)
  72.   (let recur ((m m) (n n))
  73.     (if (and (zero-magnitude? m) (zero-magnitude? n))
  74.     m
  75.     (adjoin-digit (bitwise-and (op (low-digit m) (low-digit n)) radix-mask)
  76.               (recur (high-digits m) (high-digits n))))))
  77.  
  78. ; Same as the above, except that one magnitude is that of negative number.
  79.  
  80. (define (magnitude-bitwise-binop-neg-pos op m n)
  81.   (magnitude-bitwise-binop-pos-neg op n m))
  82.  
  83. (define (magnitude-bitwise-binop-pos-neg op m n)
  84.   (let recur ((m m) (n n) (carry 1))
  85.     (if (and (zero-magnitude? n) (zero-magnitude? m))
  86.     (integer->magnitude (op 0 carry))
  87.     (let ((n-digit (negate-low-digit n carry)))
  88.       (adjoin-digit (bitwise-and (op (low-digit m) n-digit) radix-mask)
  89.             (recur (high-digits m)
  90.                    (high-digits n)
  91.                    (if (>= n-digit radix) 1 0)))))))
  92.  
  93. ; Now both M and N are magnitudes of negative numbers.
  94.  
  95. (define (magnitude-bitwise-binop-neg-neg op m n)
  96.   (let recur ((m m) (n n) (m-carry 1) (n-carry 1))
  97.     (if (and (zero-magnitude? n) (zero-magnitude? m))
  98.     (integer->magnitude (op m-carry n-carry))
  99.     (let ((m-digit (negate-low-digit m m-carry))
  100.           (n-digit (negate-low-digit n n-carry)))
  101.       (adjoin-digit (bitwise-and (op m-digit n-digit) radix-mask)
  102.             (recur (high-digits m)
  103.                    (high-digits n)
  104.                    (if (>= m-digit radix) 1 0)
  105.                    (if (>= n-digit radix) 1 0)))))))
  106.  
  107. (define (negate-low-digit m carry)
  108.   (+ (bitwise-and (bitwise-not (low-digit m))
  109.           radix-mask)
  110.      carry))
  111.  
  112. (define (negate-magnitude m)
  113.   (let recur ((m m) (carry 1))
  114.     (if (zero-magnitude? m)
  115.     (integer->magnitude carry)
  116.     (let ((res (negate-low-digit m carry)))
  117.       (if (>= res radix)
  118.           (adjoin-digit (- res radix)
  119.                 (recur (high-digits m) 1))
  120.           (adjoin-digit res
  121.                 (recur (high-digits m) 0)))))))
  122.  
  123. ; arithmetic-shift
  124.  
  125. (define (integer-arithmetic-shift m n)
  126.   (let ((m (integer->bignum m)))
  127.     (make-integer (bignum-sign m)
  128.           (cond ((> n 0)
  129.              (shift-left-magnitude (bignum-magnitude m) n))
  130.             ((= 1 (bignum-sign m))
  131.              (shift-right-pos-magnitude (bignum-magnitude m) n))
  132.             (else
  133.              (shift-right-neg-magnitude (bignum-magnitude m) n)))
  134.           (bignum-exact? m))))
  135.  
  136. (define (shift-left-magnitude mag n)
  137.   (if (< n log-radix)
  138.       (let ((mask (- (arithmetic-shift 1 (- log-radix n)) 1)))
  139.     (let recur ((mag mag)
  140.             (low 0))
  141.       (if (zero-magnitude? mag)
  142.           (adjoin-digit low zero-magnitude)
  143.           ;; Split the low digit into left and right parts, and shift
  144.           (let ((left (arithmetic-shift (low-digit mag)
  145.                         (- n log-radix))) ;shift right
  146.             (right (arithmetic-shift (bitwise-and (low-digit mag) mask)
  147.                          n)))
  148.         (adjoin-digit (bitwise-ior low right)
  149.                   (recur (high-digits mag)
  150.                      left))))))
  151.       (adjoin-digit 0 (shift-left-magnitude mag (- n log-radix)))))
  152.  
  153. (define (shift-right-pos-magnitude mag n)
  154.   (if (> n (- 0 log-radix))
  155.       (let ((mask (- (arithmetic-shift 1 (- 0 n)) 1)))
  156.     (let recur ((mag mag))
  157.       (let ((low (low-digit mag))
  158.         (high (high-digits mag)))
  159.         (adjoin-digit
  160.          (bitwise-ior (arithmetic-shift low n)
  161.               (arithmetic-shift (bitwise-and mask (low-digit high))
  162.                         (+ n log-radix)))
  163.          (if (zero-magnitude? high)
  164.          zero-magnitude
  165.          (recur high))))))
  166.       (shift-right-pos-magnitude (high-digits mag) (+ n log-radix))))
  167.       
  168. (define (shift-right-neg-magnitude mag n)
  169.   (negate-magnitude
  170.    (let digit-recur ((mag mag) (n n) (carry 1))
  171.      (let* ((low (negate-low-digit mag carry))
  172.         (next-carry (if (>= low radix) 1 0)))
  173.        (if (<= n (- 0 log-radix))
  174.        (digit-recur (high-digits mag) (+ n log-radix) next-carry)
  175.        (let ((mask (- (arithmetic-shift 1 (- 0 n)) 1)))
  176.          (let recur ((mag mag) (n n) (carry carry))
  177.            (let* ((low (negate-low-digit mag carry))
  178.               (carry (if (>= low radix) 1 0))
  179.               (high (high-digits mag))
  180.               (next (negate-low-digit high carry)))
  181.          (adjoin-digit
  182.           (bitwise-ior (arithmetic-shift low n)
  183.                    (arithmetic-shift (bitwise-and mask next)
  184.                          (+ n log-radix)))
  185.           (if (zero-magnitude? high)
  186.               (integer->magnitude carry)
  187.               (recur high n carry)))))))))))
  188.  
  189. (define log-radix
  190.   (do ((i 0 (+ i 1))
  191.        (r 1 (* r 2)))
  192.       ((>= r radix) i)))
  193.  
  194. ;(define (tst)
  195. ;  (let* ((m (random))
  196. ;         (n (bitwise-and m 63))
  197. ;         (m1 (integer-arithmetic-shift
  198. ;              (integer-arithmetic-shift m n)
  199. ;              (- 0 n))))
  200. ;    (list n m m1 (= m m1))))
  201. ;(define random (make-random 17))
  202.  
  203.  
  204. (define-integer-method bitwise-not-table (when-integers integer-bitwise-not))
  205. (define-integer-method bitwise-and-table (when-integers integer-bitwise-and))
  206. (define-integer-method bitwise-ior-table (when-integers integer-bitwise-ior))
  207. (define-integer-method bitwise-xor-table (when-integers integer-bitwise-xor))
  208.  
  209. (define-integer-method arithmetic-shift-table
  210.   (when-integers integer-arithmetic-shift))
  211.  
  212.  
  213.