;;;-*- Mode:LISP; Package:NEW-MATH; Base:10; Readtable:CL -*-
;;;
;;; Written by Youcef Bennour.
;;;


;;;***********************************
;;;*                                 *
;;;*   D I S P A T C H   T A B L E   *
;;;*                                 *
;;;***********************************

(defafun binary-bignum-op-dispatch-table (x y)
  (alu L+R+C md a0 a1 ch-return next-pc-return unboxed-md)	; 0 is for ADD
  (alu L-R-C md a0 a1 ch-return next-pc-return unboxed-md)	; 1 is for SUB
AND
  (alu AND md a0 a1 ch-return next-pc-return unboxed-md)	; 2 is for AND
OR
  (alu OR md a0 a1 ch-return next-pc-return unboxed-md)		; 3 is for IOR
  (alu XOR md a0 a1 ch-return next-pc-return unboxed-md)	; 4 is for XOR
  (alu XNOR md a0 a1 ch-return next-pc-return unboxed-md)	; 5 is for EQV
  (branch NOT (alu AND a2 a0 a1 boxed))			        ; 6 is for NAND
  (branch NOT (alu OR a2 a0 a1 boxed))				; 7 is for NOR
  (branch AND (alu not-r a0 ignore a0 boxed))			; 8 is for ANDC1
  (branch AND (alu not-r a1 ignore a1 boxed))			; 9 is for ANDC2
  (branch OR (alu not-r a0 ignore a0 boxed))			; 10 is for ORC1
  (branch OR (alu not-r a1 ignore a1 boxed))			; 11 is for ORC2
NOT
  (alu not-r md ignore a2 ch-return next-pc-return unboxed-md)	; complement answer and return.
  )


;;;****************************************
;;;*                                      *
;;;*  B I G N U M     O P E R A T I O N S *
;;;*                                      *
;;;****************************************

(defun add-bignum (a b)
  (binary-bignum-operation a b 0 0))

(defun subtract-bignum (a b)
  (binary-bignum-operation a b 1 hw:$$alu-status-carry))

(defun logand-bignum (a b)
  (binary-bignum-operation a b 2 0))

(defun logior-bignum (a b)
  (binary-bignum-operation a b 3 0))

(defun logxor-bignum (a b)
  (binary-bignum-operation a b 4 0))

(defun logxnor-bignum (a b)
  (binary-bignum-operation a b 5 0))

(defun lognand-bignum (a b)
  (binary-bignum-operation a b 6 0))

(defun lognor-bignum (a b)
  (binary-bignum-operation a b 7 0))

(defun logandc1-bignum (a b)
  (binary-bignum-operation a b 8 0))

(defun logandc2-bignum (a b)
  (binary-bignum-operation a b 9 0))

(defun logorc1-bignum (a b)
  (binary-bignum-operation a b 10. 0))

(defun logorc2-bignum (a b)
  (binary-bignum-operation a b 11. 0))


(defafun binary-bignum-operation (bignum1 bignum2 operation starting-status-reg)
  ;; a0 <---- bignum 1 pointer
  ;; a1 <---- bignum 2 pointer
  ;; a2 <---- operation
  ;; a3 <---- status register to load before the operation.

  ;; Locals
  ;;      a4  <----- length of first bignum
  ;;      a5  <----- length of second bignum
  ;;      a6  <----- Sign extension of shorter bignum
  ;;      a7  <----- 32 bit word from first operand
  ;;      a8  <----- 32 bit word from second operand
  ;;      a9  <----- temp for initial status overflow.
  ;;      a10 <----- pointer to result bignum structure.
  ;;      a11 <----- index stepping through the words of bignums
  ;;      a13 <----- Flag to indicate swap of arguments.  Needed for subtraction.  --wkf

  (move vma-start-read a0 boxed-vma boxed-md)			; read header of first bignum
  (move a13 gr:*zero*)                                          ; Initialize the flag.
  (alu merge-r a4 gr:*zero* MD bw-24 boxed)			; length of first bignum in a4
  (move vma-start-read a1 boxed-vma boxed-md)			; read header of second bignum
  (alu L+1 a11 a4 ignore bw-24 boxed)				; size of bignum result structure (while waiting on md)
  (alu merge-r a5 gr:*zero* MD bw-24 boxed)			; length of second bignum in a5

  (alu L-R nop a4 a5 bw-24 unboxed)				; difference of length
  (alu L-R nop a4 a5 bw-24 unboxed br-equal)			; test for equal length
  (branch alloc-struc-for-res () br-greater-than)		; length are equal go to start. otherwise test for less than
  (branch sign-ext-of-shorter-bignum ())
  
second->-first
  ;; Swap pointers such that a0 will have the pointer of the bignum with the most words, a1 will have the other.
  ;; Sign extension of shorter bignum in a7. a4 has the max of length and a5 the min.
  ;; use a11 as a temp.
  (move a11 a0)
  (move a0 a1)
  (move a1 a11)
  
  ;; Swap lengths
  (move a11 a4)
  (move a4 a5)
  (move a5 a11)
  (move a13 a2)  ;;Record the fact that we swapped the arguments.

sign-ext-of-shorter-bignum
  ;; Start reading the most significant word of shorter bignum
  (alu L+R vma-start-read-no-transport a1 a5 unboxed-vma unboxed-md)
  ;; while waiting compute size of result bignum structure.
  (alu L+1 a11 a4 ignore bw-24 boxed)				; size of bignum result structure
  ;; wait until you get the result of the read
  (move a6 MD)
  (alu SIGN a6 ignore ignore unboxed)				; sign extension of the shorter bignum.
  
alloc-struc-for-res
;; already computed.  (alu L+1 a11 a4 ignore bw-24 boxed)	; size of bignum structure
  (OPEN-CALL (allocate-bignum 1) a10 (O0 a11))			; allocate the structure.
  ;; Start the operation.
  (movei a11 1 unboxed)						; initialize index.
  (movea a12 (binary-bignum-op-dispatch-table 2))		; get address of the dispatch table
  (alu L+R a12 a2 a12 boxed)					; compute the dispatch address.
next-word
  (alu L+R vma-start-read-no-transport a11 a0 bw-24 unboxed-vma unboxed-md) ; get next word of bignum pointed to by a0
  (nop)
  (move O0 MD CH-OPEN)						; first argument in open 0
  (alu L+R vma-start-read-no-transport a11 a1 bw-24 unboxed-vma unboxed-md) ; get next word of bignum pointed to by a1
  (nop)
  ;; dispatch to the right operation.
  (move nop a12)
  (move O1 MD)							; second argument in open 1
  (alu load-status-r nop ignore a3 ch-call next-pc-dispatch)	; Dispatch to appropriate operation.
  (alu pass-status a3 ignore ignore unboxed)			; save status for next operation
  (alu L+R vma-start-write-no-gc-trap a11 a10 bw-24 unboxed-vma); write result
  (alu L-R nop a11 a5 bw-24 unboxed)				; are we done?
  (alu L+1 a11 a11 ignore bw-24 br-less-than unboxed)		; increment counter while deciding if we are done with this.
  (branch next-word ())
any-remaining-words
  (alu L-R nop a11 a4 bw-24 unboxed)
  (test br-greater-than)
  (branch computation-done ())
  (alu L+R vma-start-read-no-transport a0 a11 bw-24 unboxed-vma unboxed-md) ; get next word of bignum pointed to by a0
  (move O1 a6 CH-OPEN)						; first argument in open 0
  (move nop a12)						; Set up dispatch address
  (move O0 MD)							; word from memory must be here now.
  (alu load-status-r nop ignore a3 ch-call next-pc-dispatch)	; Dispatch to appropriate operation.  
  (alu pass-status a3 ignore ignore unboxed)			; Save status
  (alu L+R vma-start-write-no-gc-trap a10 a11 bw-24 unboxed-vma)		; Write answer
  (unconditional-branch any-remaining-words (alu L+1 a11 a11 ignore bw-24 unboxed)) ; Increment for the next word.
computation-done
  (alu-field field-xor a15 a3 gr:*all-zero* (byte 15. 17.) unboxed) 	;last word = extend(N xor V) = (byte 1 14.) of status
  (alu SIGN MD ignore ignore unboxed-md)
  (alu L+R vma-start-write-no-gc-trap a11 a10 unboxed-vma)
  ;; try to see if we can shrink this.
  (alu L-R nop a13 gr:*one* bw-24 unboxed)
  (test br-equal)
  (branch negate-answer ())
  (tail-open-call (shrink-bignum-structure 1) (o0 a10))
negate-answer
  (tail-open-call (negate-bignum 1) (o0 a10))
  )


(defafun negate-bignum (bignum)

  ;; Should build a new bignum of size 1+ current one.  @@@ This is rarely true, answer is normally same size.  --wkf

  ;;  Flip bits and add one.
  ;;  Edge cases are:
  ;;      1) #x800000 becomes fixnum #x-800000
  ;;      2) #x80000000 (n+1 words) becomes #x-80000000 (n words)

  ;; a0 <---- pointer to bignum.

  ;; LOCALS
  ;;		a1 <---- Index counter.
  ;;		a2 <---- Bignum length.
  ;;		a4 <---- Save register status - Must be initialized with carry = 1
  ;;		a5 <---- Save status of overflow traps.
  ;;		a6 <---- Temp
  ;;		a7 <---- pointer to bignum result.

  (move vma-start-read a0 boxed-vma boxed-md)			; Read bignum header.
  (movei a1 1)	 						; Init counter loop.
  (movei a4 hw:$$alu-status-carry)				; Save status register with carry set initially.
  (alu merge-r a2 gr:*zero* MD bw-24 boxed)			; Get length of bignum.
  (alu R+1 a6 ignore a2 bw-24 boxed)				; Expected size of bignum result.
  (OPEN-CALL (allocate-bignum 1) a7 (O0 a6))			; allocate a bignum structure.

next-word
  (alu L+R vma-start-read-no-transport a1 a0 unboxed-vma unboxed-md) ; Get next word
  (alu load-status-r nop ignore a4 unboxed)			; Restore status register
  (alu L-R-C MD gr:*all-zero* MD unboxed-md)			; If there was a carry, it is added to the next word.
  (alu pass-status a4 ignore ignore unboxed)			; Save status for next time around.
  (alu L+R vma-start-write-no-gc-trap a7 a1 unboxed-vma)			; Write word back to storage.
  (alu L-R nop a1 a2 bw-24 unboxed)				; Are we done?
  (alu L+1 a1 a1 ignore bw-24 br-less-than unboxed)		; Increment counter.
  (branch next-word ())
  (alu-field field-xor a6 a4 gr:*all-zero* (byte 15. 17.) unboxed) 	;last word = extend(N xor V) = (byte 1 14.) of status
  (alu SIGN MD ignore ignore unboxed-md)
  (alu L+R vma-start-write-no-gc-trap a7 a1 unboxed-vma)			; Write it.
  (tail-open-call (shrink-bignum-structure 1) (O0 a7))		; Call shrink bignum routine.
  )

(defafun lognot-bignum (bignum)
  ;; a0 <---- pointer to bignum

  ;; LOCALS
  ;;		a1 <---- Index counter.
  ;;		a2 <---- Length of bignum.
  ;;            a3 <---- pointer to bignum result.

  (move vma-start-read a0 boxed-vma boxed-md)			; Read bignum header.
  (movei a1 '1)							; Init counter for loop.
  (alu merge-r a2 gr:*zero* MD bw-24 boxed)			; Get the bignum length
  (OPEN-CALL (allocate-bignum 1) a3 (O0 a2))			; allocate a new bignum structure of same size.
next-word
  (alu L+R vma-start-read-no-transport a1 a0 bw-24 unboxed-vma unboxed-md) ; Get next word.
  (nop)
  (alu not-r MD ignore MD unboxed)				; Complement the word.
  (alu L+R vma-start-write-no-gc-trap a1 a3 unboxed-vma)			; write the word back to result.
  (alu L-R nop a1 a2 bw-24 unboxed)				; Are we done?
  (alu L+1 a1 a1 ignore bw-24 br-less-than unboxed)		; Increment counter.
  (branch next-word ())
  (tail-open-call (shrink-bignum-structure 1) (o0 a3))
  )

(defafun zero-bignum-internal (bignum) ;;; not a user routine, modifies the passed bignum!
  ;; a0 <---- pointer to bignum
  ;; Returns a bignum with all the words containing zero.
  ;; Must have the same length as before, do not call the shrink routine.

  ;; LOCALS
  ;;		a1 <---- Index to bignum words.
  ;;		a2 <---- Length of bignum in words.
  
  (move vma-start-read a0 boxed-vma boxed-md)			; Read bignum header
  (movei a1 '1)							; Init index register
  (alu merge-r a2 ignore MD bw-24 boxed)		; Get the length of the bignum.
  (movei md 0 unboxed-md)					; Value to write into bignum words
next-word
  (alu L+R vma-start-write-no-gc-trap a1 a0 bw-24 unboxed-vma)		; write 0 to current word.
  (alu L-R nop a1 a2 bw-24 unboxed)				; Are we done?
  (alu L+1 a1 a1 ignore bw-24 br-less-than unboxed)		; Increment counter.
  (branch next-word ())
  (return a0 boxed-right)
  )

;;;*****************************************
;;;*                                       *
;;;*      M U L T P L I C A T I O N S      *
;;;*                                       *
;;;*****************************************

(prims:defmacro %vm-read24 (pointer fixnum-offset)
  `(progn
     (hw:vma-start-read-no-transport-vma-unboxed-md-unboxed (hw:24+ ,fixnum-offset ,pointer))
     (hw:read-md)))

(prims:defmacro %vm-read32 (pointer offset)
  `(progn
     (hw:vma-start-read-no-transport-vma-unboxed-md-unboxed (hw:32+ ,offset ,pointer))
     (hw:read-md)))

(prims:defmacro %vm-read (pointer)
  `(progn
     (hw:vma-start-read-vma-boxed-md-boxed ,pointer)
     (hw:read-md)))

(prims:defmacro %vm-write24 (pointer fixnum-offset data)
  `(progn
     (hw:write-md-unboxed ,data)
     (hw:vma-start-write-no-gc-trap-unboxed (hw:24+ ,fixnum-offset ,pointer))))

(prims:defmacro %vm-write32 (pointer offset data)
  `(progn
     (hw:write-md-unboxed ,data)
     (hw:vma-start-write-no-gc-trap-unboxed (hw:32+ ,offset ,pointer))))

(prims:defmacro %vm-write (pointer data)
  `(progn
     (hw:write-md-boxed ,data)
     (hw:vma-start-write-boxed ,pointer)))

;;; A = (-AS * 2**(n-1)) + AM
;;; B = (-BS * 2**(m-1)) + BM
;;;
;;; A * B = (AS * BS * 2**(n+m-2))  ---> non-zero if both negative
;;;       - (AS * BM * 2**(n-1))    ---> non-zero if A negative
;;;       - (BS * AM * 2**(m-1))    ---> non-zero if B negative
;;;       + (AM * BM)               ---> product of all but the sign bits (unsigned multiply)
;;;
;;;  AM = (AH * 2**(n/2)) + AL
;;;  BM = (BH * 2***m/2)) + BL
;;;
;;;  AM * BM = (AH * BH * 2**((m+n)/2))   ; wallace tree
;;;          + (AH * BL * 2**(n/2))
;;;          + (BH * AL * 2**(m/2))
;;;          + (AL * BL)

(defun multiply-bignum (a-ptr b-ptr) ;;; C = A * B
  (let* 
    ((a-size (hw:dpb (%vm-read a-ptr) vinc:%%bignum-words gr:*zero*))
     (b-size (hw:dpb (%vm-read b-ptr) vinc:%%bignum-words gr:*zero*))
     (c-size (+ a-size b-size))
     (c-ptr  (allocate-bignum c-size))
     (a-data (%vm-read24 a-ptr a-size))
     (b-data (%vm-read24 b-ptr b-size))
     (a-sign (hw:ldb a-data vinc:%%bignum-sign-high-word gr:*zero*))
     (b-sign (hw:ldb b-data vinc:%%bignum-sign-high-word gr:*zero*)))
    (zero-bignum-internal c-ptr)
    (when (not (or (zerop a-sign) (zerop b-sign)))
      (%vm-write24 c-ptr c-size (hw:unboxed-constant #x40000000)))
    (when (not (zerop a-sign))
      (subtract-shifted-bignum-from-result b-ptr b-size c-ptr c-size a-size))
    (when (not (zerop b-sign))
      (subtract-shifted-bignum-from-result a-ptr a-size c-ptr c-size b-size))
    (do
      ((a-index 1 (1+ a-index)))
      ((> a-index a-size))
      (setq a-data (if (= a-index a-size)
		       (hw:dpb-unboxed (%vm-read24 a-ptr a-index) vinc:%%bignum-non-sign-high-word gr:*all-zero*)
		     (%vm-read24 a-ptr a-index)))
      (do
	((b-index 1 (1+ b-index)))
	((> b-index b-size))
	(setq b-data (if (= b-index b-size)
			 (hw:dpb-unboxed (%vm-read24 b-ptr b-index) vinc:%%bignum-non-sign-high-word gr:*all-zero*)
		       (%vm-read24 b-ptr b-index)))
	(umul32-and-add-to-result
	  a-data
	  b-data
	  (1- (+ a-index b-index))
	  c-ptr
	  c-size)))
    (shrink-bignum-structure c-ptr)))


(defafun umul32-and-add-to-result (a-data b-data c-offset c-ptr c-size)
  ;; a0 <---- multiplicand a
  ;; a1 <---- multiplier b
  ;; a2 <---- c offset fixnum
  ;; a3 <---- c-ptr
  ;; a4 <---- c-size fixnum

  ;; Result will be in
  ;;			Q reg for low product
  ;;			a14 for high product.

  ;; Returns 2 registers value
  ;;		low-product return register
  ;;		high-product a14

  (alu load-q-r nop a0 a0 unboxed)
  
  (alu umul-first a14 a1 gr:*all-zero* unboxed)
  (alu umul-step a14 a1 a14 unboxed)
  (alu umul-step a14 a1 a14 unboxed)
  (alu umul-step a14 a1 a14 unboxed)

  (alu umul-step a14 a1 a14 unboxed)
  (alu umul-step a14 a1 a14 unboxed)
  (alu umul-step a14 a1 a14 unboxed)
  (alu umul-step a14 a1 a14 unboxed)

  (alu umul-step a14 a1 a14 unboxed)
  (alu umul-step a14 a1 a14 unboxed)
  (alu umul-step a14 a1 a14 unboxed)
  (alu umul-step a14 a1 a14 unboxed)

  (alu umul-step a14 a1 a14 unboxed)
  (alu umul-step a14 a1 a14 unboxed)
  (alu umul-step a14 a1 a14 unboxed)
  (alu umul-step a14 a1 a14 unboxed)
  
  (alu umul-last a14 a1 a14 unboxed)     ;high result
  (alu l+r vma-start-read-no-transport a2 a3 bw-24 unboxed-vma unboxed-md)
  (alu pass-q a15 ignore ignore unboxed) ;low  result
  (alu l+r md-start-write-no-gc-trap a15 md unboxed-md)
  (alu pass-status a15 ignore ignore unboxed)
  (alu r+1 a2 ignore a2 bw-24)
  (alu l+r vma-start-read-no-transport a2 a3 bw-24 unboxed-vma unboxed-md)
  (alu load-status-r nop ignore a15)
  (alu l+r+c md-start-write-no-gc-trap a14 md unboxed-md)
  (alu pass-status a15 ignore ignore unboxed)
add-loop
  (alu l-r nop a2 a4 bw-24)
  (test br-greater-or-equal)
  (branch done (alu r+1 a2 ignore a2 bw-24))
  (alu l+r vma-start-read-no-transport a2 a3 bw-24 unboxed-vma unboxed-md)
  (alu load-status-r nop ignore a15)
  (unconditional-branch add-loop (alu l+r+c md-start-write-no-gc-trap gr:*all-zero* md unboxed-md))
done
  (return a3 boxed-right)
  )

(defafun subtract-shifted-bignum-from-result (from-ptr from-size to-ptr to-size shift)
  ; a0  - from-ptr
  ; a1  - from-size
  ; a2  - to-ptr
  ; a3  - to-size
  ; a4  - shift this many words less one bit (to-index)

  ; a5  - from index
  ; a6  - from high data
  ; a7  - from low data
  ; a8  - saved status reg
  ; a9  - current word to be summed

  (alu r+1 vma-start-read-no-transport ignore a0 unboxed-vma unboxed-md)
  (movei a5 1 unboxed)
  (move a7 gr:*all-zero* unboxed)
  (movei a8 hw:$$alu-status-carry unboxed)
  (move a6 md)
sub-loop
  (alu l+r vma-start-read-no-transport a2 a4 unboxed-vma unboxed-md)
  (alu-field field-extract-lr a9 a6 a7 (byte 32. -1.))
  (alu load-status-r nop ignore a8)
  (alu r-l-c md-start-write-no-gc-trap a9 md unboxed-md)
  (alu pass-status a8 ignore ignore unboxed)
  (alu l-r nop a4 a3 bw-24)
  (alu l-r nop a5 a1 bw-24 br-greater-or-equal)
  (branch done (alu r+1 a4 ignore a4 bw-24 br-greater-or-equal))
  (branch from-extend (alu r+1 a5 ignore a5 bw-24))
  (alu l+r vma-start-read-no-transport a0 a5 unboxed-vma unboxed-md)
  (move a7 a6)
  (unconditional-branch sub-loop (move a6 md))
from-extend
  (alu-field field-extract-r a7 ignore a6 (byte 31. 0.))
  (unconditional-branch sub-loop (move a6 gr:*all-zero*))
done
  (return a2 boxed-right)
 )

;;;*******************************
;;;*                             *
;;;*      D I V I S I O N S      *
;;;*                             *
;;;*******************************

(defun divide-bignum (dividend divisor)
  (let* ((dividend-size (hw:ldb (%vm-read dividend) vinc:%%fixnum-field 0))
	 (divisor-size  (hw:ldb (%vm-read divisor) vinc:%%fixnum-field 0))
	 (dividend-data (%vm-read32 dividend dividend-size))
	 (divisor-data  (%vm-read32 divisor  divisor-size))
	 (quotient      (allocate-bignum dividend-size))
	 (remainder     (allocate-bignum divisor-size))
	 )
    (cond
      ((and (hw:32zerop divisor-data) (= divisor-size 1))		;zero divide only possible by coercion
       (trap:illop "Zero divide error"))
      ((= divisor-size 1)
       (if (= dividend-size 1)
	   (divide-bignum-one-word-long dividend-data divisor-data quotient remainder)
	 (let ((status 0))
	   (do ((index dividend-size (1- index))
		(first t nil))
	       ((zerop index))
	     (setq status (divide-bignum-one-word-divisor
			    dividend
			    divisor-data
			    quotient remainder
			    index status first)))
	   (divide-bignum-return-results quotient dividend-size remainder divisor-size status dividend-data divisor))))
      (t
       (let ((status 0))
	 (do ((index dividend-size (1- index))
	      (first t nil))
	     ((zerop index))
	   (setq status (divide-bignum-internal
			  dividend
			  divisor divisor-size divisor-data
			  quotient remainder
			  index status first)))
	 (divide-bignum-return-results quotient dividend-size remainder divisor-size status dividend-data divisor))))))


(defafun divide-bignum-one-word-divisor (dividend divisor-data quotient remainder index status first)
; a0 - dividend pointer
; a1 - divisor data
; a2 - quotient pointer
; a3 - remainder pointer
; a4 - dividend/quotient index
; a5 - status word
; a6 - first time flag
;
; a8  - remainder sign extend
; a9  - remainder data
; a10 - divisor sign extend
; a13 - outer loop count

  (alu l+r vma-start-read-no-transport a0 a4 unboxed-vma unboxed-md)		;read dividend word
  (alu-field nb-shift-ar-r a10 ignore a1 (byte 0. -32.) unboxed)		;sign extension of divisor
  (move nop a6)
  (movei a13 '32 br-not-zero)							;32 iterations in outer loop
  (branch setup-first (alu load-q-r nop ignore md))				;Q = dividend word
  (alu r+1 vma-start-read-no-transport ignore a3 unboxed-vma unboxed-md)	;midpoint correct remainder
  (alu load-status-r nop ignore a5)
  (alu shift-dn-0f-r a15 ignore md)
  (alu shift-up-0f-rq a9 ignore a15 unboxed-md)
  (unconditional-branch outer-loop-setup (alu pass-status a5 ignore ignore unboxed))
setup-first
  (alu sign a9 ignore ignore unboxed-md)					;initialize remainder for first pass
  (alu sdiv-first a9 a10 a9 unboxed-md)
  (alu pass-status a5 ignore ignore unboxed)
outer-loop-setup
  (alu-field nb-shift-ar-r a8 ignore a9 (byte 0. -32.) unboxed)			;sign extension of remainder
outer-loop
  (alu r-1 a13 ignore a13 bw-24)
  (alu load-status-r nop ignore a5 br-zero)
  (branch last-loop (alu mp-div-step1 a9 a1 a9 unboxed))
  (alu mp-sdiv-step3 a8 a10 a8 unboxed)
  (unconditional-branch outer-loop (alu pass-status a5 ignore ignore unboxed))
last-loop
  (alu mp-sdiv-step3 a8 a10 a8 unboxed)
  (alu pass-status a5 ignore ignore unboxed)
  (move md a9 unboxed-md)
  (alu r+1 vma-start-write-no-gc-trap ignore a3 unboxed-vma)				;save remainder
  (nop)
  (alu pass-q md ignore ignore unboxed-md)					;save quotient
  (alu l+r vma-start-write-no-gc-trap a2 a4 unboxed-vma)
  (return a5 boxed-right)
 )

(defafun divide-bignum-internal (dividend divisor divisor-size divisor-high quotient remainder index status first)
; a0 - dividend pointer
; a1 - divisor pointer
; a2 - divisor size
; a3 - divisor high data
; a4 - quotient pointer
; a5 - remainder pointer
; a6 - dividend/quotient index
; a7 - status word
; a8 - first time flag
;
; a10 - current index
; a11 - current dividend data
; a12 - current divisor data
; a13 - outer loop count

  (alu l+r vma-start-read-no-transport a0 a6 unboxed-vma unboxed-md)		;read dividend word
  (movei a13 '32)								;32 iterations in outer loop
  (move nop a8)
  (move a15 a2 br-not-zero)
  (branch setup-first (alu load-q-r nop ignore md))				;Q = dividend word
  (alu r+1 vma-start-read-no-transport ignore a5 unboxed-vma unboxed-md)			;midpoint correct remainder
  (alu load-status-r nop ignore a7)
  (alu shift-dn-0f-r a15 ignore md)
  (alu shift-up-0f-rq md-start-write-no-gc-trap ignore a15 unboxed-md)
  (unconditional-branch outer-loop (alu pass-status a7 ignore ignore unboxed))
setup-first
  (alu sign md ignore ignore unboxed-md)					;initialize remainder for first pass
setup-loop
  (alu l+r vma-start-write-no-gc-trap a5 a15 unboxed-vma)
  (alu r-1 a15 ignore a15 bw-24)
  (test br-not-zero)
  (branch setup-loop ())
  (alu r+l vma-start-read-no-transport a2 a1 unboxed-vma unboxed-md) ;divisor hi
  (nop)
  (move r3 md)
  (alu r+1 vma-start-read-no-transport ignore a5 unboxed-vma unboxed-md) ;remainder lo
  (nop)
  (alu sdiv-first md-start-write-no-gc-trap r3 md unboxed-md)
  (alu pass-status a7 ignore ignore unboxed)
outer-loop
  (movei a10 '0)							;index = 0
inner-loop
  (alu l+r+c vma-start-read-no-transport a1 a10 unboxed-vma unboxed-md carry-1) ;A8 = divisor word
  (alu r+1 a10 ignore a10 bw-24)
  (move a8 md)
  (alu l+r vma-start-read-no-transport a5 a10 unboxed-vma unboxed-md)	;MD = remainder word
  (alu l-r nop a10 gr:*one* bw-24)
  (alu l-r nop a10 a2 br-equal bw-24)
  (branch first (alu load-status-r nop ignore a7 br-equal))
  (branch last  (alu load-status-r nop ignore a7))
middle
  (alu mp-div-step2 md-start-write-no-gc-trap a8 md unboxed-md)
  (unconditional-branch inner-loop (alu pass-status a7 gr:*zero* gr:*zero* bw-24))
first
  (alu mp-div-step1 md-start-write-no-gc-trap a8 md unboxed-md)
  (unconditional-branch inner-loop (alu pass-status a7 gr:*zero* gr:*zero* bw-24))
last
  (alu mp-sdiv-step3 md-start-write-no-gc-trap a8 md unboxed-md)
  (alu pass-status a7 gr:*zero* gr:*zero* bw-24)
  (alu r-1 a13 ignore a13 bw-24)
  (test br-not-zero)
  (branch outer-loop (alu pass-q md ignore ignore unboxed-md))
  (alu l+r vma-start-write-no-gc-trap a4 a6 unboxed-vma)
  (return a7 boxed-right)
 )


(defafun divide-bignum-one-word-long (dividend-data divisor-data quotient-ptr remainder-ptr)
  (alu load-q-r a4 a0 a0 )		;q <- dividend
  (alu sign a4 a0 a0 bw-32)		;sign extend initial remainder
  (alu sdiv-first a4 a1 a4)		;step 1
  (alu sdiv-step  a4 a1 a4)
  (alu sdiv-step  a4 a1 a4)
  (alu sdiv-step  a4 a1 a4)

  (alu sdiv-step  a4 a1 a4)
  (alu sdiv-step  a4 a1 a4)
  (alu sdiv-step  a4 a1 a4)
  (alu sdiv-step  a4 a1 a4)

  (alu sdiv-step  a4 a1 a4)
  (alu sdiv-step  a4 a1 a4)
  (alu sdiv-step  a4 a1 a4)
  (alu sdiv-step  a4 a1 a4)

  (alu sdiv-step  a4 a1 a4)
  (alu sdiv-step  a4 a1 a4)
  (alu sdiv-step  a4 a1 a4)
  (alu sdiv-step  a4 a1 a4)

  (alu sdiv-step  a4 a1 a4)
  (alu sdiv-step  a4 a1 a4)
  (alu sdiv-step  a4 a1 a4)
  (alu sdiv-step  a4 a1 a4)

  (alu sdiv-step  a4 a1 a4)
  (alu sdiv-step  a4 a1 a4)
  (alu sdiv-step  a4 a1 a4)
  (alu sdiv-step  a4 a1 a4)

  (alu sdiv-step  a4 a1 a4)
  (alu sdiv-step  a4 a1 a4)
  (alu sdiv-step  a4 a1 a4)
  (alu sdiv-step  a4 a1 a4)

  (alu sdiv-step  a4 a1 a4)
  (alu sdiv-step  a4 a1 a4)
  (alu sdiv-step  a4 a1 a4)
  (alu sdiv-step  a4 a1 a4)

  (alu sdiv-last1 a4 a1 a4)			;first fixup
  (alu pass-q a5 a1 a1 br-equal)		;no fixup2 if zero, save quotient maybe
  (branch done (alu setr md ignore a5 unboxed-md))

  (alu sdiv-last2 nop a1 a4)			;second fixup
  (move nop a4)
  (alu rem-corr a4 a1 a4)
  (alu pass-q a5 a1 a1)				;save fixed quotient
  (alu quo-corr md a5 a5 unboxed-md)		;final fixup
done
  (alu pass-status a14 gr:*zero* gr:*zero* boxed bw-24)
  (alu r+1 vma-start-write-no-gc-trap ignore a2)
  (nop)
  (move md a4 unboxed-md)
  (alu r+1 vma-start-write-no-gc-trap ignore a3)
  (open-call (shrink-bignum-structure 1) a13 (o0 a3))
  (open-call (shrink-bignum-structure 1) a2 (o0 a2))
  (movei gr:*number-of-return-values* '3 boxed)
  (move gr:*return-1* gr:*return-0*)
  (move gr:*return-0* a13)
  (return-mv a2 boxed-right)
 )


(defafun divide-bignum-return-results (quotient quotient-size remainder remainder-size status dividend-high divisor)
; a0 - quotient pointer
; a1 - dividend/quotient size
; a2 - remainder pointer
; a3 - divisor/remainder size
; a4 - status
; a5 - dividend high word
; a6 - divisor pointer
;
; a7  - divisor high word
; a8  - remainder high word
; a9  - quotient high word
; a10 - index
; a11 - temp status
; a12 - remainder zero flag

  (movei a12 '1)
  (move a10 a3)
down-shift-remainder-loop
  (alu l+r vma-start-read-no-transport a2 a10 unboxed-vma unboxed-md)
  (alu load-status-r nop ignore a4)
  (alu shift-dn-lf-r md-start-write-no-gc-trap ignore md unboxed-md)
  (alu pass-status a4 ignore ignore unboxed)
  (alu r-1 a10 ignore a10 bw-24)
  (alu-field extract-bit-right a15 ignore a4 (byte 1. 19.) unboxed br-not-zero) ; Z bit
  (branch down-shift-remainder-loop (alu and a12 a15 a12 bw-24))
set-quotient-lsb
  (alu r+1 vma-start-read-no-transport ignore a0 unboxed-vma unboxed-md)
  (move nop a12 bw-24)
  (alu-field set-bit-right md-start-write-no-gc-trap ignore md (byte 1. 0.) unboxed-md br-not-zero) ;set quotient lsb
  (branch correction-done ()) ;done if remainder = 0 now
  (alu l+r vma-start-read-no-transport a0 a1 unboxed-vma unboxed-md)
  (nop)
  (move a9 md)  ;quotient high word
  (alu l+r vma-start-read-no-transport a2 a3 unboxed-vma unboxed-md)
  (nop)
  (move a8 md) ;remainder high word
  (alu or nop a8 a5)
  (alu and nop a8 a5 br-not-negative)
  (branch correction-done (alu setr nop ignore a9 br-negative))
  (branch neg-divd-rem (alu setr a11 ignore gr:*all-zero* br-negative))
  (branch inc-q-and-sub-divs-from-rem (alu setr a10 ignore gr:*one*))
dec-q-and-add-divs-to-rem
  (alu l+r vma-start-read-no-transport a6 a10 unboxed-vma unboxed-md)
  (nop)
  (move a15 md)
  (alu l+r vma-start-read-no-transport a2 a10 unboxed-vma unboxed-md)
  (alu load-status-r nop ignore a11)
  (alu l+r+c md-start-write-no-gc-trap a15 md unboxed-md)
  (alu pass-status a11 ignore ignore unboxed)
  (alu l-r nop a10 a3 bw-24)
  (alu r+1 a10 ignore a10 bw-24 br-less-than)
  (branch dec-q-and-add-divs-to-rem ())
dec-q
  (move a10 gr:*one*)
  (move a11 gr:*all-zero*)
dec-q-loop
  (alu l+r vma-start-read-no-transport a0 a10 unboxed-vma unboxed-md)
  (alu load-status-r nop ignore a11)
  (alu r-l-c md-start-write-no-gc-trap gr:*all-zero* md unboxed-md)
  (alu pass-status a11 ignore ignore unboxed)
  (alu l-r nop a10 a1 bw-24)
  (alu r+1 a10 ignore a10 bw-24 br-less-than)
  (branch dec-q-loop ())
  (unconditional-branch correction-done ())
inc-q-and-sub-divs-from-rem
 (movei a11 hw:$$alu-status-carry unboxed)
sub-divs-from-rem
  (alu l+r vma-start-read-no-transport a6 a10 unboxed-vma unboxed-md)
  (nop)
  (move a15 md)
  (alu l+r vma-start-read-no-transport a2 a10 unboxed-vma unboxed-md)
  (alu load-status-r nop ignore a11)
  (alu r-l-c md-start-write-no-gc-trap a15 md unboxed-md)
  (alu pass-status a11 ignore ignore unboxed)
  (alu l-r nop a10 a3 bw-24)
  (alu r+1 a10 ignore a10 bw-24 br-less-than)
  (branch sub-divs-from-rem ())
inc-q
  (move a10 gr:*one*)
  (movei a11 hw:$$alu-status-carry unboxed)
inc-q-loop
  (alu l+r vma-start-read-no-transport a0 a10 unboxed-vma unboxed-md)
  (alu load-status-r nop ignore a11)
  (alu l+r+c md-start-write-no-gc-trap gr:*all-zero* md unboxed-md)
  (alu pass-status a11 ignore ignore unboxed)
  (alu l-r nop a10 a1 bw-24)
  (alu r+1 a10 ignore a10 bw-24 br-less-than)
  (branch inc-q-loop ())
  (alu-field extract-bit-right nop ignore a11 hw:%%alu-status-overflow)
  (test br-zero)
  (branch correction-done ())
quotient-overflow
  (alu r+1 a15 ignore a1 bw-24)
  (open-call (allocate-bignum 1) a15 (o0 a15))
quotient-overflow-copy-loop
  (alu l+r vma-start-read-no-transport a0 a1 unboxed-vma unboxed-md)
  (nop)
  (move md md unboxed-md)
  (alu l+r vma-start-write-no-gc-trap a15 a1 unboxed-vma)
  (alu r-1 a1 ignore a1 bw-24)
  (test br-not-zero)
  (branch quotient-overflow-copy-loop ())
  (unconditional-branch correction-done (alu setr a0 ignore a15))
neg-divd-rem
  (alu l+r vma-start-read-no-transport a6 a3 unboxed-vma unboxed-md)
  (movei a10 '1)
  (move a7 md)
  (movei a11 0 unboxed br-not-negative)
  (branch rem-plus-abs-divs ())
  (movei a11 hw:$$alu-status-carry unboxed)
rem-plus-abs-divs
  (alu l+r vma-start-read-no-transport a2 a10 unboxed-vma unboxed-md)
  (move nop a7)
  (move a15 md br-negative)
  (branch rem-plus-abs-neg-div (alu l+r vma-start-read-no-transport a6 a10 unboxed-vma unboxed-md))
rem-plus-abs-pos-div
  (alu load-status-r nop ignore a11)
  (alu l+r+c nop a15 md)
  (unconditional-branch rem-plus-abs-div-end (alu pass-status a11 ignore ignore unboxed))
rem-plus-abs-neg-div
  (alu load-status-r nop ignore a11)
  (alu r-l-c nop a15 md)
  (alu pass-status a11 ignore ignore unboxed)
rem-plus-abs-div-end
  (alu l-r nop a10 a3 bw-24 br-not-zero)
  (branch correction-done (alu r+1 a10 ignore a10 bw-24 br-less-than))
  (branch rem-plus-abs-divs ())
zero-rem
  (open-call (zero-bignum-internal 1) a2 (o0 a2)) ; remainder = 0
  (move nop a9)
  (test br-negative)
  (branch dec-q ())
  (unconditional-branch inc-q ())
correction-done
  (open-call (shrink-bignum-structure 1) a13 (o0 a2))	;shrink remainder
  (open-call (shrink-bignum-structure 1) ignore (o0 a0)) ;shrink quotient
  (movei gr:*number-of-return-values* '5 boxed)
  (move gr:*return-0* a13)
  (return-mv a0 boxed-right)
 )

;;;**************************************************
;;;                                                 *
;;;               COMPARE FUNCTIONS                 *
;;;                                                 *
;;;**************************************************


;; changed by Peter Cerrato on 4/27

(defun compare-bignum (ptr1 ptr2)
  (let* ((size1 (hw:ldb (%vm-read ptr1) vinc::%%fixnum-field 0))
	 (size2 (hw:ldb (%vm-read ptr2) vinc::%%fixnum-field 0))
	 (data1 (%vm-read32 ptr1 size1))
	 (data2 (%vm-read32 ptr2 size2))
	 (sign1 (hw:ldb data1 (byte 1. 31.) 0))
	 (sign2 (hw:ldb data2 (byte 1. 31.) 0)))
    (labels ((check-signs ()
			  (if (not (zerop (logxor sign1 sign2)))
			      (if (zerop sign1) ;different signs
				  (plus)
				(minus))
			    (if (not (= size1 size2))
				(if (zerop sign1)
				    (if (> size1 size2)
					(plus)
				      (minus))
				  (if (> size1 size2)
				      (minus)
				    (plus)))
			      (scan-equal (1- size1)))))
	     (scan-equal (size)
			 (if (hw:32= data1 data2)
			     (if (zerop size)
				 (values 0 hw:$$alu-status-zero) ;bit 19  of alu-status register ZERO flag
			       (progn
				 (setq data1 (%vm-read32 ptr1 size))
				 (setq data2 (%vm-read32 ptr2 size))
				 (scan-equal (1- size))))
			   (if (progn
				 (setq data1 (hw:32- data1 data2))
				 (hw:alu-status-logbitp (byte-position hw:%%alu-status-carry)))
			       (if (zerop sign1)
				   (plus)
				 (minus))
			     (if (zerop sign1)
				 (minus)
			       (plus)))))
	     (plus  () (values 1  hw:$$alu-status-positive))	;no bits set
	     (minus () (values -1 hw:$$alu-status-negative)))	;bit 17 set of alu-status register  NEGATIVE flag
      (check-signs))))

;(defafun compare-bignum (bignum1 bignum2)
;  ;; a0 <---- bignum1 pointer
;  ;; a1 <---- bignum2 pointer
;  ;;
;  ;; LOCALS
;  ;;      a3  <---- bignum1 's length
;  ;;      a4  <---- bignum2 's length
;  ;;      a5  <---- current word of bignum1
;  ;;      a6  <---- current word of bignum2

;  (move vma-start-read a0 boxed-vma boxed-md)
;  (nop)
;  (move a3 md)
;  (move vma-start-read a1 boxed-vma boxed-md)
;  (nop)
;  (move a4 md)
;  (alu l+r vma-start-read-no-transport a0 a3 unboxed-vma unboxed-md)
;  (movei gr:*number-of-return-values* '5 boxed)
;  (move a5 md)
;  (alu l+r vma-start-read-no-transport a1 a4 unboxed-vma unboxed-md br-negative)
;  (branch 1-neg ())
;1-pos
;  (move a6 md)
;  (alu xor nop a5 a6)
;  (test br-not-negative)
;  (branch check-lengths-1-pos ())
;greater-than
;  (alu l-r nop gr:*one* gr:*zero* bw-24)
;  (alu pass-status a14 gr:*zero* gr:*zero* bw-24)
;  (return gr:*one*)
;1-neg
;  (move a6 md)
;  (alu xor nop a5 a6)
;  (test br-not-negative)
;  (branch check-lengths-1-neg ())
;less-than
;  (alu l-r nop gr:*minus-one* gr:*zero* bw-24)
;  (alu pass-status a14 gr:*zero* gr:*zero* bw-24)
;  (return gr:*minus-one*)
;check-lengths-1-pos
;  (alu l-r nop a3 a4 bw-24)
;  (alu l-r nop a3 a4 bw-24 br-greater-than)
;  (branch greater-than () br-less-than)
;  (branch less-than ())
;  (unconditional-branch compare-equal-len-pos ())
;check-lengths-1-neg
;  (alu l-r nop a3 a4 bw-24)
;  (alu l-r nop a3 a4 bw-24 br-greater-than)
;  (branch less-than () br-less-than)
;  (branch greater-than ())
;compare-equal-len-neg
;  (alu l-r nop a5 a6)
;  (alu l-r nop a5 a6 br-greater-than)
;  (branch greater-than (alu setr a13 ignore a0 br-less-than))
;  (branch less-than (alu setr a0 ignore a1))
;  (unconditional-branch compare-equal-len (alu setr a1 ignore a13))
;compare-equal-len-pos
;  (alu l-r nop a5 a6)
;  (alu l-r nop a5 a6 br-greater-than)
;  (branch greater-than ())
;  (branch less-than ())
;compare-equal-len
;  (alu r-1 a3 ignore a3 bw-24)
;  (alu r-1 a4 ignore a4 bw-24 br-zero)
;  (branch equal (alu l+r vma-start-read-no-transport a0 a3 unboxed-vma unboxed-md))
;  (nop)
;  (move a5 md)
;  (alu l+r vma-start-read-no-transport a1 a4 unboxed-vma unboxed-md)
;  (nop)
;  (unconditional-branch compare-equal-len-pos (move a6 md))
;equal
;  (alu l-r nop gr:*zero* gr:*zero* bw-24)
;  (alu pass-status a14 gr:*zero* gr:*zero* bw-24)
;  (return gr:*zero*)
; )


(defun test-bignum (ptr)
  (let* ((size (hw:ldb (%vm-read ptr) vinc::%%fixnum-field 0))
	 (data (%vm-read24 ptr size))
	 (sign (hw:ldb data vinc:%%bignum-sign-high-word 0)))
    (if (zerop sign)
	(labels ((scan-zero ()
		     (if (hw:32= data gr:*all-zero*)
			 (if (zerop (setq size (1- size)))
			     (values 0 hw:$$alu-status-zero)
			   (progn (setq data (%vm-read24 ptr size))
				  (scan-zero)))
		       (values 1 hw:$$alu-status-positive))))
	     (scan-zero))
      (values -1 hw:$$alu-status-negative))))

;(defafun test-bignum (ptr)
;;;; Note - bignums are only greater or less than zero. Zero is a fixnum. (except when coerced!)
;  (move vma-start-read a0 boxed-vma boxed-md)
;  (nop)
;  (move a1 md)
;  (alu l+r vma-start-read-no-transport a0 a1 unboxed-vma unboxed-md)
;  (movei a15 '5)
;  (move a2 md)
;  (alu pass-status a14 gr:*zero* gr:*zero* bw-24 br-negative)
;  (branch neg (move a3 gr:*minus-one* br-greater-than))
;  (return gr:*one*)
;neg
;  (return gr:*minus-one*)
; )
  
;*******************************************************************************
; ASH Bignum (shift must be a fixnum)
;*******************************************************************************
;  a0 - bignum argument
;  a1 - shift amount argument
;
;  a2 - |shift| mod 32
;  a3 - number of words in bignum argument -- a fixnum
;  a4 - number of words to allocate for answer -- a fixnum
;  a5 - result bignum pointer
;  a6 - current result index -- a fixnum
;  a7 - current source index -- a fixnum
;  a9 - current source word hi
;  a10- current source word lo
;  a11- extraction shift constant
;
(defafun ash-bignum (num shift)
  (alu-field aligned-field-xor nop gr:*zero* a1 vinc:%%data-type) ;only fixnum shifts are legal
  (move vma-start-read a0 boxed-vma boxed-md br-zero)
  (branch got-shift-size (alu sex-r a1 ignore a1 bw-24 unboxed))
bad-ash
  (open-call (big-ash-illop 0) ignore ())
got-shift-size
  (alu setr nop a1 a1 bw-24 boxed dt-none br-negative) ;;zero test
  (branch shift-down (alu merge-r a3 gr:*zero* MD bw-24 boxed br-negative) br-not-zero)
  (branch shift-up (alu l+r vma-start-read-no-transport a3 a0 bw-24 unboxed-vma unboxed-md)) ;read top source word of bignum
zero-shift
  (movei (register *number-of-return-values* 11 15) (quote 2) boxed)
  (alu-field set-bit-right nop ignore md (byte 1 0))					     ;;top source word sign to status
  (alu pass-status (register *return-0* 10 0) ignore a3 bw-24 boxed)     ;; Get fixnum datatype from a3
  (move return-mv a0 boxed-right ch-return next-pc-return)
shift-up
  (movei a4 31. unboxed) ;allocate (+ old-length (ash (+ shift 31.) -5)) words for result
  (alu l+r a4 a1 a4 unboxed)
  (alu-field nb-shift-ar-r a4 ignore a4 (byte 32. -5.) unboxed)
  (alu l+r a4 a4 a3 bw-24 boxed)
  (open-call (allocate-bignum 1) a5 (o0 a4))
  (open-call (zero-bignum-internal 1) ignore (o0 a5))  				;;;@@@ Do we need to zero it?
  (alu-field field-extract-r a2 ignore a1 (byte 5. 0.) unboxed) ;shift mod 32
  (movei a11 32. unboxed) ;compute extract constant
  (alu l-r a11 a11 a2 bw-8 unboxed)
  (alu neg-r a11 ignore a11 bw-8 unboxed)
  (alu load-status-r nop ignore a11 bw-16)
  (move a6 a4) ; result index
  (move a7 a3) ; source index
  (move a10 md) ;top source word
  (alu sign a9 ignore ignore unboxed) ;sign extension of source
shift-up-loop
  (alu-field field-extract-lr md a9 a10 (byte 32. 0.) pw-ri unboxed-md)
  (alu l+r vma-start-write-no-gc-trap a6 a5 bw-24 unboxed-vma)
  (alu r-1 a7 ignore a7 bw-24)
  (alu r-1 a6 ignore a6 br-zero bw-24)
  (branch shift-up-finish (alu l+r vma-start-read-no-transport a7 a0 bw-24 unboxed-vma unboxed-md))
  (move a9 a10 unboxed)
  (unconditional-branch shift-up-loop (alu setr a10 ignore md unboxed))
shift-up-finish
  (alu-field field-extract-lr md a10 gr:*all-zero* (byte 32. 0.) pw-ri unboxed-md)
  (alu l+r vma-start-write-no-gc-trap a6 a5 bw-24 unboxed-vma)
  (tail-open-call (shrink-bignum-structure 1) (o0 a5))
shift-down
  (alu neg-r a1 ignore a1 unboxed)
  (alu-field nb-shift-ar-r a4 ignore a1 (byte 32. -5.) unboxed)
  (alu r-l a4 a4 a3 bw-24 boxed)
  (test br-greater-than)
  (branch shift-down-allocate ())
shift-down-till-nothing-left
  (alu l+r vma-start-read-no-transport a3 a0 bw-24 unboxed-vma unboxed-md)
  (movei a15 '5)
  (alu-field nb-shift-ar-r a10 ignore md (byte 32. -32.) unboxed)
  (alu pass-status a14 gr:*zero* gr:*zero* bw-24)
  (alu merge-r return gr:*zero* a10 bw-24 boxed ch-return next-pc-return)
shift-down-allocate
  (open-call (%allocate-bignum 1) a5 (o0 a4))
  (alu l+r vma-start-read-no-transport a3 a0 bw-24 unboxed-vma unboxed-md) ;read top source word
  (move a6 a4) ; result index
  (move a7 a3) ; source index
  (alu-field field-extract-r a2 ignore a1 (byte 5. 0.) unboxed) ;shift mod 32
  (alu neg-r a2 ignore a2 bw-8 br-greater-or-equal)
  (branch shift-down-more-setup ())
  (movei a2 '#x00e0)
shift-down-more-setup
  (alu load-status-r nop ignore a2 bw-16)
  (move a10 md) ;top source word
  (alu sign a9 ignore ignore unboxed) ;sign extension of source
shift-down-loop
  (alu-field field-extract-lr md a9 a10 (byte 32. 0.) pw-ri unboxed-md)
  (alu l+r vma-start-write-no-gc-trap a6 a5 bw-24 unboxed-vma)
  (alu r-1 a6 ignore a6 bw-24)
  (alu r-1 a7 ignore a7 br-zero bw-24)
  (branch shift-down-finish (alu l+r vma-start-read-no-transport a7 a0 bw-24 unboxed-vma unboxed-md))
  (move a9 a10 unboxed)
  (unconditional-branch shift-down-loop (alu setr a10 ignore md unboxed))
shift-down-finish
  (tail-open-call (shrink-bignum-structure 1) (o0 a5))
 )

(defun big-ash-illop ()
  (li:tail-error "Bad bignum ash shift amount (This used to be an illop.)"))

;*******************************************************************************
; Field Pass Bignum 
;*******************************************************************************
; a0 - from argument           a1 - to argument      a2 - byte spec argument
;
; a3 - position                a4 - size             a5 - from size in words
; a6 - to   size in words      a7 - result size      a8 - from index
; a9 - to index                a10-                  a11- result pointer
; a12- shift value             a13- from word high   a14- from word low
; a15- to word                 r0 - 32               r1 - 
; r2 -                         r3 - current bit      r4 - pos + size
; r5 - (mod (- 32 pos) 32)     r6 - current + 32

; DPB:	(cond
;	  ((>= cur (+ pos size))
;	   (just-copy-word))
;	  ((>= cur pos)
;	   (setq extract (mod (- 32. pos) 32)
;		 shift 0
;		 width (min 32. (- (+ pos size) cur))))
;	  ((> (+ cur 32.) pos)
;	   (setq extract 0
;		 shift (mod pos 32.)
;		 width (min size (- (+ cur 32.) pos)))))
;	  (t
;	   (just-copy-word)))

(defun field-pass-bignum (from to byte-spec ldb-p)
  (multiple-value-bind (size position)
      (resolve-byte-spec-internal byte-spec ldb-p)
    (field-pass-bignum-internal from to position size)))

; a0 - FROM argument      a1 - TO argument        a2 - POSITION argument
; a3 - SIZE argument      a4 - FROM size in words a5 - result ptr
; a6 - TO size in words   a7 - result size        a8 - from index
; a9 - 32		 a10 - current-bit       a11 - (mod pos 32)
;a12 - TO hi word        a13 - TO lo word        a14 - current TO index
;a15 - (+ pos size)       r1 - FROM word          r2 - (- 32 (mod pos 32))

(defafun field-pass-bignum-internal (from to position size)
  (move vma-start-read a0 boxed-vma boxed-md)
  (nop)
  (move a4 md bw-24 unboxed)          ;;from # words without a header
  (move vma-start-read a1 boxed-vma boxed-md)
  (move nop a3)
  (test br-negative)
  (branch ldb (alu merge-r a6 gr:*zero* md boxed bw-24)) ;;make a fixnum
dpb
  (movei a9 '32 boxed)
  (alu l+r a7 a3 a9 boxed-right bw-24)					; len = (max (ash (+ 32 position size) -5) to-size)
  (alu l+r a7 a2 a7 boxed-right bw-24)                         ;;@@@ This is too long sometimes if zeros in top of from --wkf
  (alu-field field-pass a7 a7 gr:*zero* (byte 19. -5.) boxed-right)
  (alu l-r nop a6 a7 bw-24)
  (test br-less-or-equal)
  (branch dpb-allocate-result ())
  (move a7 a6)
dpb-allocate-result
  (move o0 a1 ch-open)
  (call (copy-bignum-with-extension 2) a5 (o1 a7))			;copy TO bignum to result area with sign extension
  (movei a8 '1 boxed)
  (alu-field field-pass a11 a2 gr:*zero* (byte 5. 0.) boxed-right)	   ; (mod pos 32)
  (alu-field field-pass a14 a2 gr:*zero* (byte 19. -5.) boxed-right)	   ; (div pos 32)
  (alu l+r+c vma-start-read-no-transport a14 a5 bw-24 unboxed-vma unboxed-md carry-1)
  (move a10 a2)
  (alu l+r a15 a2 a3 bw-24 boxed-right)
  (alu l-r r2 a9 a11 bw-24 boxed-right)
  (move a12 md)
dpb-loop
  (alu-field field-pass a14 a10 gr:*zero* (byte 19. -5.) boxed-right)
  (alu r+2 a14 ignore a14 bw-24 boxed-right)
  (alu l-r nop a14 a7 bw-24)
  (move a13 a12 br-greater-than)
  (branch dpb-extract (alu sign a12 ignore ignore unboxed))
  (alu l+r vma-start-read-no-transport a14 a5 bw-24 unboxed-vma unboxed-md)
  (nop)
  (move a12 md)
dpb-extract
  (alu l-r nop a8 a4 bw-24)
  (alu-field nb-shift-ar-r r1 ignore r1 (byte 32. -32.) unboxed br-greater-than)
  (branch dpb-insert (alu r-1 a14 ignore a14 bw-24 boxed-right))
  (alu l+r vma-start-read-no-transport a8 a0 bw-24 unboxed-vma unboxed-md)
  (nop)
  (move r1 md)
dpb-insert
  (move r14 r2)
  (alu l-r nop r2 a3 bw-24)
  (alu-field field-pass r15 r2 gr:*zero* vinc:%%byte-size boxed-right br-less-or-equal)
  (branch dpb-insert-lo (alu l+r vma a5 a14 unboxed-vma))
  (alu-field field-pass r15 a3 gr:*zero* vinc:%%byte-size boxed-right)
  (move r14 a3)
dpb-insert-lo
  (alu merge-l r15 a11 r15 bw-8 boxed-right)
  (alu load-status-r nop ignore r15 bw-16)
  (alu field-pass md-start-write-no-gc-trap r1 a13 pw-rr unboxed-md)
  (alu l-r a3 a3 r14 bw-24 boxed-right)
  (alu l-r r14 a9 r14 bw-24 boxed-right br-less-or-equal)
  (branch dpb-done (alu neg-r r13 r2 r2 bw-8 br-equal boxed-right))
  (branch dpb-next (alu load-status-r nop ignore r13 bw-16))
  (alu l-r nop r14 a3 bw-24)
  (test br-less-or-equal)
  (branch dpb-insert-hi (alu field-extract-r r1 ignore r1 pw-rr boxed-right))
  (move r14 a3)
dpb-insert-hi
  (alu-field field-pass r15 r14 gr:*zero* vinc:%%byte-size boxed-right)
  (alu l-r a3 a3 r14 bw-24 boxed-right)
  (alu load-status-r nop ignore r15 br-less-or-equal bw-16)
  (branch dpb-final-write (alu field-pass a12 r1 a12 pw-rr boxed-right))
dpb-next
  (alu r+1 a8 ignore a8 bw-24 boxed-right)
  (alu r+1 a14 ignore a14 bw-24 boxed-right)
  (unconditional-branch dpb-loop (alu l+r a10 a9 a10 bw-24 boxed-right))
dpb-final-write
  (move md a12 unboxed-md)
  (alu l+r+c vma-start-write-no-gc-trap a14 a5 bw-24 unboxed-vma carry-1)
dpb-done
  (tail-open-call (shrink-bignum-structure 1) (o0 a5))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; a0 - from argument           a1 - to argument      a5 - byte spec argument/result ptr
;
; a2 - position                a3 - size             a4 - from word size
; a6 - to word size	       a7 - result word size a8 - current-bit number
; a9 - (mod pos 32.)	      a10 - (+ pos size)    a11 - high from word
;a12 - low from word          a13 - temp            a14 - result index

ldb
  (alu neg-r a2 ignore a2 bw-24 boxed-right)					; make position positive
  (movei a7 '32. boxed)						; len = (max (ash (+ 32 size) -5) to-size)
  (alu l+r a7 a3 a7 boxed-right bw-24)
  (alu-field field-pass a7 a7 gr:*zero* (byte 19. -5.) boxed-right)
  (alu l-r nop a6 a7 bw-24)
  (test br-less-or-equal)
  (branch ldb-allocate-result ())
  (move a7 a6)
ldb-allocate-result
  (move o0 a1 ch-open)
  (call (copy-bignum-with-extension 2) a5 (o1 a7))			;copy TO bignum to result area with sign extension
  (movei a14 '1 boxed)
  (alu-field field-pass a13 a2 gr:*zero* (byte 19. -5.) boxed-right)     ;read first from word
  (alu l+r+c vma-start-read-no-transport a13 a0 bw-24 unboxed-vma unboxed-md carry-1)
  (alu l+r a10 a2 a3 bw-24 boxed-right)						;a10 = (+ pos size)
  (alu-field field-pass a9 a2 gr:*zero* (byte 5. 0.) boxed-right)		;a9  = -(mod pos 32.)
  (alu neg-r a9 ignore a9 bw-8 boxed-right)
  (move a8 a2)
  (move a11 md)
  (movei r1 '32 boxed)
ldb-loop
  (move a12 a11)
  (alu-field field-pass a13 a8 gr:*zero* (byte 19. -5.) boxed-right)
  (alu r+2 a13 ignore a13 bw-24 boxed-right)
  (alu l-r nop a13 a4 bw-24)
  (alu-field nb-shift-ar-r a11 ignore a12 (byte 32. -32.) unboxed br-greater-than)
  (branch extract-from ())
  (alu l+r vma-start-read-no-transport a13 a0 bw-24 unboxed-vma unboxed-md)
  (nop)
  (move a11 md)
extract-from
    ;added no-transport to below inst
    ; below must be bw-24 to avoid smashing the data type.
  (alu l+r vma-start-read-no-transport a14 a5 bw-24 unboxed-vma unboxed-md)
  (movei a15 '0 boxed)
  (alu l-r nop a3 r1 bw-24)
  (alu load-status-r nop ignore a9 bw-16 br-greater-or-equal)
  (branch store-it (alu field-extract-lr a13 a11 a12 pw-rr boxed-right))
  (alu-field field-pass a15 a3 gr:*zero* vinc:%%byte-size boxed-right)
store-it
  (alu load-status-r nop ignore a15 bw-16)
  (alu field-pass md-start-write-no-gc-trap a13 md pw-rr unboxed-md)
  (alu l+r a8 a8 r1 bw-24 boxed-right)
  (alu l-r a3 a3 r1 bw-24 boxed-right)
  (alu r+1 a14 ignore a14 bw-24 boxed-right br-greater-than)
  (branch ldb-loop ())
  (tail-open-call (shrink-bignum-structure 1) (o0 a5))
 )

(defafun copy-bignum-with-extension (from to-size)
  (open-call (allocate-bignum 1) a2 (o0 a1))
  (move vma-start-read a0 boxed-vma boxed-md)
  (movei a4 1)                                ;;;counter of current word being copied.
  (move a3 md)                                ;;;length of from bignum in words
loop
  (alu l-r nop a4 a3 bw-24)
  (alu-field nb-shift-ar-r md ignore a5 (byte 32. -32.) unboxed-md br-greater-than)

  (branch write ())         ;;;@@@ This always branches except first time through.  -wkf

  (alu l+r vma-start-read-no-transport a4 a0 unboxed-vma unboxed-md)
  (nop)
  (move a5 md unboxed)
  (move md a5 unboxed-md)   ;;;@@@ Is this needed???  --wkf
write
  (alu l-r nop a4 a1 bw-24)
  (alu l+r vma-start-write-no-gc-trap a4 a2 unboxed-vma br-less-than)
  (branch loop (alu r+1 a4 ignore a4))
  (return a2 boxed-right)
 )