-;;;; LDB (load byte)
-
-#|
-FOR NOW WE DON'T USE LDB OR DPB. WE USE SHIFTS AND MASKS IN NUMBERS.LISP WHICH
-IS LESS EFFICIENT BUT EASIER TO MAINTAIN. BILL SAYS THIS CODE CERTAINLY WORKS!
-
-(defconstant maximum-fixnum-bits #!+ibm-rt-pc 27 #!-ibm-rt-pc 30)
-
-(defun bignum-load-byte (byte bignum)
- (declare (type bignum-type bignum))
- (let ((byte-len (byte-size byte))
- (byte-pos (byte-position byte)))
- (if (< byte-len maximum-fixnum-bits)
- (bignum-ldb-fixnum-res bignum byte-len byte-pos)
- (bignum-ldb-bignum-res bignum byte-len byte-pos))))
-
-;;; This returns a fixnum result of loading a byte from a bignum. In order, we
-;;; check for the following conditions:
-;;; Insufficient bignum digits to start loading a byte --
-;;; Return 0 or byte-len 1's depending on sign of bignum.
-;;; One bignum digit containing the whole byte spec --
-;;; Grab 'em, shift 'em, and mask out what we don't want.
-;;; Insufficient bignum digits to cover crossing a digit boundary --
-;;; Grab the available bits in the last digit, and or in whatever
-;;; virtual sign bits we need to return a full byte spec.
-;;; Else (we cross a digit boundary with all bits available) --
-;;; Make a couple masks, grab what we want, shift it around, and
-;;; LOGIOR it all together.
-;;; Because (< maximum-fixnum-bits digit-size) and
-;;; (< byte-len maximum-fixnum-bits),
-;;; we only cross one digit boundary if any.
-(defun bignum-ldb-fixnum-res (bignum byte-len byte-pos)
- (multiple-value-bind (skipped-digits pos) (truncate byte-pos digit-size)
- (let ((bignum-len (%bignum-length bignum))
- (s-digits+1 (1+ skipped-digits)))
- (declare (type bignum-index bignum-len s-digits+1))
- (if (>= skipped-digits bignum-len)
- (if (%bignum-0-or-plusp bignum bignum-len)
- 0
- (%make-ones byte-len))
- (let ((end (+ pos byte-len)))
- (cond ((<= end digit-size)
- (logand (ash (%bignum-ref bignum skipped-digits) (- pos))
- ;; Must LOGAND after shift here.
- (%make-ones byte-len)))
- ((>= s-digits+1 bignum-len)
- (let* ((available-bits (- digit-size pos))
- (res (logand (ash (%bignum-ref bignum skipped-digits)
- (- pos))
- ;; LOGAND should be unnecessary here
- ;; with a logical right shift or a
- ;; correct unsigned-byte-32 one.
- (%make-ones available-bits))))
- (if (%bignum-0-or-plusp bignum bignum-len)
- res
- (logior (%ashl (%make-ones (- end digit-size))
- available-bits)
- res))))
- (t
- (let* ((high-bits-in-first-digit (- digit-size pos))
- (high-mask (%make-ones high-bits-in-first-digit))
- (low-bits-in-next-digit (- end digit-size))
- (low-mask (%make-ones low-bits-in-next-digit)))
- (declare (type bignum-element-type high-mask low-mask))
- (logior (%ashl (logand (%bignum-ref bignum s-digits+1)
- low-mask)
- high-bits-in-first-digit)
- (logand (ash (%bignum-ref bignum skipped-digits)
- (- pos))
- ;; LOGAND should be unnecessary here with
- ;; a logical right shift or a correct
- ;; unsigned-byte-32 one.
- high-mask))))))))))
-
-;;; This returns a bignum result of loading a byte from a bignum. In order, we
-;;; check for the following conditions:
-;;; Insufficient bignum digits to start loading a byte --
-;;; Byte-pos starting on a digit boundary --
-;;; Byte spec contained in one bignum digit --
-;;; Grab the bits we want and stick them in a single digit result.
-;;; Since we know byte-pos is non-zero here, we know our single digit
-;;; will have a zero high sign bit.
-;;; Else (unaligned multiple digits) --
-;;; This is like doing a shift right combined with either masking
-;;; out unwanted high bits from bignum or filling in virtual sign
-;;; bits if bignum had insufficient bits. We use SHIFT-RIGHT-ALIGNED
-;;; and reference lots of local variables this macro establishes.
-(defun bignum-ldb-bignum-res (bignum byte-len byte-pos)
- (multiple-value-bind (skipped-digits pos) (truncate byte-pos digit-size)
- (let ((bignum-len (%bignum-length bignum)))
- (declare (type bignum-index bignum-len))
- (cond
- ((>= skipped-digits bignum-len)
- (make-bignum-virtual-ldb-bits bignum bignum-len byte-len))
- ((zerop pos)
- (make-aligned-ldb-bignum bignum bignum-len byte-len skipped-digits))
- ((< (+ pos byte-len) digit-size)
- (let ((res (%allocate-bignum 1)))
- (setf (%bignum-ref res 0)
- (logand (%ashr (%bignum-ref bignum skipped-digits) pos)
- (%make-ones byte-len)))
- res))
- (t
- (make-unaligned-ldb-bignum bignum bignum-len
- byte-len skipped-digits pos))))))
-
-;;; This returns bits from bignum that don't physically exist. These are
-;;; all zero or one depending on the sign of the bignum.
-(defun make-bignum-virtual-ldb-bits (bignum bignum-len byte-len)
- (if (%bignum-0-or-plusp bignum bignum-len)
- 0
- (multiple-value-bind (res-len-1 extra) (truncate byte-len digit-size)
- (declare (type bignum-index res-len-1))
- (let* ((res-len (1+ res-len-1))
- (res (%allocate-bignum res-len)))
- (declare (type bignum-index res-len))
- (do ((j 0 (1+ j)))
- ((= j res-len-1)
- (setf (%bignum-ref res j) (%make-ones extra))
- (%normalize-bignum res res-len))
- (declare (type bignum-index j))
- (setf (%bignum-ref res j) all-ones-digit))))))
-
-;;; Since we are picking up aligned digits, we just copy the whole digits
-;;; we want and fill in extra bits. We might have a byte-len that extends
-;;; off the end of the bignum, so we may have to fill in extra 1's if the
-;;; bignum is negative.
-(defun make-aligned-ldb-bignum (bignum bignum-len byte-len skipped-digits)
- (multiple-value-bind (res-len-1 extra) (truncate byte-len digit-size)
- (declare (type bignum-index res-len-1))
- (let* ((res-len (1+ res-len-1))
- (res (%allocate-bignum res-len)))
- (declare (type bignum-index res-len))
- (do ((i skipped-digits (1+ i))
- (j 0 (1+ j)))
- ((or (= j res-len-1) (= i bignum-len))
- (cond ((< i bignum-len)
- (setf (%bignum-ref res j)
- (logand (%bignum-ref bignum i)
- (the bignum-element-type (%make-ones extra)))))
- ((%bignum-0-or-plusp bignum bignum-len))
- (t
- (do ((j j (1+ j)))
- ((= j res-len-1)
- (setf (%bignum-ref res j) (%make-ones extra)))
- (setf (%bignum-ref res j) all-ones-digit))))
- (%normalize-bignum res res-len))
- (declare (type bignum-index i j))
- (setf (%bignum-ref res j) (%bignum-ref bignum i))))))
-
-;;; This grabs unaligned bignum bits from bignum assuming byte-len causes at
-;;; least one digit boundary crossing. We use SHIFT-RIGHT-UNALIGNED referencing
-;;; lots of local variables established by it.
-(defun make-unaligned-ldb-bignum (bignum
- bignum-len
- byte-len
- skipped-digits
- pos)
- (multiple-value-bind (res-len-1 extra) (truncate byte-len digit-size)
- (shift-right-unaligned
- bignum skipped-digits pos (1+ res-len-1)
- ((or (= j res-len-1) (= i+1 bignum-len))
- (cond ((= j res-len-1)
- (cond
- ((< extra high-bits-in-first-digit)
- (setf (%bignum-ref res j)
- (logand (ash (%bignum-ref bignum i) minus-start-pos)
- ;; Must LOGAND after shift here.
- (%make-ones extra))))
- (t
- (setf (%bignum-ref res j)
- (logand (ash (%bignum-ref bignum i) minus-start-pos)
- ;; LOGAND should be unnecessary here with a logical
- ;; right shift or a correct unsigned-byte-32 one.
- high-mask))
- (when (%bignum-0-or-plusp bignum bignum-len)
- (setf (%bignum-ref res j)
- (logior (%bignum-ref res j)
- (%ashl (%make-ones
- (- extra high-bits-in-first-digit))
- high-bits-in-first-digit)))))))
- (t
- (setf (%bignum-ref res j)
- (logand (ash (%bignum-ref bignum i) minus-start-pos)
- ;; LOGAND should be unnecessary here with a logical
- ;; right shift or a correct unsigned-byte-32 one.
- high-mask))
- (unless (%bignum-0-or-plusp bignum bignum-len)
- ;; Fill in upper half of this result digit with 1's.
- (setf (%bignum-ref res j)
- (logior (%bignum-ref res j)
- (%ashl low-mask high-bits-in-first-digit)))
- ;; Fill in any extra 1's we need to be byte-len long.
- (do ((j (1+ j) (1+ j)))
- ((>= j res-len-1)
- (setf (%bignum-ref res j) (%make-ones extra)))
- (setf (%bignum-ref res j) all-ones-digit)))))
- (%normalize-bignum res res-len))
- res)))
-\f
-;;;; DPB (deposit byte)
-
-(defun bignum-deposit-byte (new-byte byte-spec bignum)
- (declare (type bignum-type bignum))
- (let* ((byte-len (byte-size byte-spec))
- (byte-pos (byte-position byte-spec))
- (bignum-len (%bignum-length bignum))
- (bignum-plusp (%bignum-0-or-plusp bignum bignum-len))
- (byte-end (+ byte-pos byte-len))
- (res-len (1+ (max (ceiling byte-end digit-size) bignum-len)))
- (res (%allocate-bignum res-len)))
- (declare (type bignum-index bignum-len res-len))
- ;; Fill in an extra sign digit in case we set what would otherwise be the
- ;; last digit's last bit. Normalize at the end in case this was
- ;; unnecessary.
- (unless bignum-plusp
- (setf (%bignum-ref res (1- res-len)) all-ones-digit))
- (multiple-value-bind (end-digit end-bits) (truncate byte-end digit-size)
- (declare (type bignum-index end-digit))
- ;; Fill in bits from bignum up to byte-pos.
- (multiple-value-bind (pos-digit pos-bits) (truncate byte-pos digit-size)
- (declare (type bignum-index pos-digit))
- (do ((i 0 (1+ i))
- (end (min pos-digit bignum-len)))
- ((= i end)
- (cond ((< i bignum-len)
- (unless (zerop pos-bits)
- (setf (%bignum-ref res i)
- (logand (%bignum-ref bignum i)
- (%make-ones pos-bits)))))
- (bignum-plusp)
- (t
- (do ((i i (1+ i)))
- ((= i pos-digit)
- (unless (zerop pos-bits)
- (setf (%bignum-ref res i) (%make-ones pos-bits))))
- (setf (%bignum-ref res i) all-ones-digit)))))
- (setf (%bignum-ref res i) (%bignum-ref bignum i)))
- ;; Fill in bits from new-byte.
- (if (typep new-byte 'fixnum)
- (deposit-fixnum-bits new-byte byte-len pos-digit pos-bits
- end-digit end-bits res)
- (deposit-bignum-bits new-byte byte-len pos-digit pos-bits
- end-digit end-bits res)))
- ;; Fill in remaining bits from bignum after byte-spec.
- (when (< end-digit bignum-len)
- (setf (%bignum-ref res end-digit)
- (logior (logand (%bignum-ref bignum end-digit)
- (%ashl (%make-ones (- digit-size end-bits))
- end-bits))
- ;; DEPOSIT-FIXNUM-BITS and DEPOSIT-BIGNUM-BITS only store
- ;; bits from new-byte into res's end-digit element, so
- ;; we don't need to mask out unwanted high bits.
- (%bignum-ref res end-digit)))
- (do ((i (1+ end-digit) (1+ i)))
- ((= i bignum-len))
- (setf (%bignum-ref res i) (%bignum-ref bignum i)))))
- (%normalize-bignum res res-len)))
-
-;;; This starts at result's pos-digit skipping pos-bits, and it stores bits
-;;; from new-byte, a fixnum, into result. It effectively stores byte-len
-;;; number of bits, but never stores past end-digit and end-bits in result.
-;;; The first branch fires when all the bits we want from new-byte are present;
-;;; if byte-len crosses from the current result digit into the next, the last
-;;; argument to DEPOSIT-FIXNUM-DIGIT is a mask for those bits. The second
-;;; branch handles the need to grab more bits than the fixnum new-byte has, but
-;;; new-byte is positive; therefore, any virtual bits are zero. The mask for
-;;; bits that don't fit in the current result digit is simply the remaining
-;;; bits in the bignum digit containing new-byte; we don't care if we store
-;;; some extra in the next result digit since they will be zeros. The last
-;;; branch handles the need to grab more bits than the fixnum new-byte has, but
-;;; new-byte is negative; therefore, any virtual bits must be explicitly filled
-;;; in as ones. We call DEPOSIT-FIXNUM-DIGIT to grab what bits actually exist
-;;; and to fill in the current result digit.
-(defun deposit-fixnum-bits (new-byte byte-len pos-digit pos-bits
- end-digit end-bits result)
- (declare (type bignum-index pos-digit end-digit))
- (let ((other-bits (- digit-size pos-bits))
- (new-byte-digit (%fixnum-to-digit new-byte)))
- (declare (type bignum-element-type new-byte-digit))
- (cond ((< byte-len maximum-fixnum-bits)
- (deposit-fixnum-digit new-byte-digit byte-len pos-digit pos-bits
- other-bits result
- (- byte-len other-bits)))
- ((or (plusp new-byte) (zerop new-byte))
- (deposit-fixnum-digit new-byte-digit byte-len pos-digit pos-bits
- other-bits result pos-bits))
- (t
- (multiple-value-bind (digit bits)
- (deposit-fixnum-digit new-byte-digit byte-len pos-digit pos-bits
- other-bits result
- (if (< (- byte-len other-bits) digit-size)
- (- byte-len other-bits)
- digit-size))
- (declare (type bignum-index digit))
- (cond ((< digit end-digit)
- (setf (%bignum-ref result digit)
- (logior (%bignum-ref result digit)
- (%ashl (%make-ones (- digit-size bits)) bits)))
- (do ((i (1+ digit) (1+ i)))
- ((= i end-digit)
- (setf (%bignum-ref result i) (%make-ones end-bits)))
- (setf (%bignum-ref result i) all-ones-digit)))
- ((> digit end-digit))
- ((< bits end-bits)
- (setf (%bignum-ref result digit)
- (logior (%bignum-ref result digit)
- (%ashl (%make-ones (- end-bits bits))
- bits))))))))))
-
-;;; This fills in the current result digit from new-byte-digit. The first case
-;;; handles everything we want fitting in the current digit, and other-bits is
-;;; the number of bits remaining to be filled in result's current digit. This
-;;; number is digit-size minus pos-bits. The second branch handles filling in
-;;; result's current digit, and it shoves the unused bits of new-byte-digit
-;;; into the next result digit. This is correct regardless of new-byte-digit's
-;;; sign. It returns the new current result digit and how many bits already
-;;; filled in the result digit.
-(defun deposit-fixnum-digit (new-byte-digit byte-len pos-digit pos-bits
- other-bits result next-digit-bits-needed)
- (declare (type bignum-index pos-digit)
- (type bignum-element-type new-byte-digit next-digit-mask))
- (cond ((<= byte-len other-bits)
- ;; Bits from new-byte fit in the current result digit.
- (setf (%bignum-ref result pos-digit)
- (logior (%bignum-ref result pos-digit)
- (%ashl (logand new-byte-digit (%make-ones byte-len))
- pos-bits)))
- (if (= byte-len other-bits)
- (values (1+ pos-digit) 0)
- (values pos-digit (+ byte-len pos-bits))))
- (t
- ;; Some of new-byte's bits go in current result digit.
- (setf (%bignum-ref result pos-digit)
- (logior (%bignum-ref result pos-digit)
- (%ashl (logand new-byte-digit (%make-ones other-bits))
- pos-bits)))
- (let ((pos-digit+1 (1+ pos-digit)))
- ;; The rest of new-byte's bits go in the next result digit.
- (setf (%bignum-ref result pos-digit+1)
- (logand (ash new-byte-digit (- other-bits))
- ;; Must LOGAND after shift here.
- (%make-ones next-digit-bits-needed)))
- (if (= next-digit-bits-needed digit-size)
- (values (1+ pos-digit+1) 0)
- (values pos-digit+1 next-digit-bits-needed))))))
-
-;;; This starts at result's pos-digit skipping pos-bits, and it stores bits
-;;; from new-byte, a bignum, into result. It effectively stores byte-len
-;;; number of bits, but never stores past end-digit and end-bits in result.
-;;; When handling a starting bit unaligned with a digit boundary, we check
-;;; in the second branch for the byte spec fitting into the pos-digit element
-;;; after after pos-bits; DEPOSIT-UNALIGNED-BIGNUM-BITS expects at least one
-;;; digit boundary crossing.
-(defun deposit-bignum-bits (bignum-byte byte-len pos-digit pos-bits
- end-digit end-bits result)
- (declare (type bignum-index pos-digit end-digit))
- (cond ((zerop pos-bits)
- (deposit-aligned-bignum-bits bignum-byte pos-digit end-digit end-bits
- result))
- ((or (= end-digit pos-digit)
- (and (= end-digit (1+ pos-digit))
- (zerop end-bits)))
- (setf (%bignum-ref result pos-digit)
- (logior (%bignum-ref result pos-digit)
- (%ashl (logand (%bignum-ref bignum-byte 0)
- (%make-ones byte-len))
- pos-bits))))
- (t (deposit-unaligned-bignum-bits bignum-byte pos-digit pos-bits
- end-digit end-bits result))))
-
-;;; This deposits bits from bignum-byte into result starting at pos-digit and
-;;; the zero'th bit. It effectively only stores bits to end-bits in the
-;;; end-digit element of result. The loop termination code takes care of
-;;; picking up the last digit's bits or filling in virtual negative sign bits.
-(defun deposit-aligned-bignum-bits (bignum-byte pos-digit end-digit end-bits
- result)
- (declare (type bignum-index pos-digit end-digit))
- (let* ((bignum-len (%bignum-length bignum-byte))
- (bignum-plusp (%bignum-0-or-plusp bignum-byte bignum-len)))
- (declare (type bignum-index bignum-len))
- (do ((i 0 (1+ i ))
- (j pos-digit (1+ j)))
- ((or (= j end-digit) (= i bignum-len))
- (cond ((= j end-digit)
- (cond ((< i bignum-len)
- (setf (%bignum-ref result j)
- (logand (%bignum-ref bignum-byte i)
- (%make-ones end-bits))))
- (bignum-plusp)
- (t
- (setf (%bignum-ref result j) (%make-ones end-bits)))))
- (bignum-plusp)
- (t
- (do ((j j (1+ j)))
- ((= j end-digit)
- (setf (%bignum-ref result j) (%make-ones end-bits)))
- (setf (%bignum-ref result j) all-ones-digit)))))
- (setf (%bignum-ref result j) (%bignum-ref bignum-byte i)))))
-
-;;; This assumes at least one digit crossing.
-(defun deposit-unaligned-bignum-bits (bignum-byte pos-digit pos-bits
- end-digit end-bits result)
- (declare (type bignum-index pos-digit end-digit))
- (let* ((bignum-len (%bignum-length bignum-byte))
- (bignum-plusp (%bignum-0-or-plusp bignum-byte bignum-len))
- (low-mask (%make-ones pos-bits))
- (bits-past-pos-bits (- digit-size pos-bits))
- (high-mask (%make-ones bits-past-pos-bits))
- (minus-high-bits (- bits-past-pos-bits)))
- (declare (type bignum-element-type low-mask high-mask)
- (type bignum-index bignum-len))
- (do ((i 0 (1+ i))
- (j pos-digit j+1)
- (j+1 (1+ pos-digit) (1+ j+1)))
- ((or (= j end-digit) (= i bignum-len))
- (cond
- ((= j end-digit)
- (setf (%bignum-ref result j)
- (cond
- ((>= pos-bits end-bits)
- (logand (%bignum-ref result j) (%make-ones end-bits)))
- ((< i bignum-len)
- (logior (%bignum-ref result j)
- (%ashl (logand (%bignum-ref bignum-byte i)
- (%make-ones (- end-bits pos-bits)))
- pos-bits)))
- (bignum-plusp
- (logand (%bignum-ref result j)
- ;; 0's between pos-bits and end-bits positions.
- (logior (%ashl (%make-ones (- digit-size end-bits))
- end-bits)
- low-mask)))
- (t (logior (%bignum-ref result j)
- (%ashl (%make-ones (- end-bits pos-bits))
- pos-bits))))))
- (bignum-plusp)
- (t
- (setf (%bignum-ref result j)
- (%ashl (%make-ones bits-past-pos-bits) pos-bits))
- (do ((j j+1 (1+ j)))
- ((= j end-digit)
- (setf (%bignum-ref result j) (%make-ones end-bits)))
- (declare (type bignum-index j))
- (setf (%bignum-ref result j) all-ones-digit)))))
- (declare (type bignum-index i j j+1))
- (let ((digit (%bignum-ref bignum-byte i)))
- (declare (type bignum-element-type digit))
- (setf (%bignum-ref result j)
- (logior (%bignum-ref result j)
- (%ashl (logand digit high-mask) pos-bits)))
- (setf (%bignum-ref result j+1)
- (logand (ash digit minus-high-bits)
- ;; LOGAND should be unnecessary here with a logical right
- ;; shift or a correct unsigned-byte-32 one.
- low-mask))))))
-|#