;;; Spice Lisp numeric package, SPNUM. -*-Lisp-*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; Author : Brian G. Milnes (Milnes@CMU-20C)
;;; Please report bugs, gripes or comments about this code to both
;;; Scott Fahlman and me.
;;;
;;; I. ABSTRACT
;;;
;;; Spnum is the spice lisp code implementing the non-transcendental
;;; and non-irrational sections of the number chapter (12) of the
;;; common lisp manual. Spnum is used only for the spice lisp implementation on
;;; the perq. This package contains code for
;;;
;;; - fixnum operations that overflow to a bignum,
;;; - integer operations that produce a ratio,
;;; - bignum operations,
;;; - fixnum bignum operations,
;;; - and ratio operations.
;;;
;;; Any functions which end in -escape are designed to be called
;;; by the PERQ micro code whenever it can not handle the arguments,
;;; or result, of an arithmetic operation.
;;;
;;;
;;; CONTENTS
;;;
;;;
;;; I. Abstract
;;; IV. Accessing macros
;;; 1. Random macros
;;; V. Relational operations
;;; VI. Arithmetic operations
;;; 2. Fixnum operations
;;; 3. Bignum operations
;;; 4. Ratio operations
;;; 5. Integer and mixed mode operations
;;; 6. Arithmetic bugout dispatch routines
;;; VII. Logical operations
;;; VIII. Exported routines (other)
;;;
;;; IV. ACCESSING MACROS
;;;
;;;
;;;
;
;;;
;;;
;;; 1. Random macros
;;;
;;; Cons-a-Bignum generates a bignum, of size n subtype s.
(eval-when (compile)
(defmacro cons-a-bignum (n)
`(%primitive alloc-bignum ,n 3))
(defmacro bignum-length (b)
`(%sp-get-vector-length ,b))
(defmacro complement (X)
`(if (zerop ,X) 1 0))
;;; One for negative, zero for positive.
(defmacro bignum-sign (b)
`(let ((b ,b))
(ldb (byte 1 7) (%sp-v-access b (1- (bignum-length b))))))
(defmacro integerize1 (n)
`(let ((n ,n))
(if (fixnump n) n (integerize n (bignum-length n)))))
;;; Fills the field with sign bits, and makes sure that it's large enough.
(defmacro create-bignum (n s)
`(let ((byte (- ,s))
(size (max 4 ,n))) ;For Brian's code.
(do ((res (cons-a-bignum size))
(i 0 (1+ i)))
((= i size) res)
(%sp-v-store res i byte))))
(defmacro integer-compare (x y)
`(let ((x (integerize1 ,x))
(y (integerize1 ,y)))
(typecase x
(bignum (typecase y
(bignum (bignum-compare x y))
(fixnum (bignum-fixnum-compare x))))
(fixnum (typecase y
(bignum (bignum-fixnum-compare y))
(fixnum (fixnum-compare x y)))))))
;;;
;;; Fixnum-Sign returns the sign of a fixnum as the fixnum 0 or 1.
;;; VM:T
(defmacro fixnum-sign (X)
`(%sp-logldb 1 #,(1- %fixnum-length) ,X))
;;;
;;; Integer-sign returns the sign of any integer argument.
;;;
;;; VM:T
(defmacro integer-sign (x)
`(cond ((bignump ,x) (bignum-sign ,x))
((fixnump ,x) (fixnum-sign ,x))
(t (error "Non integer argument passed to integer-sign macro. ~%"))))
;;;
;;; Get-byte (P S N) returns a field of bytes from the integer
;;; N, whose highest order byte is position P and whose lowest
;;; order bit is in position P - S. Get-byte sign extends, and
;;; fills righthand zeros.
;;; VM:T
(defmacro get-byte (p s n)
`(if (> (- (1+ ,p) ,s) 0)
(%sp-ldb ,s (- (1+ ,p) ,s) ,n)
(if (< ,p 0) 0
(%sp-lsh (%sp-ldb (1+ ,p) 0 ,n)
(- ,s (1+ ,p))))))
;;;
;;; Fixable (X) returns true iff X is a number (of any type)
;;; that can be represented as a fixnum.
;;; VM:T
(defmacro fixable (X)
`(<= max-negative-fixnum ,x max-positive-fixnum))
;;;
;;; Get-fixnum-byte (P S X) returns right packed the next s bits
;;; whose highest bit is P and whose lowest bit is P-S from the fixnum
;;; X. if the bits run off the right hand side of the fixnum, the spaces
;;; are padded with 0's. if P is too large, then an run time error will occur.
;;; VM:()
(defmacro get-fixnum-byte (p s x)
`(cond ((< ,p 0) 0)
((< (- ,p ,s) 0) (%sp-logdpb (%sp-logldb (1+ ,p) 0 ,x)
(1+ ,p) (- 7 ,p) 0))
(t (%sp-logdpb (%sp-logldb ,s (1+ (- ,p ,s)) ,x)
,s (- 8 ,s) 0))))
) ;Close of eval-when(compile).
;;;
;;;
;;; 4. Not macros, but ...
(defun copy-xnum (n)
(let ((res (cons-a-bignum (bignum-length n))))
(%sp-byte-blt n 0 res 0 (bignum-length n))
res))
;;; Byte-bash and friends?
;;; Returns a bignum of the specified size, "equal" to the given integer.
(defun sizify (n size)
(let ((res (create-bignum size (if (minusp n) 1 0))))
(cond ((fixnump n)
(do ((i 0 (1+ i))
(n n (ash n -8)))
((= i 4))
(%sp-v-store res i n)))
(t (bash-bytes n size 0 res)))
res))
(defun nsizify (n size)
(if (and (bignump n)
(>= (bignum-length n) size))
(%sp-shrink-vector n size)
(sizify n size)))
(defun bash-bytes (f i p n)
"Replaces the i bytes at byte p of xnum n with the lower bytes of f."
(let* ((i (min i (bignum-length f)))
(end (min (+ p i) (bignum-length n))))
(%sp-byte-blt f 0 n p end)
n))
;;;
;;; V. RELATIONAL OPERATIONS
;;;
;;;
;;;
;;;
;;;
;;; Fixnum-Compare (X Y) returns '> '< or '= depending upon
;;; whether X = Y or X > Y or X < Y.
;;; VM:T
(eval-when (compile)
(defmacro fixnum-compare (X Y)
`(or (and (= ,x ,y) '=)
(and (> ,x ,y) '>)
'<))
)
;;; bignum-fixnum-compare returns > or < but never =.
;;; VM:T
(defun bignum-fixnum-compare (b)
(if (= 0 (bignum-sign b)) '> '<))
;;;
;;; Bignum-compare (X Y) returns '= '> or '< depending upon
;;; whether X = Y, X > Y or X < Y.
;;;
;;; VM:T
;;; Returns <, >, or =.
(defun bignum-compare (x y)
(let ((trap nil)
(sign-x (bignum-sign x))
(sign-y (bignum-sign y))
(length-x (bignum-length x))
(length-y (bignum-length y)))
(if (not (eq (setq trap (zerop sign-x))
(zerop sign-y)))
(if trap '> '<)
(if (not (eq '= (setq trap (fixnum-compare length-x length-y))))
(if (zerop sign-x)
trap
(if (eq trap '>) '< '>))
(do ((byte-counter (1- length-x)
(1- byte-counter)))
((or (not (eq '= (setq trap
(fixnum-compare
(%sp-v-access x byte-counter)
(%sp-v-access y byte-counter)))))
(eq '= (fixnum-compare byte-counter 0)))
trap)
)))))
(defun numerator (x)
"Returns the numerator of a rational."
(%primitive numerator x))
(defun denominator (x)
"Returns the denominator of a rational."
(%primitive denominator x))
;;; ratio-compare returns >,< or = as a comparison of
;;; two ratios.
;;; Returns > < or =.
(defun ratio-compare (x y)
(let* ((numx (%primitive numerator x))
(denx (%primitive denominator x))
(numy (%primitive numerator y))
(deny (%primitive denominator y))
(xsign (minusp numx)) ; Strange way to hold sign, huh ?
(ysign (minusp numy)))
(cond ((not (eq xsign ysign)) (if xsign '< '>))
((and (zerop numx) (zerop numy)) '=)
((and (= numx numy) (= denx deny)) '=)
((= numx numy)
(cond ((> denx deny)
(if xsign '> '<))
(t (if xsign '< '>))))
((= denx deny) (if (> numx numy) '> '<))
(t (compare-numbers (* numx deny) (* numy denx))))))
;;; ratio-integer-compare returns >,< or = as a comparison
;;; of the arguments x and y.
;;; vm:T
(defun ratio-integer-compare (x y)
(let* ((numx (%primitive numerator x))
(denx (%primitive denominator x))
(xsign (minusp numx)))
(cond ((not (eq xsign (minusp y)))
(if xsign '< '>))
((and (= 1 denx))
(compare-numbers numx y))
(t (multiple-value-bind (xi xr) (truncate numx denx)
(case (compare-numbers xi y)
(> '>)
(< '<)
(= (cond ((zerop xr) '=)
((minusp xr) '<)
(t '>)))))))))
;;; 2. FIXNUM OPERATIONS
;;;
;;;
;;; Integerize reduces any vector of type xnum into
;;; it's arithmetically correct integer representation.
;;; VM:T
(defun integerize (b v-length)
(let* ((bit-length (integer-length b))
(length-needed (1+ (truncate bit-length 8))))
(if (< bit-length %fixnum-length)
(%sp-logdpb (%sp-v-access b 3) 4 24
(%sp-logdpb (%sp-v-access b 2) 8 16
(%sp-logdpb (%sp-v-access b 1) 8 8
(%sp-v-access b 0))))
(if (> v-length length-needed)
(%sp-shrink-vector b length-needed) b))))
;;; Add-in-byte multiplies two bytes together and adds
;;; them plus the carry, into the bignum X at I and
;;; returns the carry. The index I is an 8 bit byte index into
;;; the vector.
(defun add-in-bytes (b1 b2 x i carry)
(let ((sum (+ (%sp-lsh (%sp-v-access x (1+ i)) 8) (%sp-v-access x i)
(* b1 b2) (if (zerop carry) 0 256))))
;; The carry is 16 bit, so I must slide it 8 bits left to get it
;; in the right byte.
(%sp-v-store x i sum)
(%sp-v-store x (1+ i) (%sp-logldb 8 8 sum))
(%sp-logldb 1 16 sum)))
;;; Add-in-carry adds a carry bit into a bignum at a given byte.
;;; VM:T
(defun add-in-carry (v i)
(do ((j (1+ i) (1+ j))
(sum (zerop (%sp-logldb 1 8 (%sp-v-store v i (1+ (%sp-v-access v i)))))
(zerop (%sp-logldb 1 8 (%sp-v-store v j (1+ (%sp-v-access v j))))))
)
(sum)))
;;; %sp-fixnum* multiplies two fixnums and returns the integer result,
;;; be it bignum or fixnum.
;;; VM:T
(defun %sp-fixnum* (x y)
(let* ((xs (fixnum-sign x))
(ys (fixnum-sign y))
(new-s (if (= xs ys) 0 1))
(x (if (zerop xs) x (- x)))
(y (if (zerop ys) y (- y))))
(cond ((not (and (fixnump x) (fixnump y)))
(if (zerop new-s) (* x y) (- (* x y))))
(t (let ((xl (integer-length x))
(yl (integer-length y)))
(cond ((or (zerop xl) (zerop yl)) 0)
(t (let* ((xb (1+ (truncate xl 8)))
(yb (1+ (truncate yl 8)))
(zb (+ xb yb))
(z (cons-a-bignum zb))
(carry 0))
(do ((xi 0 (1+ xi))
(xbyte 0)
(xbs 8. (if (= xi 2) 4 8)))
((= xi xb))
(setq xbyte (%sp-ldb xbs (* 8 xi) x))
(unless (zerop xbyte)
(do ((yi 0 (1+ yi))
(yi+xi xi (1+ yi+xi))
(ybyte 0)
(ybs 8 (if (= yi 2) 4 8)))
((= yi yb)
(unless (zerop carry)
(add-in-carry
z (+ yb xi 1))))
(setq ybyte (%sp-ldb ybs (* 8 yi) y))
(unless (zerop ybyte)
(setq carry (add-in-bytes
ybyte xbyte
z yi+xi carry))))))
(let ((z (integerize z zb)))
(if (zerop new-s) z (- z)))))))))))
;;; %sp-fixnum/ builds a ratio of the arguments x and y.
;;; It knows that any arguments the microcode has bugged out
;;; on must be an uneven division, or an fixnum division whose
;;; quotient is a bignum. So if args are most-negative-fixnum and -1, then it
;;; returns (1+ most-positive-fixnum) or it simply builds a ratio of them.
;;; VM:T
(defun %sp-fixnum/ (x y)
(cond ((and (= -1 y) (= x most-negative-fixnum)) (1+ most-positive-fixnum))
(t (let ((gcd-x-y (gcd x y)))
(unless (= gcd-x-y 1)
(setq x (/ x gcd-x-y)
y (/ y gcd-x-y)))
(cond ((minusp y)
(%primitive make-ratio (- x) (- y)))
(t
(%primitive make-ratio x y)))))))
;;; %sp-fixnum+ does an integer addition, into a bignum of length 4
;;; which is integerized into a fixnum or a bignum, or into
;;; a fixnum, which is sign extended.
;;; VM:t
(defun %sp-fixnum+ (x y)
(let* ((xs (fixnum-sign x))
(ys (fixnum-sign y))
(same-sign (= xs ys)))
(cond (same-sign
(let* ((z (cons-a-bignum 4))
(sum1 (+ (%sp-logldb 16 0 x)
(%sp-logldb 16 0 y)))
(sum2 (+ (%sp-logldb 12 16 x)
(%sp-logldb 12 16 y)
(%sp-logldb 1 16 sum1))))
(unless (zerop xs)
(setq sum2 (%sp-logdpb 255 3 13 sum2)))
(%sp-typed-v-store 4 z 0 sum1)
(%sp-typed-v-store 4 z 1 sum2)
(integerize z 4)))
(t (let* ((sum1 (+ (%sp-logldb 16 0 x)
(%sp-logldb 16 0 y)))
(sum2 (+ (%sp-logldb 12 16 x)
(%sp-logldb 12 16 y)
(%sp-logldb 1 16 sum1))))
(%sp-logdpb sum2 12 16 sum1))))))
;;; %sp-fixnum- does a subtraction into a 4 byte xnum, or a fixnum.
;;; VM:t
(defun %sp-fixnum- (x y)
(let ((xs (fixnum-sign x))
(ys (fixnum-sign y)))
(cond ((= xs ys)
(let* ((diff1 (- (%sp-logldb 16 0 x)
(%sp-logldb 16 0 y)))
(diff2 (- (%sp-logldb 12 16 x)
(%sp-logldb 12 16 y)
(if (minusp diff1) 1 0))))
(%sp-logdpb diff2 12 16 diff1)))
(t (let* ((diff1 (- (%sp-logldb 16 0 x)
(%sp-logldb 16 0 y)))
(diff2 (- (%sp-logldb 12 16 x)
(%sp-logldb 12 16 y)
(if (minusp diff1) 1 0))))
(cond ((= xs (%sp-logldb 1 11 diff2)) ; No overflow.
(%sp-logdpb diff2 12 16 diff1))
(t (let ((z (cons-a-bignum 4)))
(%sp-typed-v-store 4 z 0 diff1)
(%sp-typed-v-store
4 z 1
(if (zerop xs) diff2
(%sp-logdpb 255 4 12 diff2)))
(integerize z 4)))))))))
;;; 3. Bignum operations
;;;
;;;
;;; Stuff used in bignum printing.
;;;
;;; Differs from previous in that we do not need to check for
;;; leading zeros. The bignum may have any length (including zero).
(defun new-integerize (bignum)
(let ((len (bignum-length bignum)))
(cond ((or (> len 4)
(and (= len 4) (>= (%sp-v-access bignum 3) 8)))
bignum)
(t (do ((i (1- len) (1- i))
(res (- (bignum-sign bignum))
(%sp-logdpb res 19 8 (%sp-v-access bignum i))))
((minusp i) res))))))
;;; Special division for printing et al.
;;;
;;; Both divisor and dividend must be positive, and the divisor must
;;; be of integer-length <= 19 (the closer the better).
;;;
;;; This uses two successive loops for convenience, the first collecting
;;; a remainder less than the fixnum divisor (might as well truncate),
;;; then a second to actually put the results back. The bignum
;;; result may still be of fixnum size, and hence must be checked.
;;; Because of the first loop (and the shrink that follows it), this check
;;; is easier than previous ones.
(defun bignum-fixnum-divide-inplace (big fix)
(do ((byte (1- (bignum-length big)) (1- byte))
(remainder (- (bignum-sign big)))
tmp)
((minusp byte)
(values (integerize big (bignum-length big)) remainder))
(multiple-value-setq (tmp remainder)
(truncate (%sp-logdpb remainder 19 8
(%sp-v-access big byte))
fix))
(%sp-v-store big byte tmp)))
;
;(defun bignum-fixnum-divide-inplace (big fix)
; (do ((tmp 0)
; (remainder 0)
; (byte (1- (bignum-length big)) (1- byte)))
; ((not (zerop tmp)) ;Plusp compares.
; (%sp-shrink-vector big (+ byte 2))
; (%sp-v-store big (1+ byte) tmp)
; (do ((byte byte (1- byte)))
; ((minusp byte)
; (values (new-integerize big) remainder))
; (multiple-value-setq (tmp remainder)
; (truncate (%sp-logdpb remainder 19 8 (%sp-v-access big byte))
; fix))
; (%sp-v-store big byte tmp)))
; (multiple-value-setq (tmp remainder)
; (truncate (%sp-logdpb remainder 19 8 (%sp-v-access big byte))
; fix))))
;;;
;;; More esoterics. Shifting in place.
;;;
;;; The result of a negative shift of ash-in-place may result in a fixnum,
;;; so the result should always be setq'd if it is to be kept
;;; (just like any other destructive operations).
(defun byte-ash-in-place (n c)
(let* ((length (bignum-length n))
(newlen (max 0 (+ length c))))
(cond ((zerop newlen) (- (bignum-sign n)))
(t (%sp-byte-blt n (max 0 (- c)) n (max 0 c) newlen)
(%sp-shrink-vector n newlen)
(new-integerize n)))))
(defun ash-in-place (n i)
(if (fixnump n) (ash n i)
(let* ((len (bignum-length n))
(sign (- (bignum-sign n)))
(top (%sp-logdpb (%sp-v-access n (1- len)) 8 0 sign)))
(cond ((zerop i) n)
((plusp i)
(if (> i (- 7 (integer-length top))) (ash n i)
(do ((byte 1 (1+ byte))
(remainder (ash (%sp-v-store
n 0 (ash (%sp-v-access n 0) i)) -8)
(ash (%sp-v-store
n byte (%sp-logdpb
(%sp-v-access n byte)
8 i remainder))
-8)))
((= len byte) n))))
(t (multiple-value-bind (bytes bits) (truncate i 8)
(setq n (ash n bytes))
(if (fixnump n) (ash n bits)
(let ((newlen-1 (1- (bignum-length n)))
(-bits (- bits))
(bits+8 (+ 8 bits)))
(do ((byte newlen-1 (1- byte))
(previous sign))
((minusp byte)
(if (> (- bits) (integer-length top))
(%sp-shrink-vector n newlen-1)
n))
(%sp-v-store
n byte (%sp-logdpb previous -bits bits+8
(ash (Setq previous
(%sp-v-access n
byte))
bits))))))))))))
;;; %sp-bignum* multiplies two bignums together.
;;; VM:T
(defun %sp-bignum* (a b)
(let* ((as (bignum-sign a))
(bs (bignum-sign b))
(a (if (= as 0) a (- a)))
(b (if (= bs 0) b (- b)))
(new-sign (if (= as bs) 0 1)))
(cond ((or (fixnump a) (fixnump b))
(if (zerop new-sign) (* a b) (- (* a b))))
(t (let* ((length-a (bignum-length a))
(length-b (bignum-length b))
(length-c (+ length-a length-b))
(c (cons-a-bignum length-c)))
;; swap the longer bignum into a.
(if (> length-b length-a)
(psetq length-a length-b
length-b length-a
a b
b a))
;; byte by byte multiply with 16 bit add in's to the bignum c.
(do ((b←index 0 (1+ b←index))
(byte-in-b 0))
((= b←index length-b)
(if (zerop new-sign) (integerize c length-c)
(- (integerize c length-c))))
(setq byte-in-b (%sp-v-access b b←index))
(unless (zerop byte-in-b)
(do ((carry 0)
(a←index 0 (1+ a←index))
(byte-in-a 0)
(A+b←index b←index (1+ a+b←index)))
((= a←index length-a)
(unless (zerop carry)
(add-in-carry
c (+ length-a b←index 1))))
(setq byte-in-a (%sp-v-access a a←index))
(unless (= byte-in-a 0)
(setq carry (add-in-bytes
byte-in-a byte-in-b
c a+b←index carry)))))))))))
;;; Gb16 does a sign extending 16 bit vector access of vector.
;;; Pos is the 8 bit index into vector, length is 1- the number of
;;; 8 bit entries and sign-byte is a 16 bit byte of sign bits.
;;; VM:T
(defun gb16 (vector pos length sign-byte)
(cond ((> pos length) sign-byte)
((= pos length)
(%sp-logdpb sign-byte
8. 8. (%sp-v-access vector pos)))
(t (%sp-typed-v-access 4 vector (truncate pos 2)))))
(defun gb8 (vector pos length sign-byte)
(cond ((> pos length) (%sp-logldb 8 0 sign-byte))
(t (%sp-v-access vector pos))))
;;; %sp-bignum+ is the internal bignum addition routine.
;;; VM:T
(defun %sp-bignum+ (a b)
(let* ((length-a (bignum-length a))
(length-b (bignum-length b))
(mab (max length-a length-b))
(a-sign (bignum-sign a))
(b-sign (bignum-sign b))
(same-sign (if (= a-sign b-sign) t nil))
(carry 0)
(c (cons-a-bignum (if same-sign (1+ mab) mab)))
(la-1 (1- length-a))
(lb-1 (1- length-b))
(asb (if (zerop a-sign) 0 65535))
(bsb (if (zerop b-sign) 0 65535)))
(do ((1-mab (1- mab))
(i 0 (+ i 2))
(sum 0))
((>= i 1-mab)
(when (= i 1-mab)
(setq sum (+ (gb8 a i la-1 asb)
(gb8 b i lb-1 bsb) carry))
(%sp-v-store c i sum)))
(setq sum (+ (gb16 a i la-1 asb)
(gb16 b i lb-1 bsb)
carry))
(setq carry (%sp-logldb 1 16 sum))
(%sp-typed-v-store 4 c (truncate i 2) sum))
(cond (same-sign
(cond ((not (= a-sign
(%sp-logldb
1 7 (%sp-v-access c (1- mab)))))
(%sp-v-store c mab asb)
C) ;SKH.
(t (%sp-shrink-vector c mab))))
(t (integerize c mab)))))
;;; %sp-bignum- does a signed subtraction of two bignums.
;;;
(defun %sp-bignum- (a b)
(let* ((la (bignum-length a))
(lb (bignum-length b))
(mab (max la lb))
(as (bignum-sign a))
(bs (bignum-sign b))
(la-1 (1- la))
(lb-1 (1- lb))
(asb (if (zerop as) 0 65535))
(bsb (if (zerop bs) 0 65535))
(carry 0))
(cond ((eq as bs)
(let ((z (cons-a-bignum mab)))
(do ((i 0 (+ i 2))
(diff 0)
(mab-1 (1- mab)))
((>= i mab-1)
(when (= i mab-1)
(%sp-v-store z mab-1
(- (gb8 a i la-1 asb)
(gb8 b i lb-1 bsb)
carry)))
(integerize z mab))
(setq diff (- (gb16 a i la-1 asb)
(gb16 b i lb-1 bsb)
carry))
(setq carry (if (minusp diff) 1 0))
(%sp-typed-v-store 4 z (truncate i 2) diff))))
(t (let ((z (cons-a-bignum (1+ mab))))
(do ((i 0 (+ i 2))
(diff 0))
((>= i mab)
(unless (zerop as)
(%sp-v-store z mab 255))
(integerize z (1+ mab)))
(setq diff (- (gb16 a i la-1 asb)
(gb16 b i lb-1 bsb)
carry))
(setq carry (if (minusp diff) 1 0))
(%sp-typed-v-store 4 z (truncate i 2) diff)))))))
;;; Bignum-negate returns the negation of any bignum.
;;; VM:T.
(defun bignum-negate (X)
(let* ((size (bignum-length x))
(xsign (bignum-sign x))
(neg-size (if (zerop xsign) size (1+ size)))
(neg (cons-a-bignum neg-size)))
;;; If x is negative, neg must be one byte longer just in case
;;; the negation overflows.
(do ((byte 0 (+ byte 2))
(size-1 (1- size))
(carry 1))
((>= byte size-1)
(when (= byte size-1)
(%sp-v-store neg byte
(+ (- #2r11111111
(%sp-v-access x byte))
carry))))
(setq carry
(%sp-logldb 1 16
(%sp-typed-v-store
4 neg (truncate byte 2)
(+ (- #2r1111111111111111
(%sp-typed-v-access 4 x (truncate byte 2)))
carry)))))
(integerize neg neg-size)))
;;;
;;; 4. Ratio operations
;;; Build-ratio takes two integer arguments and builds
;;; the rational number which is thier quotient.
;;; When reduction is implemented, it will go in here.
;;; VM:T
(defun build-ratio (x y)
(multiple-value-bind (q r) (truncate x y)
(if (zerop r) q
(let ((gcd (gcd x y)))
(unless (= gcd 1)
(setq x (/ x gcd)
y (/ y gcd)))
(cond ((minusp y) (%primitive make-ratio (- x) (- y)))
(t (%primitive make-ratio x y)))))))
;;; Rational produces a rational number for any numeric argument.
;;; Rational assumed that the floating point is completely accurate.
(defun rational (x)
(typecase x
(float (multiple-value-bind (f e) (decode-float x)
(let* ((precision (float-precision f))
(f (truncate (scale-float f precision))))
(if (minusp e)
(build-ratio f (ash 1 (+ precision (abs e))))
(build-ratio (ash f e) (ash 1 precision))))))
(rational x)
(otherwise (error "Argument not a non complex number, ~A."
x))))
;;; Rationalize does a rational, but it assumes that floats
;;; are only accurate to their precision, and generates a good
;;; rational aproximation of them.
(eval-when (compile)
(remprop 'long-float-epsilon '%constant))
;;;
(defun rationalize (x)
(typecase x
(rational x)
(short-float (rationalize-float x short-float-epsilon))
(long-float (rationalize-float x long-float-epsilon))
(otherwise (error "Argument not a non complex number, ~A."
x))))
;;; Thanks to Kim Fateman, who stole this function rationalize-float
;;; from macsyma's rational. Macsyma'a rationalize was written
;;; by the legendary Gosper (rwg). Gosper is now working for xerox
;;; at parc. Guy Steele said about Gosper, "He has been called the
;;; only living 17th century mathematician and is also the best
;;; pdp-10 hacker I know." So, if you can understand or debug this
;;; code you win big.
(defun rationalize-float (x &optional (eps long-float-epsilon))
(cond ((minusp x) (- (rationalize (- x))))
((zerop x) 0)
(t (let ((y ())
(a ()))
(do ((xx x (setq y (/ 1.0 (- xx (float a x)))))
(num (setq a (truncate x))
(+ (* (setq a (truncate y)) num) onum))
(den 1 (+ (* a den) oden))
(onum 1 num)
(oden 0 den))
((and (not (zerop den))
(not (> (abs (/ (- x (/ (float num x)
(float den x)))
x))
eps)))
(/ num den)))))))
;;; %sp-ratio* does a ratio to ratio multiplication.
;;; VM:T
(defun %sp-ratio* (x y)
(let ((numx (%primitive numerator x))
(numy (%primitive numerator y))
(denx (%primitive denominator x))
(deny (%primitive denominator y)))
(let ((gcdnumx (gcd numx deny))
(gcdnumy (gcd numy denx)))
(let ((num (* (/ numx gcdnumx) (/ numy gcdnumy)))
(den (* (/ denx gcdnumy) (/ deny gcdnumx))))
(if (= 1 den) num
(%primitive make-ratio num den))))))
;;; %sp-ratio/ does a ratio to ratio division.
;;; vm:T
(defun %sp-ratio/ (x y)
(%sp-ratio* x (%sp-ratio-inverse y)))
;;; %sp-ratio-negate negates the numerator of the ratio.
;;; VM:T
(defun %sp-ratio-negate (x)
(%primitive make-ratio (- (%primitive numerator x)) (%primitive denominator x)))
;;; %sp-ratio+ does a ratio to ratio addition.
;;; VM:T
(defun %sp-ratio+ (x y)
(let ((denx (%primitive denominator x))
(deny (%primitive denominator y)))
(build-ratio (+ (* (%primitive numerator x) deny)
(* (%primitive numerator y) denx))
(* denx deny))))
;;; %sp-ratio- does a ratio to ratio subtraction.
;;; VM:T
(defun %sp-ratio- (x y)
(let ((denx (%primitive denominator x))
(deny (%primitive denominator y)))
(build-ratio (- (* (%primitive numerator x) deny)
(* (%primitive numerator y) denx))
(* denx deny))))
;;; %sp-ratio-inverse inverts a ratio.
;;; VM:T
(defun %sp-ratio-inverse (x)
(let ((numx (%primitive numerator x))
(denx (%primitive denominator x)))
(when (zerop numx)
(error "%sp-ratio-inverse : the inverse of zero is not defined."))
(cond ((= 1 numx) denx)
((= -1 numx) (- denx))
((minusp denx)
(%primitive make-ratio (- denx) (- numx)))
(t (%primitive make-ratio denx numx)))))
;;;
;;; 5. Integer and mixed mode operations
;;;
;;; %sp-integer/ does a division of two integers.
;;; VM:T
(defun %sp-integer/ (x y)
(when (zerop y)
(error "~A / ~A" x y))
(multiple-value-bind (zi zr) (truncate x y)
(if (zerop zr) zi
(build-ratio x y))))
;;; %sp-ratio-integer* multiplies a ratio by an integer.
;;; vm:t
(defun %sp-ratio-integer* (x y)
(let* ((den (%primitive denominator x))
(gcd (gcd den y)))
(build-ratio (* (%primitive numerator x) (/ y gcd)) (/ den gcd))))
;;; %sp-ratio-integer/ divides a ratio by an integer.
;;; VM:T
(defun %sp-ratio-integer/ (x y)
(when (zerop y)
(error "Attempt to divide ~A by zero." x))
(let* ((num (%primitive numerator x))
(gcd (gcd num y)))
(%primitive make-ratio (/ num gcd) (* (%primitive denominator x) (/ y gcd)))))
;;; %sp-ratio-integer+ adds an integer to a ratio.
;;; VM:T
(defun %sp-ratio-integer+ (x y)
(let ((denx (%primitive denominator x)))
(build-ratio
(+ (%primitive numerator x) (* denx y))
denx)))
;;; %sp-ratio-integer- subtracts an integer from a ratio.
(defun %sp-ratio-integer- (x y)
(let ((denx (%primitive denominator x)))
(build-ratio
(- (%primitive numerator x) (* denx y))
denx)))
;;; gfb8 and gfb16 get a sign extended fixnum byte of 8 or 16 bits.
;;; The index, i, is an 8 bit index, and s is a byte of the sign of f.
(defun gfb8 (f i s)
(case i
((0 1 2) (%sp-logldb 8 (* i 8) f))
(3 (%sp-logdpb s 4 4 (%sp-logldb 4 24 f)))
(t (%sp-logldb 8 0 s))))
;;; I is an 8 bit index.
(defun gfb16 (f i s)
(case i
(0 (%sp-logldb 16 0 f))
(2 (%sp-logdpb s 4 12 (%sp-logldb 12 16 f)))
(t (%sp-logldb 16 0 s))))
;;; %sp-bignum-fixnum* multiplies a bignum by a fixnum.
;;; VM:T
(defun %sp-bignum-fixnum* (x y)
(let* ((xs (bignum-sign x))
(ys (fixnum-sign y))
(zs (eq xs ys))
(x (if (zerop xs) x (- x)))
(y (if (zerop ys) y (- y))))
(cond ((or (not (bignump x)) (not (fixnump y)))
(if zs (* x y) (- (* x y))))
(t (let* ((lenx (bignum-length x))
(bit-length (integer-length y))
(byte-len (1+ (truncate bit-length 8)))
(c (cons-a-bignum (+ byte-len lenx))))
(do ((y←index 0 (1+ y←index))
(byte-in-y 0))
((= y←index byte-len) (let ((c (integerize
c (+ byte-len lenx))))
(if zs c (- c))))
(setq byte-in-y (gfb8 y y←index 0))
(unless (zerop byte-in-y)
(do ((carry 0)
(x←index 0 (1+ x←index))
(byte-in-x 0)
(x+y←index y←index (1+ x+y←index)))
((= x←index lenx)
(unless (zerop carry)
(add-in-carry c (+ lenx x←index))))
(setq byte-in-x (%sp-v-access x x←index))
(setq carry (add-in-bytes byte-in-x byte-in-y
c x+y←index
carry))))))))))
;;; %sp-bignum-fixnum+ adds a bignum to a fixnum, using twos
;;; complement addition.
(defun %sp-bignum-fixnum+ (b f)
(let* ((bs (bignum-sign b))
(bsign-byte (- bs))
(bl (bignum-length b))
(1-bl (1- bl))
(fs (fixnum-sign f))
(fsign-byte (- fs))
(carry 0))
(cond ((eq bs fs) ; if they have the same sign,
(let* ((z (cons-a-bignum (1+ bl)))); make a larger xnum.
(do ((i 0 (+ i 2))
(sum 0))
((>= i bl)
(cond ((= bs (%sp-logldb 1 15 sum))
(%sp-shrink-vector z bl))
(t (unless (zerop bs)
(%sp-v-store z bl bsign-byte))
z)))
(setq sum (+ (gb16 b i 1-bl bsign-byte)
(gfb16 f i fsign-byte)
carry))
(setq carry (%sp-logldb 1 16 sum))
(%sp-typed-v-store 4 z (truncate i 2) sum))))
(t (let* ((z (cons-a-bignum bl))
(carry 0))
(do ((i 0 (+ i 2))
(sum 0))
((>= i 1-bl)
(when (= i 1-bl)
(setq sum (+ (gb8 b i 1-bl bsign-byte)
(gfb8 f i fsign-byte)
carry))
(%sp-v-store z 1-bl sum))
(integerize z bl))
(setq sum (+ (gb16 b i 1-bl bsign-byte)
(gfb16 f i fsign-byte)
carry))
(setq carry (%sp-logldb 1 16 sum))
(%sp-typed-v-store 4 z (truncate i 2) sum)))))))
;;; %sp-fixnum-bignum- subtracts a bignum from a fixnum.
(defun %sp-fixnum-bignum- (f b)
(let* ((fs (fixnum-sign f))
(fsign-byte (- fs))
(bs (bignum-sign b))
(bsign-byte (- bs))
(bl (bignum-length b))
(1-bl (1- bl)))
(cond ((eq fs bs)
(let* ((z (cons-a-bignum bl))
(carry 0))
(do ((i 0 (+ i 2))
(sum 0))
((>= i 1-bl)
(when (= i 1-bl)
(%sp-v-store z 1-bl
(- (%sp-logldb 8 0 fsign-byte)
(gb8 b i 1-bl bsign-byte)
carry)))
(integerize z bl))
(setq sum (- (gfb16 f i fsign-byte)
(gb16 b i 1-bl bsign-byte)
carry))
(setq carry (if (minusp sum) 1 0))
(%sp-typed-v-store 4 z (truncate i 2) sum))))
(t (let ((z (cons-a-bignum (1+ bl)))
(carry 0))
(do ((i 0 (+ i 2))
(sum 0))
((>= i bl)
(unless (zerop fs)
(%sp-v-store z bl 255))
(integerize z (1+ bl)))
(setq sum (- (gfb16 f i fsign-byte)
(gb16 b i 1-bl bsign-byte)
carry))
(setq carry (if (minusp sum) 1 0))
(%sp-typed-v-store 4 z (truncate i 2) sum)))))))
;;;
;;; Spicelisp Gcd.
;;; Speed is very a important factor in the calculation of
;;; Gcd, because the implementation of rational numbers uses Gcd
;;; very heavily.
;;; Gcd of two nonnegative integers, no type checking.
;;; Based on the Lehman multiple precision algorithm in Knuth vol. 2.
(defun gcd2 (u v)
(cond ((zerop u) v)
((zerop v) u)
((= 1 u) (if (zerop v) 0 1)) ;For inverses.
((= 1 v) (if (zerop u) 0 1))
(t (let* ((k (do ((k 0 (1+ k)))
((or (oddp u) (oddp v)) k)
(setq u (ash u -1))
(setq v (ash v -1))))
(tee 0))
(cond ((oddp u)
(setq tee (- v))) ; falls into b4.
(t (setq tee (ash u -1)))) ; Setq tee to U/2 and then B4.
(do () ; B4 is the test, B3 the body.
((oddp tee))
(Setq tee (ash tee -1)))
(if (> tee 0)
(setq u tee)
(setq v (- tee)))
(setq tee (- u v)) ;B6
(do ()
((zerop tee) (ash u k))
(setq tee (ash tee -1)) ;B3 again.
(do ()
((oddp tee))
(setq tee (ash tee -1))) ;B3.
(if (> tee 0)
(setq u tee)
(setq v (- tee)))
(setq tee (- u v)))))))
(defun gcd (&rest args)
"Returns the greatest common divisor of the arguments, which must be
integers. Gcd with no arguments is defined to be 0."
(do ((args args (cdr args))
(gcd 0 (gcd2 gcd (abs (car args)))))
((null args) gcd)
(if (not (integerp (car args)))
(error "Gcd - argument not an integer: ~A"
(car args)))))
;;; Lcm.
;;; Lcm2 is defined this way so that operations won't unnecessarily bignumify.
(defun lcm2 (n m)
"Least common multiple of two nonzero integers. No type checking."
(* (/ (max n m) (gcd n m)) (min n m)))
(defun lcm (&rest args)
"Returns the least common multiple of one or more integers."
(do ((args args (cdr args))
(lcm 1 (lcm2 lcm (car args))))
((null args) lcm)
(cond ((not (integerp (car args)))
(error "Lcm: argument not an integer, ~A"
(car args)))
((zerop (car args)) ;Result is zero.
(dolist (arg (cdr args))
(if (not (integerp arg))
(error "Lcm: argument not an integer, ~A" arg)))
(return 0)))))
;;; %sp-Trunc-escape and its associated division and truncation
;;; routines.
;;; Fixnum-fixnum-divide is passed only positive fixnums, so
;;; it can call the microcode for its answers.
(eval-when (compile)
(defmacro fixnum-fixnum-divide (x y)
`(truncate ,x ,y))
;;; Converts the integer-length of the number to the byte length.
(defmacro bit-to-8-bit-byte (bits)
`(multiple-value-bind (q r) (truncate ,bits 8)
(if (zerop r) q (1+ q))))
)
;;; Bignum Division
;;;
;;;
;;; Integer-divide takes two integers and returns thier quotient and
;;; remainder.
;;; Divide-with-sign uses the function to divide u by v and checks
;;; usign and vsign to return the correctly signed q and r.
(eval-when (compile)
(defmacro divide-with-sign (function)
`(multiple-value-bind (q r) (,function u v)
(if usign
(if vsign (values q (- r))
(values (- q) (- r)))
(if vsign (values (- q) r)
(values q r))))))
(defun integer-divide (u v)
(typecase u
(fixnum (typecase v
(fixnum (truncate u v))
(bignum (values 0 u)) ;WHM 10-18-83
(otherwise
(error "~a must be an integer, truncate." v))))
(otherwise
(let* ((usign (minusp u))
(u (abs u))
(vsign (minusp v))
(v (abs v)))
(typecase u
(fixnum (typecase v
(fixnum (divide-with-sign truncate))
(bignum (if vsign (values 0 (- v))
(values 0 v)))))
(bignum (typecase v
(fixnum (divide-with-sign bignum-fixnum-divide))
(bignum (divide-with-sign bignum-divide)))))))))
;;; Implement Knuth's indexing scheme.
(defmacro knuth-u (bignum index &optional (length 'ulen))
`(let ((index (- ,length ,index 1)))
(if (minusp index) 0 (aref ,bignum index))))
(defsetf knuth-u (bignum index &optional (length 'ulen)) (new)
`(let ((index (- ,length ,index 1))
(new ,new))
(if (minusp index) new
(setf (aref ,bignum index) new))))
(defmacro knuth-v (bignum index &optional (length 'vlen))
`(aref ,bignum (- ,length ,index))))
;;; Part of the Knuth algorithm for division. Does step D4, p.258 (vol 2).
;;; Returns the borrow (-1 if there was one).
;;; May not work if u and v are the same byte size.
(defun new-multiply-and-subtract (u j v qhat)
(let ((vlen (bignum-length v))
(ulen (bignum-length u)))
(do ((i vlen (1- i))
(multiply-carry 0) ; Nonnegative.
(subtract-carry 0)) ; Nonpositive.
((zerop i)
(ash (incf (knuth-u u j ulen)
(- subtract-carry multiply-carry))
-8))
(let* ((subtrahend (+ multiply-carry (* qhat (knuth-v v i))))
(difference (- (+ subtract-carry (knuth-u u (+ j i)))
(ldb (byte 8 0) subtrahend))))
(setq multiply-carry (ash subtrahend -8)
subtract-carry (ash difference -8))
(setf (knuth-u u (+ j i) ulen) difference)))))
;;; Does step D6, except for decrementing qhat.
(defun new-add-back (u j v)
(let ((n (bignum-length v))
(ulen (bignum-length u))
(carry 0))
(do ((i n (1- i)))
((< i j))
(Setq carry (ash (incf (knuth-u u (+ j i) ulen)
(+ carry (knuth-v v i n)))
-8)))))
;;; Destructively modifies the new u and v.
;;; U and V are normalized, and d is what we shift the remainder by.
;(proclaim (inline do-bignum-division))
(defun do-bignum-division (u v d)
;; First, really normalize u and v so that indexing works. This may make them
;; look negative.
(let ((ulen (bignum-length u))
(vlen (bignum-length v)))
; (if (zerop (aref v (1- vlen)))
; (%primitive shrink-vector v (decf vlen)))
;( (((let ((new-u (%primitive alloc-bignum (1+ ulen) 3)))
; (dotimes (i ulen) (setf (aref new-u i) (aref u i)))
; (setq u new-u ulen (1+ ulen)))))
; ((= vlen (1- ulen)))
; (t (%primitive shrink-vector u (decf ulen))))
(if (= ulen vlen)
(let ((new-u (%primitive alloc-bignum (1+ ulen) 3)))
(dotimes (i ulen) (setf (aref new-u i) (aref u i)))
(setq u new-u ulen (1+ ulen))))
(let ((v1 (knuth-v v 1))
(v2 (knuth-v v 2))
(m (- ulen vlen)))
(do ((j 0 (1+ j))
(q (%primitive alloc-bignum (max 4 (1+ m)) 3))) ; For hackish system.
((> j m)
(values (integerize q (1+ m))
(ash (integerize u ulen) (- d))))
(let* ((qhat (do ((qhat (if (= (knuth-u u j) v1) 255
(truncate (+ (ash (knuth-u u j) 8)
(knuth-u u (1+ j)))
v1))
(1- qhat)))
((<= (* qhat v2)
(+ (ash (+ (ash (knuth-u u j) 8)
(knuth-u u (1+ j))
(- (* qhat v1)))
8)
(knuth-u u (+ 2 j))))
qhat)))
(borrow (new-multiply-and-subtract u j v qhat)))
(cond ((not (zerop borrow))
(setf (knuth-u q j m) (1- qhat))
(new-add-back u j v))
(t (setf (knuth-u q j m) qhat))))))))
(defun bignum-fixnum-divide (u v)
(let ((us (bignum-sign u))
(vs (if (plusp v) 0 1)))
(if (not (zerop us)) (setq u (- u)))
(if (not (zerop vs)) (setq v (- v)))
(let ((d (- 31 (integer-length v))))
(multiple-value-bind (div rem)
(do-bignum-division (ash u d) (ash v d) d)
(values (if (zerop (logxor us vs)) div (- div))
(if (zerop us) rem (- rem)))))))
(defun bignum-divide (u v)
(if (< u v)
(values 0 u)
(let ((us (bignum-sign u))
(vs (bignum-sign v)))
(if (not (zerop us)) (setq u (- u)))
(if (not (zerop vs)) (setq v (- v)))
(multiple-value-bind (bytes bits) (truncate (integer-length v) 8)
(let ((d (mod (- 8 bits) 8)))
(multiple-value-bind (div rem)
(do-bignum-division (ash u d) (ash v d) d)
(values (if (zerop (logxor us vs)) div (- div))
(if (zerop us) rem (- rem)))))))))
;;; Bignum-divide as above does not work. So here's the Milnes code.
;;; bignum-divide takes two positive bignums u,v of significant length
;;; ul and vl and returns thier quotient, q, of ul - vl bytes and the
;;; remainder, r, of vl bytes.
;;; multiply and subtract subtracts qhat*v from the middle of
;;; u and returns t iff the subtraction took u negative.
(defun multiply-and-subtract (u qhat v j ul vl)
(let* ((qhat*v (* qhat v))
(qhat*vlength (bignum-length qhat*v)))
(do ((i 0 (1+ i))
(carry ()))
((= i qhat*vlength)
(if (and carry (<= (+ (- ul j vl) i) ul)
(not (zerop (%sp-v-access u (+ (- ul j vl) i)))))
(setq carry (minusp
(%sp-v-store u (+ (- ul j vl) i)
(- (%sp-v-access u (+ (- ul j vl) i)) 1)))))
carry)
(setq carry (minusp
(%sp-v-store u (+ (- ul j vl) i)
(if carry
(- (%sp-v-access u (+ (- ul j vl) i))
(%sp-v-access qhat*v i) 1)
(- (%sp-v-access u (+ (- ul j vl) i))
(%sp-v-access qhat*v i)))))))))
;;; add-back adds v back into u if the quotient guess was too big.
(defun add-back (u v j ul vl qhat)
(setq qhat (1- qhat))
(do ((i 0 (1+ i))
(carry ()))
((= i vl)
(%sp-v-store u (- ul j) (1+ (%sp-v-access u (- ul j)))) u)
(setq carry
(%sp-logldb 1 8
(%sp-v-store u (+ (- ul j vl) i)
(if carry
(+ (%sp-v-access u (+ (- ul j vl) i))
(%sp-v-access v i) 1)
(+ (%sp-v-access u (+ (- ul j vl) i))
(%sp-v-access v i))))))))
(defun bignum-divide (u v)
(let* ((ulength (bignum-length u))
(vlength (bignum-length v))
(ul (if (zerop (%sp-v-access u (1- ulength))) (1- ulength) ulength))
(vl (if (zerop (%sp-v-access v (1- vlength))) (1- vlength) vlength))
(ql (1+ (- ul vl))))
(if (not (plusp ql)) (values 0 u)
(let* ((q (cons-a-bignum (max ql 4)))
(d (- 8 (integer-length (%sp-v-access v (1- vl)))))
;; d is the number of bits needed to shift v such that v's
;; highest significant bit is in position 7 of its byte.
(u (let* ((u* (ash u d))
(u*length (bignum-length u*)))
(if (not (zerop (%sp-v-access u* (1- u*length))))
(let ((u** (cons-a-bignum (1+ u*length))))
(do ((i 0 (1+ i)))
((= i u*length) u**)
(%sp-v-store u** i (%sp-v-access u* i))))
u*)))
(v (ash v d)))
(do* ((j 0 (1+ j))
(qhat 0)
(v1 (%sp-v-access v (1- vl)))
(v2 (%sp-v-access v (- vl 2))))
((= j ql) (values (integerize q ql)
(ash (integerize u (1+ ul)) (- d))))
(let ((uj (%sp-v-access u (- ul j)))
(uj+1 (%sp-v-access u (- ul j 1)))
(uj+2 (%sp-v-access u (- ul j 2))))
;;; multiply and subtract subtracts qhat*v from the middle of u
;;; and returns t if and only if qhat*v was larger than the byte chunk
;;; being subtracted from, so that add-back can add back in 1*v to
;;; to the middle of u.
(setq qhat
(do ((qhat
(if (= uj v1) 255 (truncate (+ (ash uj 8) uj+1) v1))
(1- qhat)))
((<= (* v2 qhat)
(+ (ash (- (+ (ash uj 8) uj+1) (* qhat v1)) 8)
uj+2))
qhat)))
(unless (zerop qhat)
(if (multiply-and-subtract u qhat v j ul vl)
(add-back u v j ul vl qhat)))
(%sp-v-store q (- ql j 1) qhat)))))))
;;; Ratio-trunc returns the integer quotient and the ratio remainder.
;;;
(defun ratio-trunc (x)
(multiple-value-bind (q r)
(truncate (numerator x) (denominator x))
(values q
(if (zerop r) 0
(build-ratio r (denominator x))))))
;;;
;;; VII. LOGICAL OPERATIONS
;;;
;;;
;;; Integer-length returns the number of significant bits in the
;;; representation of the integer.
(defun %sp-integerlength-escape (x)
(typecase x
(bignum (let ((sign (bignum-sign x))
(length (bignum-length x)))
(cond ((= sign 0)
(do* ((byte (1- length) (1- byte))
(the-byte (%sp-v-access x byte)
(%sp-v-access x byte)))
((or (not (zerop the-byte)) (zerop byte))
(%sp-escape-return
(+ (integer-length the-byte) (* 8 byte))))))
(t (do* ((byte (1- length) (1- byte))
(the-byte (%sp-v-access x byte)
(%sp-v-access x byte)))
((or (not (= 255 the-byte)) (zerop byte))
(%sp-escape-return
(+ (integer-length (- 255 the-byte))
(* 8 byte)))))))))
(otherwise (error "~A, argument not integer, integer-length" x))))
;;; Put-in-big takes an 8 bit byte and puts it into a bignum
;;; at rightmost bit position rb.
;;; Used by fix and big lsh.
(defun put-in-big (x rb big)
(multiple-value-bind (byte0 hmin1) (truncate rb 8)
;
(cond ((and (not (zerop hmin1))
(= byte0 (1- (bignum-length big))))
(let ((b0 (%sp-v-access big byte0)))
(%sp-v-store big byte0
(%sp-logdpb x (- 8 hmin1) hmin1 b0))
big))
((zerop hmin1)
(%sp-v-store big byte0 x)
big)
(t (let ((b0 (%sp-v-access big byte0))
(b1 (%sp-v-access big (1+ byte0))))
(%sp-v-store big byte0
(%sp-logdpb x (- 8 hmin1) hmin1 b0))
(%sp-v-store big (1+ byte0)
(%sp-logdpb (%sp-logldb hmin1 (- 8
hmin1) x)
hmin1 0 b1))
big)))))
;;; Get-from-big gets a byte of 8 bits starting at rb from X.
;;; Sign extendes if rb + 8 is greater than the highest bit.
;;; Length is the number of bytes in x.
;;; Used only by BigAsh.
;;; VM:T
(defun get-from-big (rb x length)
(multiple-value-bind (byte0 hmin1) (truncate rb 8)
(cond ((< byte0 length) ;; Byte0 is in vector not off the end.
(cond ((zerop hmin1) (%sp-v-access x byte0))
((< (1+ byte0) length) ;; Byte1 is in vector.
(%sp-logdpb
(%sp-logldb hmin1 0 (%sp-v-access x (1+ byte0)))
hmin1 (- 8 hmin1)
(%sp-lsh (%sp-v-access x byte0) (- hmin1))))
(t (%sp-logdpb
(%sp-logldb hmin1 0 (- (bignum-sign x)))
hmin1 (- 8 hmin1)
(%sp-lsh (%sp-v-access x byte0) (- hmin1))))))
(t (%sp-logldb 8 0 (- (bignum-sign x)))))))
;;; FixAsh arithmetically shifts a fixnum, N, left by B bits.
;;; It uses lsh when possible, otherwise it uses put-in-big.
;;; vm:T
(defun fixash (n b)
(if (not (fixnump b))
(error "Ash, shift argument is not a fixnum, ~A" b))
(let ((tch (integer-length n)))
(cond ((<= (+ tch b) 0) (- (%sp-logldb 1 (1- %fixnum-length) n)))
((minusp b) (%sp-logdpb (%sp-lsh n b) (+ %fixnum-length b) 0
(- (%sp-logldb 1 (1- %fixnum-length) n))))
((<= (+ tch b) (1- %fixnum-length)) (%sp-lsh n b))
(t (let* ((byte-length (1+ (truncate (+ tch b) 8)))
(s (%sp-logldb 1 (1- %fixnum-length) n))
(sign-byte (- s))
(ans (cons-a-bignum byte-length)))
(do ((i 0 (+ i 8)))
((> i tch))
(put-in-big (gfb8 n (truncate i 8) sign-byte) (+ i b)
ans))
(integerize ans byte-length))))))
;;; Shifts a bignum into a bignum.
(defun big-to-bigash (n b nl)
(let* ((byte-length (1+ (truncate (+ nl b) 8)))
(ans (cons-a-bignum byte-length))
(bl (bignum-length n)))
(do ((i (1- byte-length) (1- i)))
((minusp i) (integerize ans byte-length))
(put-in-big (get-from-big (+ (- b) (* 8 i)) n bl)
(* i 8) ans))))
;;; Shifts a bignum into a fixnum.
;;;
(defun big-to-fixash (n b nl)
(let* ((size (bignum-length n))
(fix (%sp-logdpb (get-from-big (- nl 7) n size) 8 20
(%sp-logdpb
(get-from-big (- nl 15) n size) 8 12
(%sp-logdpb
(get-from-big (- nl 23) n size) 8 4
(%sp-logdpb (get-from-big (- nl 27) n size) 4 0
(- (bignum-sign n))))))))
(fixash fix (+ nl b -27))))
;;; BigAsh arithmetically shifts the bignum N left by B bits.
;;; VM:T
(defun nzero-bytes (n c)
"Detructively nullifies the bottom c bytes of the xnum n."
(do ((i 0 (1+ i))
(end (min c (bignum-length n))))
((= i end) n)
(%sp-v-store n i 0)))
(defun byte-ash (n c)
"Shifts the bignum n by c bytes, by playing with the internal vector."
(let* ((length (bignum-length n))
(newlen (max 0 (+ length c))))
(if (zerop newlen) (- (bignum-sign n))
(let* ((start (max 0 (- c)))
(dststart (max 0 c))
(res (nzero-bytes (create-bignum newlen (bignum-sign n))
dststart))) ;At least 4, and 0 shifted in
(%sp-byte-blt n start res dststart newlen)
(integerize1 res)))))
;;; Similar to gb16. c must be valid.
(defun Load-two-bytes (n c 1-length sign-byte)
"Loads two bytes at position c in bignum n, extending with byte."
(%sp-logdpb (if (= c 1-length) sign-byte (%sp-v-access n (1+ c)))
8 8 (%sp-v-access n c)))
;;; Bigash first byte-ashes for coarse adjustments, then ashes each byte the
;;; remaining amount. This is always downward, so we can get 16 bits
;;; and still have the 8 we want to store.
(defun bigash (n c)
(multiple-value-bind (bytes bits) (ceiling c 8)
(let ((res (byte-ash n bytes)))
(cond ((fixnump res)
(ash res bits))
(t (let ((length (bignum-length res))
(sign-byte (- (bignum-sign res))))
(do ((i 0 (1+ i))
(1-len (1- length)))
((= i length) (integerize1 res))
(%sp-v-store res i
(ash (load-two-bytes res i 1-len sign-byte)
bits)))))))))
;;; %sp-ash-escape is an arithmetic shift function for any integer.
;;; N is the integer, and B is the number of bits to shift
;;; left.
;;; VM:T
(defun %sp-ash-escape (n b)
(unless (fixnump b)
(error "Ash, cannot shift by a non fixnum value, ~A." b))
(%sp-escape-return
(cond ((zerop b) n)
(t (typecase n
(fixnum (%sp-escape-return (fixash n b)))
(bignum (%sp-escape-return (bigash n b)))
(t (error "Ash, object to shift is not an integer, ~A." n)))))))
;;; Count-bits counts the number of bits equal to s from
;;; bit p to 0.
;
(defun count-bits (s p x)
(do ((sum (if (= s (%sp-logldb 1 p x)) 1 0)
(+ sum (if (= s (%sp-logldb 1 i x)) 1 0)))
(i (1- p) (1- i)))
((minusp i) sum)
))
;;; Logcount returns the number of bits that are the complement of
;;; the sign in the integer argument x.
(defun logcount (x)
(typecase x
(fixnum (do* ((s (complement (fixnum-sign x)))
(i 0 (1+ i))
(sum (if (= s (%sp-logldb 1 i x)) 1 0)
(if (= s (%sp-logldb 1 i x)) (1+ sum) sum)))
((= i (1- %fixnum-length)) sum)
))
(bignum (let* ((sum 0)
(l (bignum-length x))
(l-1 (1- l))
(s (complement (bignum-sign x))))
(do ((b 0 (+ b 2)))
((>= b l-1)
(cond ((= b l-1)
(+ sum
(count-bits s 7
(%sp-v-access x l-1)
)))
(t sum)))
(setq sum
(+ sum
(count-bits s 16 (%sp-typed-v-access
4 x (truncate b 2))))))))
(otherwise (error "Argument not integer, ~A." x))))
;;; get-from-big-no-extend does a get-from-big with no sign
;;; extend.
;;; Gets a byte of 8 bits, starting at rb, from x.
;;; Does not sign extend, fills with zeros.
(defun get-from-big-no-extend (rb x length)
(let* ((byte0 (truncate rb 8)) ; The right hand byte's position.
(hmin1 (- rb (* byte0 8)))); How many bit's in byte1.
(cond ((zerop hmin1)
(%sp-v-access x byte0))
((> (+ rb 8) (* length 8))
(let ((b0 (%sp-lsh (%sp-v-access x byte0)
(- hmin1))))
(%sp-logdpb 0 hmin1 (- 8 hmin1) b0)))
(t (%sp-logdpb (%sp-v-access x (1+ byte0))
hmin1 (- 8 hmin1)
(%sp-lsh (%sp-v-access x byte0)
(- hmin1)))))))
;;; Ldb-a-fixnum, loads a fixnum chunck of bits from either a fixnum or a
;;; bignum.
(defun sign-extend-tva (v vl i sign-byte)
(cond ((>= i vl) sign-byte)
(t (%sp-v-access v i))))
;
(defun ldb-a-fixnum (s p n)
(typecase n
(fixnum
;; A fixnum sized load can be broken down into two fields:
;; The significant field and the sign field.
(let* ((significant-size (if (> p (1- %fixnum-length))
0 (min s (- %fixnum-length p))))
(sign-field-size (- s significant-size)))
(cond ((zerop significant-size) ;; No significant field.
(case (fixnum-sign n)
(0 0)
(1 (%sp-logldb sign-field-size 0 -1))))
((zerop sign-field-size) ;; No sign field.
(%sp-logldb significant-size p n))
(t (case (fixnum-sign n) ;; Both fields.
(0 (%sp-logldb significant-size p n))
(1 (%sp-logdpb
-1 sign-field-size significant-size
(%sp-logldb significant-size p n))))))))
(bignum (let* ((nl (bignum-length n))
(sign-byte (- (bignum-sign n)))
;;; The loading of a fixnum from a bignum can be divided into 3 distinct
;;; parts, the lowest byte, the middle 8 bit bytes and the highest byte.
;;; The lowest byte can be up to 8 bits long; starts at Lbp and is lbs
;;; bits long. There are from 0 to 3 middle 8 bit bytes, and the number
;;; of the highest byte is -1 if it does not exist.
(Lb (truncate p 8))
(Lbp (- p (* lb 8)))
(Lbs (min s (- 8 lbp)))
(num-middle-bytes (truncate (- s lbs) 8))
(Hb (if (zerop (- s lbs (* 8 num-middle-bytes)))
-1 (+ 1 Lb num-middle-bytes)))
(fix 0))
;;; Now I deposit the fields into their places in fix.
;;; Lb field
(setq fix (%sp-logdpb
(%sp-logldb
Lbs Lbp
(sign-extend-tva n nl Lb sign-byte))
Lbs 0 fix))
;;; Middle byte fields.
(do ((i 1 (1+ i)))
((> i num-middle-bytes) t)
(setq fix
(%sp-logdpb
(sign-extend-tva n nl (+ Lb i) sign-byte)
8 (+ (* 8 (1- i)) Lbs) fix)))
;;; High Byte.
(unless (= -1 hb)
(let* ((bits-in (+ Lbs (* 8 num-middle-bytes)))
(hbs (- s bits-in)))
(setq fix
(%sp-logdpb
(sign-extend-tva
n nl hb sign-byte)
hbs bits-in fix))))
fix))))
;;; get-from-fix gets a byte of size 8, whose rightmost bit is rb,
;;; from n, where n's signbyte is s.
;
(defun get-from-fix (rb n sign)
(cond ((> rb (1- %fixnum-length)) (%sp-logldb 8 0 sign))
((< (+ rb 8) %fixnum-length) (%sp-logldb 8 rb n))
(t (let* ((rbs (max 0 (min (- %fixnum-length rb) 8)))
(rb (if (plusp rbs) (%sp-logldb rbs rb n) 0))
(lbs (- 8 rbs))
(lb (%sp-logldb lbs 0 sign)))
(cond ((plusp lbs)
(%sp-logdpb lb lbs rbs rb))
(t rb))))))
;;; ldb-a-bignum loads a bignum sized byte from a fixnum or a bignum.
;
(defun ldb-a-bignum (s p n)
(typecase n
;; The load of a bignum, from a fixnum or a bignum, can
;; be seperated into the loading, and depositing, of
;; the right hand 8 bit bytes which compose the load,
;; and the final byte, of which less than 8 bits are used.
(fixnum (let* ((l (bit-to-8-bit-byte s))
(ansl (if (and (zerop (rem s 8))
(not (zerop (logbitp
(1- (+ s p)) n))))
(1+ l) l))
(ans (cons-a-bignum ansl))
(sign (- (fixnum-sign n))))
(multiple-value-bind (num-whole-bytes
size-of-partial-byte)
(truncate s 8)
;
(do ((i 0 (1+ i))
(pcount p (+ pcount 8)))
((= i num-whole-bytes))
(%sp-v-store ans i (get-from-fix pcount n sign)))
(unless (zerop size-of-partial-byte)
(%sp-v-store ans num-whole-bytes
(%sp-logldb size-of-partial-byte 0
(get-from-fix
(+ p (* num-whole-bytes 8))
n sign))))
(integerize ans ansl))))
(bignum (let* ((l (bignum-length n))
(byte-length
(multiple-value-bind (b r) (truncate s 8)
(cond ((zerop r)
(if (logbitp (1- (+ p s)) n) (1+ b) b))
(t (1+ b)))))
(bytes (truncate s 8))
(ans (cons-a-bignum byte-length)))
(do ((bc p (+ bc 8))
(bytec 0 (1+ bytec)))
((>= bytec bytes)
(let ((rem (- s (* bytec 8))))
(when (plusp rem)
(%sp-v-store ans bytec
(%sp-logldb rem 0 (get-from-big bc n l)))))
(integerize ans byte-length))
(%sp-v-store ans bytec
(get-from-big bc n l)))))))
;;; %sp-ldb-escape (S P N). S is the size of the byte field,
;;; P is the position it starts at and N is the number to get
;;; the byte field from.
(defun %sp-ldb-escape (S P N)
(unless (and (fixnump s) (>= s 0))
(error "Size argument must be a positive fixnum, ~A." s))
(unless (and (fixnump p) (>= p 0))
(error "Position argument must be a positive fixnum, ~A." p))
(unless (integerp n)
(error "Ldb: source must be an integer, ~A." n))
(%sp-escape-return
(cond ((zerop s) 0)
((or (< s %fixnum-length)
(and (= s %fixnum-length)
(not (logbitp (1- (+ p s)) n))))
(ldb-a-fixnum s p n))
(t (ldb-a-bignum s p n)))))
;;; Fixnum-mask-field does a mask-field when n is a fixnum.
(defun fixnum-mask-field (s p n)
(when (and (>= n 0)
(< (1- %fixnum-length) (+ s p)))
(setq s (max 0 (- (1- %fixnum-length) p))))
(cond ((zerop s) 0) ;; Getting sign bits from positive fixnum.
((< (+ s p) %fixnum-length) (%sp-lsh (%sp-logldb s p n) p))
;; The sign is being masked out, so the result is fixnum.
;; For the next clause to be chosen, n must be negative,
;; and the result will be a bignum.
(t (let* ((bit-length (+ 1 p s)) ;; 1+ for the sign.
(byte-length
(multiple-value-bind (q r) (truncate bit-length 8)
(if (zerop r) q (1+ q)))))
(multiple-value-bind (Low LowPos) (truncate p 8)
(let* ((LowSize (min s (- 8 LowPos)))
(num-middle-bytes (truncate (- s lowsize) 8))
(HighSize (- s lowsize (* 8 Num-middle-bytes)))
(ans (cons-a-bignum byte-length)))
(%sp-v-store ans low
(%sp-lsh (ldb (byte LowSize p) n) lowpos))
(do ((anscount (1+ Low) (1+ anscount))
(num-middle-bytes+low (+ num-middle-bytes low)))
((> anscount num-middle-bytes+low)
(unless (zerop HighSize)
(%sp-v-store ans anscount
(%sp-logldb HighSize 0
(gfb8 n anscount #b11111111))))
ans)
(%sp-v-store ans anscount
(gfb8 n anscount #b11111111)))))))))
;;; Bignum-mask-field does a mask-field when n is a bignum.
(defun bignum-mask-field (s p n)
(let* ((nl (bignum-length n))
(nl-1 (1- nl))
(sign-start (- (* 8 nl) (- 8 (integer-length nl)))))
(when (and (plusp n) ;; Reduce size if possible to
(< sign-start (+ s p))) ;; avoid consing up uneeded bignums.
(setq s (max 0 (- sign-start p))))
(cond ((zerop s) 0) ;; Positive bignum, with only sign not masked.
(t (let* ((bit-length (+ s p)))
(cond ((or (< bit-length %fixnum-length)
(and (= bit-length %fixnum-length)
(not (logbitp (1- bit-length) n))))
(%sp-lsh (ldb (byte s p) n) p))
(t (let ((byte-length
(multiple-value-bind (q r) (truncate bit-length 8)
(if (or (and (zerop r)
(logbitp (1- bit-length) n))
(not (zerop r))) (1+ q) q))))
(multiple-value-bind (low lowpos) (truncate p 8)
(let ((LowSize (min s (- 8 LowPos))))
(multiple-value-bind (num-middle-bytes Highsize)
(truncate (- s lowsize) 8)
(let ((sign-byte
(%sp-logldb
8 0 (- (bignum-sign n))))
(ans (cons-a-bignum byte-length)))
(%sp-v-store ans low
(%sp-lsh (ldb (byte LowSize p) n)
lowpos))
(do ((bc (1+ low) (+ bc 1))
(bytecount 0 (1+ bytecount)))
((= bytecount num-middle-bytes)
(unless (zerop HighSize)
(%sp-v-store
ans bc
(%sp-logldb
HighSize 0
(gb8 n bc nl-1 sign-byte))))
ans)
(%sp-v-store
ans bc (gb8 n bc nl-1
sign-byte)))))))))))))))
;;; Mask-field always returns a positive integer. Bignum arguments
;;; can yield bignum or fixnum arguments but only negative fixnum
;;; arguments can return a bignum.
;;;
(defun %sp-maskfield-escape (s p n)
(unless (and (fixnump s) (not (minusp s)))
(error "Size argument must be a non negative fixnum, ~A." s))
(unless (and (fixnump p) (not (minusp p)))
(error "Position argument must be a non negative fixnum, ~A." p))
(%sp-escape-return
(typecase n
(fixnum (fixnum-mask-field s p n))
(bignum (bignum-mask-field s p n))
(t (error "Argument must be an integer, ~A." n)))))
;;;
;;; Fixnum-dpb is cased by result type : bignum or fixnum,
;;; but called only when n is a fixnum.
(defun fixnum-dpb (v s p n)
(let ((size (+ s p)))
(cond ((<= size 27)
(dpb (ldb (byte s 0) v) (byte s p) n))
(t (multiple-value-bind (high-byte high-bits-in) (floor size 8)
(multiple-value-bind (low-byte low-bits-out) (floor p 8)
(let* ((bytes (ceiling (1+ size) 8))
(res (sizify n bytes))
(workspace-high (- high-byte low-byte))
(workspace (nsizify (ash v low-bits-out)
(1+ workspace-high))))
(%sp-v-store workspace 0
(%sp-logdpb (%sp-v-access res low-byte)
low-bits-out 0
(%sp-v-access workspace 0)))
(%sp-v-store workspace workspace-high
(%sp-logdpb (%sp-v-access workspace
workspace-high)
high-bits-in 0
(%sp-v-access res high-byte)))
(bash-bytes workspace
(1+ workspace-high)
low-byte res)
(integerize1 res))))))))
;;; Bignum-dpb handles dpb when n is a bignum.
(defun bignum-dpb (v s p n)
(let* ((nlength (bignum-length n))
(nlength-1 (1- nlength))
(nsign (bignum-sign n))
(nsign-byte (- nsign))
(bit-size (cond ((>= (+ s p) (* 8 nlength))
(if (and (logbitp (1- s) v) (= 1 nsign))
(+ s p)
(+ 1 s p)))
(t (* 8 nlength))))
(byte-size
(multiple-value-bind (q r) (truncate bit-size 8)
(if (zerop r) q (1+ q))))
(answer (cons-a-bignum byte-size)))
(multiple-value-bind (low lowpos) (truncate p 8)
(multiple-value-bind (high highpos) (truncate (+ p s -1) 8)
(let* ((lowsize (min s (- 8 lowpos)))
(highsize (1+ highpos))) ;; This assumes that low /= high.
(cond ((= low high)
(do ((i 0 (1+ i)))
((= i low))
(%sp-v-store answer i
(gb8 n i nlength-1 nsign-byte)))
(%sp-v-store
answer low
(%sp-logdpb (if (bignump v) (ldb (byte s 0) v) v)
lowsize lowpos
(gb8 n low nlength-1 nsign-byte)))
(do ((i (1+ low) (1+ i)))
((>= i byte-size))
(%sp-v-store answer i
(gb8 n i nlength-1 nsign-byte)))
(integerize answer byte-size))
(t (do ((i 0 (1+ i)))
((= i low))
(%sp-v-store answer i
(gb8 n i nlength-1 nsign-byte)))
(%sp-v-store
answer low
(%sp-logdpb (if (bignump v)
(ldb (byte lowsize 0) v) v)
lowsize lowpos
(gb8 n low nlength-1 nsign-byte)))
(do ((i (1+ low) (1+ i))
(pc lowsize (+ pc 8)))
((>= i high))
(%sp-v-store answer i
(ldb (byte 8 pc) v)))
(%sp-v-store answer high
(%sp-logdpb
(ldb (byte highsize (- s highsize)) v)
highsize 0 (gb8 n high nlength-1 nsign-byte)))
(do ((i (1+ high) (1+ i)))
((>= i byte-size))
(%sp-v-store answer i
(gb8 n i nlength-1 nsign-byte)))
(integerize answer byte-size))))))))
;;; %sp-dpb-escape is the bugout for dpb, but it can handle all cases.
;;; VM:T
(defun %sp-dpb-escape (v s p n)
(unless (integerp v)
(error "Value argument must be integer, ~A." v))
(unless (integerp n)
(error "Argument must be integer, ~A." n))
(unless (and (integerp s) (not (minusp s)))
(error "Size argument must be non-negative, ~A." S))
(unless (and (integerp s) (not (minusp s)))
(error "Position argument must be non-negative, ~A." s))
(if (zerop s) (%sp-escape-return n)
(typecase n
(fixnum (%sp-escape-return (fixnum-dpb v s p n)))
(bignum (%sp-escape-return (bignum-dpb v s p n))))))
;;;
;;; Fixnum-deposit-field handles the case where n is a fixnum.
(defun fixnum-deposit-field (v s p n)
(let* ((nsign (not (zerop (%sp-logldb 1 (1- %fixnum-length) n))))
(bit-size (cond ((> (+ s p) (1- %fixnum-length))
(if (eq (logbitp (1- s) v) nsign)
(+ s p)
(+ 1 s p)))
(t %fixnum-length))))
(cond ((<= bit-size %fixnum-length)
(%sp-logdpb (ldb (byte s p) v) s p n))
(t (let* ((nsign-byte (if nsign -1 0))
(byte-size
(multiple-value-bind (q r) (truncate bit-size 8)
(if (zerop r) q (1+ q))))
(answer (cons-a-bignum byte-size)))
(multiple-value-bind (low lowpos) (truncate p 8)
;
(multiple-value-bind (high highpos) (truncate (+ p s -1) 8)
;
(let* ((lowsize (min s (- 8 lowpos)))
(highsize (1+ highpos)))
;; If low is the same byte as high, I use 2 do loops. From 0 to low,
;; then insert the broken byte, and then a do from low+1 to byte-size.
(cond ((= low high)
(do ((i 0 (1+ i)))
((= i low))
(%sp-v-store answer i
(gfb8 n i nsign-byte)))
;; Put in broken byte.
(%sp-v-store answer low
(%sp-logdpb (ldb (byte s p) v)
Lowsize Lowpos
(gfb8 n low nsign-byte)))
(do ((i (1+ low) (1+ i)))
((>= i byte-size))
(%sp-v-store answer i
(gfb8 n i nsign-byte)))
(integerize answer byte-size))
;; If low is not = to high, then I use 3 do loops, one from 0 to low,
;; then I put in the low byte, one from low + 1 to high -1 , then
;; I put in the high byte and then one from high + 1 to byte size.
(t (do ((i 0 (1+ i)))
((= i low))
(%sp-v-store answer i
(gfb8 n i nsign-byte)))
;; Put in low byte.
(%sp-v-store answer low
(%sp-logdpb
(ldb (byte lowsize p) v)
lowsize lowpos
(gfb8 n low nsign-byte)))
(do ((i (1+ low) (1+ i))
(pc (* 8 (1+ low)) (+ 8 pc)))
((>= i high)
;; Put in high byte.
(%sp-v-store answer high
(%sp-logdpb
(ldb (byte highsize pc) v)
highsize 0
(gfb8 n i nsign-byte))))
(%sp-v-store answer i
(ldb (byte 8 pc) v)))
(do ((i (1+ high) (1+ i)))
((>= i byte-size))
(%sp-v-store
answer i
(gfb8 n i nsign-byte)))
(integerize answer byte-size)))))))))))
;;; Bignum-deposit-field handles dpb when n is a bignum.
(defun bignum-deposit-field (v s p n)
(let* ((nlength (bignum-length n))
(nlength-1 (1- nlength))
(nsign (bignum-sign n))
(nsign-byte (- nsign))
(bit-size (cond ((>= (+ s p) (* 8 nlength))
(if (and (logbitp (1- s) v) (= 1 nsign))
(+ s p)
(+ 1 s p)))
(t (* 8 nlength))))
(byte-size
(multiple-value-bind (q r) (truncate bit-size 8)
(if (zerop r) q (1+ q))))
(answer (cons-a-bignum byte-size)))
(multiple-value-bind (low lowpos) (truncate p 8)
(multiple-value-bind (high highpos) (truncate (+ p s -1) 8)
(let* ((lowsize (min s (- 8 lowpos)))
(highsize (1+ highpos))) ;; This assumes that low /= high.
(cond ((= low high)
(do ((i 0 (1+ i)))
((= i low))
(%sp-v-store answer i
(gb8 n i nlength-1 nsign-byte)))
(%sp-v-store
answer low
(%sp-logdpb (ldb (byte s p) v)
lowsize lowpos
(gb8 n low nlength-1 nsign-byte)))
(do ((i (1+ low) (1+ i)))
((>= i byte-size))
(%sp-v-store answer i
(gb8 n i nlength-1 nsign-byte)))
(integerize answer byte-size))
(t (do ((i 0 (1+ i)))
((= i low))
(%sp-v-store answer i
(gb8 n i nlength-1 nsign-byte)))
(%sp-v-store
answer low
(%sp-logdpb (ldb (byte lowsize p) v)
lowsize lowpos
(gb8 n low nlength-1 nsign-byte)))
(do ((i (1+ low) (1+ i))
(pc lowsize (+ pc 8)))
((>= i high)
(%sp-v-store
answer high
(%sp-logdpb
(ldb (byte highsize pc) v)
highsize 0 (gb8 n high nlength-1 nsign-byte))))
(%sp-v-store answer i
(ldb (byte 8 pc) v)))
(do ((i (1+ high) (1+ i)))
((>= i byte-size))
(%sp-v-store answer i
(gb8 n i nlength-1 nsign-byte)))
(integerize answer byte-size))))))))
;;; %sp-depositfield-escape is the bugout for deposit-field.
;;; VM:T
(defun %sp-depositfield-escape (v s p n)
(unless (integerp v)
(error "Value argument must be integer, ~A."
v))
(unless (integerp n)
(error "Argument must be integer, ~A." n))
(unless (and (integerp s) (not (minusp s)))
(error "Size argument must be non-negative, ~A." S))
(unless (and (integerp s) (not (minusp s)))
(error "Position argument must be non-negative, ~A." s))
(if (zerop s) (%sp-escape-return n)
(typecase n
(fixnum (%sp-escape-return (fixnum-deposit-field v s p n)))
(bignum (%sp-escape-return (bignum-deposit-field v s p n))))))
;;;
;;;
;;; VIII. Exported routines
;;;
;;; Part 12.5 of the laser edition
(defun float-sign (float1 &optional (float2 (float 1 float1)))
(if (eq (minusp float1) (minusp float2))
float2
(- float2)))
(defun float-precision (f)
(typecase f
(short-float 20)
(long-float 53)
(t (error "Float-precision: ~A not a float" f))))
(defun integer-decode-float (x)
(let ((precision (float-precision x)))
(multiple-value-bind (f e s) (decode-float x)
(values (truncate (scale-float f precision))
(- e precision)
s))))
(defun decode-float (f)
(%sp-decode-float f))
(defun scale-float (f e) (%sp-scale-float f e))
;;; The two macros, bignum-bignum-bitfun and bignum-fixnum-bitfun
;;; are used to implement all of the one logical function bit funs.
;;; The first argument, fun is the micro-instruction name used
;;; (e.g. one of %sp-bit-and, %sp-bit-or or %sp-bit-xor),
;;; the second and third arguments are the numbers.
(defmacro bignum-bignum-bitfun (fun b1 b2)
`(let* ((b1l (%sp-get-vector-length ,b1))
(b2l (%sp-get-vector-length ,b2))
(b1s (%sp-get-vector-subtype ,b1))
(b2s (%sp-get-vector-subtype ,b2))
(max-length (max b1l b2l))
(r (%sp-alloc-xnum max-length (%sp-logldb 1 0 (,fun b1s b2s))))
(b1sign-byte (- b1s))
(b2sign-byte (- b2s)))
(do ((i 0 (+ i 2))
(1-b1l (1- b1l))
(1-b2l (1- b2l))
(1-max-length (1- max-length)))
((>= i 1-max-length)
(when (= i 1-max-length)
(%sp-typed-v-store
3 r 1-max-length
(,fun (gb8 ,b1 i 1-b1l b1sign-byte)
(gb8 ,b2 i 1-b2l b2sign-byte))))
(integerize r max-length))
(%sp-typed-v-store 4 r (truncate i 2)
(,fun (gb16 ,b1 i 1-b1l b1sign-byte)
(gb16 ,b2 i 1-b2l b2sign-byte))))))
(defmacro bignum-fixnum-bitfun (fun b f)
`(let* ((bl (bignum-length ,b))
(bs (bignum-sign ,b))
(fs (%sp-logldb 1 27 ,f))
(r (cons-a-bignum bl))
(bsign-byte (- bs))
(fsign-byte (- fs)))
(do ((i 0 (+ i 2))
(1-bl (1- bl)))
((>= i 1-bl)
(when (= i 1-bl)
(%sp-typed-v-store 3 r 1-bl
(,fun (gb8 ,b i 1-bl bsign-byte)
(gfb8 ,f i fsign-byte))))
(integerize r bl))
(%sp-typed-v-store 4 r (truncate i 2)
(,fun (gb16 ,b i 1-bl bsign-byte)
(gfb16 ,f i fsign-byte))))))
(defun %sp-bitand-escape (a b)
(cond ((and (bignump a) (bignump b))
(%sp-escape-return (bignum-bignum-bitfun logand a b)))
((fixnump a)
(%sp-escape-return (bignum-fixnum-bitfun logand b a)))
(t (%sp-escape-return (bignum-fixnum-bitfun logand a b)))))
(defun %sp-bitxor-escape (a b)
(cond ((and (bignump a) (bignump b))
(%sp-escape-return (bignum-bignum-bitfun logxor a b)))
((fixnump a)
(%sp-escape-return (bignum-fixnum-bitfun logxor b a)))
(t (%sp-escape-return (bignum-fixnum-bitfun logxor a b)))))
(defun %sp-bitor-escape (a b)
(cond ((and (bignump a) (bignump b))
(%sp-escape-return (bignum-bignum-bitfun logior a b)))
((fixnump a)
(%sp-escape-return (bignum-fixnum-bitfun logior b a)))
(t (%sp-escape-return (bignum-fixnum-bitfun logior a b)))))