;;;-*- Mode:LISP; Package:NEW-MATH; Base:10; Readtable:CL -*-

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;        Fixnum multiply         ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun multiply-fixnum (x y)
  (hw::load-q-register x)
  (let* ((high-half 

	   (hw:signed-multiply-step y
	    (hw:signed-multiply-step y
	     (hw:signed-multiply-step y
	      (hw:signed-multiply-step y

	       (hw:signed-multiply-step y
		(hw:signed-multiply-step y
		 (hw:signed-multiply-step y
		  (hw:signed-multiply-step y

		   (hw:signed-multiply-step y
		    (hw:signed-multiply-step y
		     (hw:signed-multiply-step y

		      (hw:signed-multiply-first-step y 0)))))))))))))

	 (low-half (hw::read-q-register-boxed))
	 (sign     (hw::ldb low-half vinc:%%bignum-sign-high-word 0)))
      (if (zerop (hw:24+ high-half sign))
	  low-half
	  ;; We overflowed, make a bignum
	(let ((bignum-high (hw:32-sign-extend (hw:32arithmetic-shift-down high-half (byte-size vinc:%%fixnum-non-data))))
	      (bignum-low  (hw:dpb-unboxed high-half vinc:%%fixnum-non-data low-half)))
	  (if (hw:32zerop (hw:32+ bignum-high (hw:ldb bignum-low vinc:%%bignum-sign-high-word gr:*all-zero*)))
	      (make-bignum-32-get-neg-status bignum-low)
	    (make-bignum-64-get-neg-status bignum-high bignum-low))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;         Fixnum divide          ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun divide-fixnum (dividend divisor)
  (when (zerop divisor)
    (li:error "Zero divide" dividend divisor))
  ;;Seems like we need to load-q-reg here.  --wkf
  (let* ((almost-remainder
	   (hw:signed-divide-last1 divisor

	     (hw:signed-divide-step divisor
	      (hw:signed-divide-step divisor
	       (hw:signed-divide-step divisor
	        (hw:signed-divide-step divisor

	         (hw:signed-divide-step divisor
	          (hw:signed-divide-step divisor
	           (hw:signed-divide-step divisor
	            (hw:signed-divide-step divisor

	             (hw:signed-divide-step divisor
		      (hw:signed-divide-step divisor
		       (hw:signed-divide-step divisor
		        (hw:signed-divide-step divisor

		         (hw:signed-divide-step divisor
			  (hw:signed-divide-step divisor
		           (hw:signed-divide-step divisor
		            (hw:signed-divide-step divisor

		             (hw:signed-divide-step divisor
			      (hw:signed-divide-step divisor
			       (hw:signed-divide-step divisor
				(hw:signed-divide-step divisor

				 (hw:signed-divide-step divisor
				  (hw:signed-divide-step divisor
				   (hw:signed-divide-step divisor
						     
				    (hw:signed-divide-first-step divisor
				     (hw:24-sign-fill (hw:load-q-register dividend))
					 ))))))))))))))))))))))))))
	 (cruft    (hw:signed-divide-last2 divisor almost-remainder))
	 (remainder(hw:remainder-correct   divisor almost-remainder))
	 (quotient (hw:quotient-correct (hw:read-q-register-boxed))))
    (if (hw:alu-status-logbitp hw:%%alu-status-overflow)
	(values quotient remainder)
      (values (array:make-bignum-32 (hw:unboxed-constant #x800000)) remainder))));;answer is most-neg-fix divided by -1. --wkf


(defun truncate-fixnum (dividend divisor)
  (divide-fixnum dividend divisor))

(defun floor-fixnum (dividend divisor)
  (multiple-value-bind (quotient remainder)
      (divide-fixnum dividend divisor)
    (if (or (and (minusp quotient)
		 (not (zerop remainder)))
	    (minusp remainder))
	(values (1- quotient) (+ remainder divisor))
	(values quotient remainder))))

(defun ceiling-fixnum (dividend divisor)
  (multiple-value-bind (quotient status remainder)
      (divide-fixnum dividend divisor)
    (if (or (and (plusp quotient)
		 (not (zerop remainder)))
	    (plusp remainder))
	(values (1+ quotient) (- remainder divisor))
      (values quotient remainder))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;   Fixnum add that may overflow ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun add-fixnum (x y)
  (let ((sum24 (hw:24+ x y))
	(status (hw:read-alu-status)))
    (if (hw:32logbitp hw:%%alu-status-overflow status)
	(make-bignum-32-get-neg-status (hw:32+ (hw:32-sign-extend x) (hw:32-sign-extend y)))
    (values sum24 status))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Fixnum subtract that may overflow ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun subtract-fixnum (x y)
  (let ((diff24 (hw:24- x y))
	(status (hw:read-alu-status)))
    (if (hw:32logbitp hw:%%alu-status-overflow status)
	(make-bignum-32-get-neg-status (hw:32- (hw:32-sign-extend x) (hw:32-sign-extend y)))
    (values diff24 status))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;       Fixnum compare           ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun compare-fixnum (x y)
  (values (hw:24- x y) (hw:read-alu-status)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;       Fixnum compare           ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defun test-fixnum (x)
  (values x (hw:read-alu-status)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Fixnum negate that may overflow ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun negate-fixnum (x)
  (if (= x li:most-negative-fixnum)
      (values (array:make-bignum-32 (hw:unboxed-constant #x800000)) hw:$$alu-status-positive))
    (values (- x) (hw:read-alu-status)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;       Fixnum field pass        ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun field-pass-fixnum (x y byte-spec ldb-p)
  (multiple-value-bind (hard size position)
      (resolve-byte-spec byte-spec ldb-p)
    (if hard
	(field-pass-bignum-internal (convert-fixnum-to-bignum x)
				    (convert-fixnum-to-bignum y)
				    byte-spec position size)
      ;; (ALU FIELD-PASS ...)
      ;; does dpb if (byte-position byte-spec) is positive
      ;; does ldb if (byte-position byte-spec) is negative
      ;; pfc 5/25
      (values (if ldb-p
		  (hw:ldb x byte-spec y)
		(hw:dpb x byte-spec y))
	      (hw:read-alu-status)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;     Resolve byte specifier     ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun resolve-byte-spec-internal (bs ldb-p)
  (multiple-value-bind (size position)
    (if (vinc:fixnump bs)
	(let ((fsize (hw:ldb bs vinc:%%byte-size 0)))
	  (values (if (zerop fsize) 32. fsize)
		  (li:byte-position-fixnum bs)))
      (values (cons:car bs) (cons:cdr bs)))
    (when (< size 1)
      (li:error "Illegal size in byte specifier" size))
    (when ldb-p
      (setq position (- position)))
    (values size position)))

(defun resolve-byte-spec (bs ldb-p)
  (multiple-value-bind (size position)
      (resolve-byte-spec-internal bs ldb-p)     ; fixed --pfc 4/25
    (if (or (and (<= position 0)		; big ldb's are hard
		 (<= (- size position) 24.))	; allowed to ldb from sign bit !!
	    (and (not (minusp position))	; big dpb's are hard
		 (<= (+ position size) 23.)))	; not allowed to dpb into sign bit !!
	(values nil size position)		; not hard
      (values t size position))))		; hard

(defun byte-position (bs)  ;;@@@ Do we need definition other than one in arithmetic.lisp?  --wkf
  (if (vinc:fixnump bs)
      (li:byte-position-fixnum bs)
    (cons:cdr bs)))

(defun byte-size (bs)      ;;@@@ Do we need definition other than one in arithmetic.lisp?  --wkf
  (if (vinc:fixnump bs)
      (let ((fsize (hw:ldb bs vinc:%%byte-size 0)))
	(if (zerop fsize) 32. fsize))
    (cons:car bs)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;          Fixnum ash            ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun ash-fixnum (i shift)
  (when (not (vinc:fixnump shift))
    (li:error "Bad shift to ash, must be a fixnum" i shift))
  (let* ((big-i (hw:32-sign-extend i)))
    (if (minusp shift)
	(let ((x-shift (if (< shift -24.) -32. shift)))
	  (values
	    (vinc:make-fixnum (hw:32arithmetic-shift-up big-i x-shift)) ;;negative shift is down.
	    (hw:read-alu-status)))
      (let* ((raw-i       (if (minusp i) (hw:ldb-not i vinc:%%fixnum-field 0) i))
	     (unused-bits (vinc:make-fixnum (hw:24-prioritize raw-i))))
	(if (>= shift unused-bits)
	    (ash-bignum (convert-fixnum-to-bignum i) shift)
	  (values
	    (vinc:make-fixnum (hw:32logical-shift-up big-i shift))
	    (hw:read-alu-status)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;        Fixnum logand           ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun logand-fixnum (x y)
  (logand x y))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;        Fixnum logior           ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun logior-fixnum (x y)
  (logior x y))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;        Fixnum logxor           ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun logxor-fixnum (x y)
  (logxor x y))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;        Fixnum logxnor          ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun logxnor-fixnum (x y)
  (logeqv x y))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;        Fixnum lognot           ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun lognot-fixnum (x)
  (lognot x))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;    For slightly large fixnums  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;**********************************
;;;*                                *
;;;* ALLOCATING STORAGE FOR BIGNUMS *
;;;*                                *
;;;**********************************

(defun allocate-bignum (size)
  (unless (and (plusp size) (< size #x40000))
    (li:error "Bad size to allocate-bignum" size))
  (cons::allocate-structure
    1 size $$dtp-bignum
    (cons:make-header $$dtp-unboxed-header size)))

;;;**********************************
;;;*                                *
;;;*   SHRINK  BIGNUM  STRUCTURE    *
;;;*                                *
;;;**********************************

(defun shrink-bignum-structure (bignum-ptr)
  (let* ((size      (hw:ldb (array:%vm-read bignum-ptr 0) vinc::%%pointer gr:*all-zero*))
	 (high-word (array:%vm-read32 bignum-ptr size))
	 (new-size  size))
    (labels ((reduce-bignum (new-size new-high-word)
		(setq new-size (hw:32-1- new-size))
		(if (hw:32zerop new-size)
		    (if (or (hw:field= new-high-word gr:*all-zero*                    vinc:%%fixnum-sign-and-datatype)
			    (hw:field= new-high-word (hw:unboxed-constant #xFF800000) vinc:%%fixnum-sign-and-datatype))
			(values (hw:ldb-boxed new-high-word vinc::%%fixnum-field 0)
				(hw:read-alu-status))
		      (progn
			(array:%vm-write32 bignum-ptr 2 (cons:make-header $$dtp-unboxed-header (- size 2)))
			;;+++ Above is ready to be garbage collected.  Should we have a special datatype for this?  --wkf
			(array:%vm-write bignum-ptr (cons:make-header $$dtp-unboxed-header 1))
			(values bignum-ptr
				(hw:dpb (hw:ldb new-high-word vinc:%%bignum-sign-high-word 0)
					hw:%%alu-status-negative 0))))
		  (let ((next-word (array:%vm-read32 bignum-ptr new-size)))
		    (if (hw:32zerop
			  (hw:32+ new-high-word (hw:ldb next-word vinc:%%bignum-sign-high-word gr:*all-zero*)))
			(reduce-bignum new-size next-word)
		      (values bignum-ptr
			      (hw:dpb (hw:ldb new-high-word vinc:%%bignum-sign-high-word 0)
				      hw:%%alu-status-negative 0)))))))
      (reduce-bignum size high-word))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;  Allocate Bignums and get their status, negative or positive, don't check for zero. ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun make-bignum-32-get-neg-status (bignum-word) "Does not detect zero status."
  (let ((ptr (cons:allocate-structure
	       1 1 $$dtp-bignum
	       (cons:make-header $$dtp-unboxed-header 1))))
    (%vm-write32 ptr 1 bignum-word)
    (values ptr (hw:dpb (hw:ldb bignum-word vinc:%%bignum-sign-high-word 0)
			hw:%%alu-status-negative 0))))

(defun make-bignum-64-get-neg-status (bignum-word-high bignum-word-low) "Does not detect zero status."
  (let ((ptr (cons:allocate-structure
	       1 2 $$dtp-bignum
	       (cons:make-header $$dtp-unboxed-header 2))))
    (%vm-write32 ptr 1 bignum-word-low)
    (%vm-write32 ptr 2 bignum-word-high)
    (values ptr (hw:dpb (hw:ldb bignum-word-high vinc:%%bignum-sign-high-word 0)
			hw:%%alu-status-negative 0))))