;;; 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)))))