;;; Arithmetic bugout routines for the Perq.
;;;
;;; Written by Steven Handerson, based on Milnes code.
;;; Non-numeric bugouts written by Skef Wholey.

;;;
;;; Bugout takes the function name,
;;;  a switch (escapep) telling whether to insert an escape-return,
;;;  a default function call (in terms of x and y),
;;;  whether the function is commutative (a convenience),
;;;  what types the microcode handles (chosen from (fixnum
;;;   short-float long-float bignum ratio)),
;;;  a list of exception pairs and code to handle them (in terms
;;;   of x and y),
;;;  and an optional body which gets evaluated (and should include
;;;   the symbol %typecase-form).
;;;
;;; The macro generates a function containing two layers of typecase,
;;;  using the floating-point contageon rules.  It barfs if it discovers
;;;  an uncovered case.
;;;

(eval-when (compile load eval)
(proclaim '(special %typecase-form))
)

(eval-when (compile)
(defmacro bugout (bugout-name escapep default-fn commutativep
			      defined-for exceptions &optional body)
  (let* ((%typecase-form
	  `(typecase x
	     ,@(mapcar
		#'(lambda (xtype)
		    `(,xtype
		      (typecase y
			,@(mapcar
			   #'(lambda (ytype)
			       `(,ytype
				 ,(if (exception-p xtype ytype defined-for)
				      (find-exception xtype ytype default-fn
						      commutativep exceptions)
				      default-fn)))
			   '(fixnum short-float long-float bignum ratio)))))
		'(fixnum short-float long-float bignum ratio)))))
    `(defun ,bugout-name (x y)
       (unless (numberp x)
	 (error "Object not number - ~A" x))
       (unless (numberp y)
	 (error "Object not number - ~A" y))
       ,(if body (eval body) %typecase-form))))

	    

(defun exception-p (xtype ytype defined-for)
  (not (and (eq xtype ytype)
	    (member xtype defined-for))))

(defun find-exception (xtype ytype default-fn commutativep exceptions)
  (cond	((eq xtype 'long-float)
	 (subst '(%sp-l-float y) 'y default-fn))
	((eq ytype 'long-float)
	 (subst '(%sp-l-float x) 'x default-fn))
	((eq xtype 'short-float)
	 (subst '(%sp-s-float y) 'y default-fn))
	((eq ytype 'short-float)
	 (subst '(%sp-s-float x) 'x default-fn))
	(t (let ((fn (assoc (list xtype ytype) exceptions :test #'equal)))
	     (cond ((and fn (cadr fn)) (cadr fn))
		   (fn default-fn)
		   ((not commutativep) (uncovered-case-error))
		   ((prog1 nil
			   (setq fn (assoc (list ytype xtype) exceptions
					   :test #'equal))))
		   ((and fn (cadr fn))
		    (switch-subst 'x 'y (cadr fn)))
		   (fn default-fn)
		   (t (uncovered-case-error)))))))

(defun uncovered-case-error ()
  (error "You lose."))

(defun switch-subst (a b list)
  (let ((sym (gensym)))
    (subst a sym (subst b a (subst sym b list)))))

)


;;;
;;;   Arithmetic bugouts.
;;;

(defun %sp-addone-escape (x) (%sp-add-escape x 1))
(defun %sp-subtractone-escape (x) (%sp-subtract-escape x 1))

;;; Bugout for +.  

(bugout %sp-add-escape T (+ x y) T (short-float long-float)
	(((fixnum fixnum) (%sp-fixnum+ x y))		;Might overflow.
	 ((bignum bignum) (%sp-bignum+ x y))
	 ((ratio ratio) (%sp-ratio+ x y))
	 ((fixnum bignum) (%sp-bignum-fixnum+ y x))
	 ((fixnum ratio) (%sp-ratio-integer+ y x))
	 ((bignum ratio) (%sp-ratio-integer+ y x))))

(bugout %sp-subtract-escape T (- x y) nil (short-float long-float)
	(((fixnum fixnum) (%sp-fixnum- x y))
	 ((fixnum bignum) (%sp-fixnum-bignum- x y))
	 ((fixnum ratio) (- (%sp-ratio-integer- y x)))
	 ((bignum fixnum) (+ x (- y)))
	 ((bignum bignum) (%sp-bignum- x y))
	 ((bignum ratio) (- (%sp-ratio-integer- y x)))
	 ((ratio fixnum) (%sp-ratio-integer- x y))
	 ((ratio bignum) (%sp-ratio-integer- x y))
	 ((ratio ratio) (%sp-ratio- x y))))

(bugout %sp-multiply-escape T (* x y) T (short-float long-float)
	(((fixnum fixnum) (%sp-fixnum* x y))		;Might overflow.
	 ((fixnum bignum) (%sp-bignum-fixnum* y x))
	 ((fixnum ratio) (%sp-ratio-integer* y x))
	 ((bignum bignum) (%sp-bignum* x y))
	 ((bignum ratio) (%sp-ratio-integer* y x))
	 ((ratio ratio) (%sp-ratio* x y))))

(bugout %sp-divide-escape T (/ x y) nil (short-float long-float)
	(((fixnum fixnum) (%sp-fixnum/ x y))
	 ((fixnum bignum) (%sp-integer/ x y))
	 ((fixnum ratio) (* (%sp-ratio-inverse y) x))
	 ((bignum fixnum) (%sp-integer/ x y))
	 ((bignum bignum) (%sp-integer/ x y))
	 ((bignum ratio) (* (%sp-ratio-inverse y) x))
	 ((ratio fixnum) (%sp-ratio-integer/ x y))
	 ((ratio bignum) (%sp-ratio-integer/ x y))
	 ((ratio ratio) (%sp-ratio/ x y)))
	`(if (zerop y)
	     (error "/, division by zero")
	     ,%typecase-form))

;;;
;;; Some random miscops.
;;;

(defun %sp-abs-escape (x)
  (unless (numberp x)
    (error "Object not number - ~A" x))
  (if (minusp x) (- x) x))

;;;  %sp-negate returns the negation of any integer or floating
;;; point number.
;;;

(defun %sp-negate-escape (x)
  (typecase x
    ;; 1+ not working on the perq.
    (fixnum (+ most-positive-fixnum 1))
    ;; if i get a fixnum, it must be from the bugout because the fixnum
    ;; overflows to a bignum and the only one that does this is 
    ;; most-negative-fixnum.
    (short-float  (- x))
    (bignum  (bignum-negate x))
    (long-float (- x))
    (ratio (%sp-ratio-negate x))
    (otherwise (error "Object not number - ~A" x))))


;;;
;;; Sfloat and Lfloat.
;;;


;;;  %sp-s-float converts any number, that can be represented
;;; as an S-flonum, into an s-flonum.

;(declare (function %sp-sfloat-escape (number) short-float))
(defun %sp-sfloat-escape (X)
  "%sp-sfloat-escape is an internal numeric conversion function.
%sp-s-float returns a short floating-point representation of X,
truncating towards zero."
  (typecase x
    (bignum
     (let ((diff (- 26 (integer-length x))))		;To be safe.
       (scale-float (%sp-s-float (ash x diff)) (- diff))))
    (ratio (/ (%sp-s-float (numerator x))
	      (%sp-s-float (denominator x))))
    (otherwise
     (Error "Object not number - ~A" x))))




;;;  %sp-lfloat-escape converts any number into a l-flonum.
;;; VM:()

(defun %sp-lfloat-escape (X)
  "%sp-lfloat-escape is an internal numeric conversion routine."
  (typecase x
    (bignum (%sp-lfloat-bignum x))
    (ratio (let ((num (numerator x))			;Here 'cause of bug.
		 (den (denominator x)))
	     (declare (special num den))
	     (/ (%sp-l-float num) (%sp-l-float den))))
    (otherwise (error "Object not number - ~A" x))))

;;; Gets the b bit of integer x.
(eval-when (compile)
(defmacro get-bit (x b)
  `(if (minusp ,b) 0
       (cond ((fixnump ,x) (%sp-logldb 1 ,b ,x))
	     (t (%sp-logldb 1 (rem ,b 8)
			    (%primitive typed-vref 3 ,x (truncate ,b 8)))))))
)

(defun bignum-to-lfloat (big)
  (let ((float (%sp-l-float 1)))
    (dotimes (i 4) (%primitive long-float-set float i
			       (ldb (byte 16 (* 16 i)) big)))
    float))
(defun lfloat-to-bignum (float)
  (let ((bignum (ash 1 62)))
    (dotimes (i 4) (%primitive typed-vset 4 bignum i
			       (%primitive long-float-ref float i)))
    (integerize bignum (%sp-get-vector-length bignum))))

;;; lfloat for a bignum. *** Needs to be in ucode eventually
;;; (so we can get all the bits).
;;; Tested.
(defun %sp-lfloat-bignum (n)
  (cond ((minusp n) (- (%sp-lfloat-bignum (- n))))
	(t (let* ((len (integer-length n))
		  (diff (- 53 len))
		  (guard-bit (get-bit n (- -1 diff)))
		  (f (+ guard-bit (ash n diff)))
		  (carryp (if (= (integer-length f) 53) nil t))
		  (f (if carryp (ash f -1) f))
		  (e (+ len (if carryp 1023 1022))))
	     (cond ((> e 2046)
		    (error "L-float : base 2 exponent out of range - ~A" e))
		   (t (bignum-to-lfloat (dpb e (byte 11 52) f))))))))



;;;
;;;			Predicate bugouts
;;;

;;; Comparison complement.
(defmacro comp-comp (r)
  `(cond ((eq ,r '=) '=)
	 ((eq ,r '>) '<)
	 (t '>)))


;(declare (function %sp-equal-escape (number number) t))
(defun %sp-equal-escape (x y)
  "%sp-equal-escape is the two-argument = bugout."
 (declare (type number x y))
 (eq '= (compare-numbers x y)))

;(declare (function %sp-greaterthan-escape (number number) t))
(defun %sp-greaterthan-escape (x y)
  "%sp-greaterthan-escape is the two argument > bugout."
  (declare (type number x y))
  (eq '> (compare-numbers x y)))

;(declare (function %sp-lessthan-escape (number number) t))
(defun %sp-lessthan-escape (x y)
  "%sp-lessthan-escape is the two argument numeric < bugout."
 (declare (type number x y))
 (eq '< (compare-numbers x y)))


;;;
;;;	Compare-numbers dispatches the comparison to the
;;; argument specific comparison functions.
;;;
;;; A float and an integer are equal if they are equal to the precision
;;; of the float.  This is still better than just floating yourself, since
;;; we take floatability into account.

(defmacro microcode-compare (x y)
  `(cond ((< ,x ,y) '<)
	 ((> ,x ,y) '>)
	 (t '=)))


(bugout compare-numbers nil (microcode-compare x y) nil
	(fixnum short-float long-float)
	(((fixnum bignum) (comp-comp (bignum-fixnum-compare y)))
	 ((fixnum ratio) (comp-comp (ratio-integer-compare y x)))
	 ((bignum fixnum) (bignum-fixnum-compare x))
	 ((bignum bignum) (bignum-compare x y))
	 ((bignum ratio) (comp-comp (ratio-integer-compare y x)))
	 ((ratio fixnum) (ratio-integer-compare x y))
	 ((ratio bignum) (ratio-integer-compare x y))
	 ((ratio ratio) (ratio-compare x y))))



;;;
;;; Truncate escape.
;;;

(defun %sp-trunc-escape-default (x y)
  "This is the default escape function for truncate of two args."
  (let ((q (truncate (/ x y))))
    (values q (- x (* q y)))))

(bugout %sp-trunc-escape nil (%sp-trunc-escape-default x y) nil
	(short-float long-float ratio)
	(((fixnum fixnum) (integer-divide x y))
	 ((fixnum bignum) (integer-divide x y))
	 ((fixnum ratio) (%sp-trunc-escape-default x y))
	 ((bignum fixnum) (integer-divide x y))
	 ((bignum bignum) (integer-divide x y))
	 ((bignum ratio) (%sp-trunc-escape-default x y))
	 ((ratio fixnum) (%sp-trunc-escape-default x y))
	 ((ratio bignum) (%sp-trunc-escape-default x y)))
	`(cond ((= y 1)
		(typecase x
		  (ratio (ratio-trunc x))
		  (fixnum (values x 0))
		  (bignum (values x 0))
		  (long-float (long-float-trunc x))
		  (short-float (big-short-float-trunc x))))
	       (t ,%typecase-form)))



(defun long-float-trunc (x)
  (cond ((zerop x) (values 0 (%sp-l-float 0)))
	(t (multiple-value-bind (f e s) (decode-float x)
	     (let ((bignum (ash 1 52)))
	       (dotimes (i 3)
		 (%primitive typed-vset 4 bignum i
			     (%primitive long-float-ref f i)))
	       (setq bignum
		     (dpb (%primitive long-float-ref f 3)
			  (byte 4 48) bignum))
	       (setq e (- e 53))
	       (let ((res1 (ash bignum e))
		     (res2 (if (plusp e) (%sp-l-float 0)
			       (scale-float
				(%sp-l-float (ldb (byte (- e) 0) bignum)) e))))
		 (if (minusp s) (values (- res1) (- res2))
		     (values res1 res2))))))))

(defun big-short-float-trunc (X)
  "Returns the bignum result of truncating the short float x."
  (multiple-value-bind (f e s) (decode-float X)
    (let ((n (ash (truncate (scale-float f 20))
		  (- e 20))))
      (values (if (minusp s) (- n) n) 0.0s0))))

;;; Other bugout routines:

(defun %sp-assoc-escape (x l)
  (do ((l l (cdr l)))
      ((endp l) nil)
    (if (and (consp (car l))
	     (eql x (caar l)))
	(return (car l)))))

(defun %sp-member-escape (x l)
  (do ((l l (cdr l)))
      ((endp l) nil)
    (if (eql x (car l))
	(return l))))

;;; Byte-BLT passes this guy hard addresses to evil things like the middle of
;;; strings.  The Source and Destination are these pointers.  Byte-Count is a
;;; fixnum that is the number of bytes to move.  Start bit is a fixnum that
;;; contains 1 in bit 0 if the source starts on an odd byte and a 1 in bit
;;; 16 if the destination starts on an odd byte.

(defun %sp-byte-blt-escape (source destination byte-count start-bits)
  (declare (fixnum byte-count))
  (let ((source-index (logand start-bits 1))
	(destination-index (ash start-bits -16)))
    (declare (fixnum source-index destination-index))
    (cond ((< (%sp-make-fixnum source)
	      (%sp-make-fixnum destination))
	   ;; Backwards if all that stuff is true.
	   (setq destination-index (+ destination-index byte-count))
	   (setq source-index (+ source-index byte-count))
	   (do ()
	       ((= byte-count 0) :bugout)
	     (decf source-index)
	     (decf destination-index)
	     (%primitive 8bit-system-set destination destination-index
			 (%primitive 8bit-system-ref source source-index))
	     (decf byte-count)))
	  (t
	   ;; Forwards elsewise.
	   (do ()
	       ((= byte-count 0) :bugout)
	     (%primitive 8bit-system-set destination destination-index
			 (%primitive 8bit-system-ref source source-index))
	     (decf byte-count)
	     (incf source-index)
	     (incf destination-index))))))