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

;***************************************************************************
;  Constants used for datatype trap emulation
;***************************************************************************

(defconstant generic-lognot-code	0.)
(defconstant generic-logand-code        1.)
(defconstant generic-logior-code        2.)
(defconstant generic-logxor-code        3.)
(defconstant generic-logxnor-code       4.)
(defconstant generic-field-pass-code    5.) ;ILLEGAL!!!!!
(defconstant generic-negate-code        6.)
(defconstant generic-add-code           7.)
(defconstant generic-sub-code           8.)
(defconstant generic-subr-code 		9.)
(defconstant generic-add1-code         10.)
(defconstant generic-add2-code         11.)
(defconstant generic-add4-code         12.)
(defconstant generic-sub1-code         13.)
(defconstant generic-sub2-code         14.)
(defconstant generic-sub4-code         15.)
(defconstant generic-test-code         16.)
(defconstant generic-compare-code      17.)
(defconstant generic-comparer-code     18.)
(defconstant generic-ash-up-code       19.)
(defconstant generic-ash-down-code     20.)
(defconstant generic-equal-code	       21.)

(defconstant nonary-op      0)
(defconstant unary-left-op  1)
(defconstant unary-right-op 2)
(defconstant binary-op      3)

(defconstant generic-broken-code       #.(zl:ash 0 5))
(defconstant generic-unary-left-code   #.(zl:ash 1 5))
(defconstant generic-unary-right-code  #.(zl:ash 2 5))
(defconstant generic-binary-code       #.(zl:ash 3 5))

(defconstant generic-logical-code      #.(zl:ash 0 7))
(defconstant generic-arithmetic-code   #.(zl:ash 1 7))
 
(defun trap:dt-and-ovf-trap-handler-2 (trap-pc left right status)
;  (li:error "Entered dt-and-ovf-trap-handler-2")
  (let* ((result nil)
	 (rstat  nil)
	 (pc-loc (pc->unboxed-locative trap-pc))
 	 (instl  (array:%vm-read32 pc-loc 0))
 	 (insth  (array:%vm-read32 pc-loc 1)))
    (dispatch hw:%%i-dtp-check-high insth  ;; dispatch on datatype check code
       (vinc:$$dtc-none
	 (li:tail-error "ARRRGH - datatype trap on code NO-DATATYPE-CHECKING" trap-pc))
       ((vinc:$$dtc-both-fixnum vinc:$$dtc-both-fixnum-with-overflow)
	(when (or (zerop (k2:boxed-bit left)) (zerop (k2:boxed-bit right)))
	  (li:tail-error "Fixnum datatype trap on unboxed data!" left right))
	(let ((op-info (decode-alu-op insth instl)))
	  (multiple-value-setq (result rstat)
	    (dispatch (byte 2. 5.) op-info
		      (nonary-op
			(li:tail-error "Datatype error on operation with no operands" trap-pc))

		      ;; LEFT and RIGHT were backwards !!! how did this ever work ???  --pfc
		      (unary-left-op
			(handle-unary-op op-info left))
		      (unary-right-op
			(handle-unary-op op-info right))

		      (binary-op
			(handle-binary-op insth instl op-info left right status))))))
       (vinc:$$dtc-right-list
	 (li:tail-error "This isn't a list" right)
 ;  --we assume car and cdr are operating right source.
	 (case (hw:ldb insth #.(byte (byte-size hw:%%i-destination)
			       (- (byte-position hw:%%i-destination) 32.))
		 0)
	   (hw:$$i-fd-vma-start-read		;CAR
	    (case (hw:ldb right vinc::%%data-type 0)
	      (vinc:$$dtp-symbol )
	      (vinc:$$dtp-locative right)
	      (vinc:$$dtp-instance )
	      (t
	       (li:tail-error "Bad data type for CAR" right trap-pc)))
	    )
	   (hw:$$i-fd-vma-start-read-cdr	;CDR
	;just returnning from here will not win because its still going to do -CDR operation.
	    (case (hw:ldb right vinc::%%data-type 0)
	      (vinc:$$dtp-symbol )
	      (vinc:$$dtp-locative )
	      (vinc:$$dtp-instance )
	      (t
	       (li:tail-error "Bad data type for CDR" right trap-pc)))
	    )
 ;  --for now, we assume RPLACA and RPLACD of funny data types will result in a simple
 ;    write of a memory location (albeit a different one than the case for a list).
 ;    someday RPLACA and RPLACD on instances will have to dig out the second argument from
 ;    a1 of the previous frame, etc.
	   (hw:$$i-fd-vma-start-read-will-write	;RPLACA
	    )
	   (hw:$$i-fd-vma-start-read-cdr-will-write	;RPLACA
	    )
	   (t
	    (li:tail-error "Unknown operation on non-list!" right trap-pc))))
       (vinc:$$dtc-right-array-and-left-structure
	 (if (arrayp right)
	     (li:tail-error "~s is not a structure! PC: ~x" left trap-pc)
	   (li:tail-error "~s is not an array! PC: ~x" right trap-pc)))
       (vinc:$$dtc-both-character
	 (li:tail-error "~s is not a character! PC: ~x" right trap-pc))
       (vinc:$$dtc-hairy-number
	 (li:tail-error "Can't handle hairy EQL traps yet!" trap-pc left right))
       (t
	 (trap::illop "Illegal datatype check code specified!")))
  (values result (hw:dpb (hw:ldb rstat (byte 4. 16.) 0) (byte 4. 16.) status))))


(defun pc->unboxed-locative (pc)
    (trap::without-traps
      #'(lambda () (hw:dpb-boxed $$dtp-unboxed-locative vinc::%%data-type
				 (hw:32logior
				   (hw:unboxed-constant #x2000000)
				   (hw:32+ pc pc))))))


  
(defun handle-unary-op (op-info operand)
  (prims:dispatch (byte 5. 0.) op-info
		  (generic-lognot-code (lognot-generic operand))
		  (generic-negate-code (negate-generic operand))
		  (generic-add1-code   (add-generic operand 1))
		  (generic-add2-code   (add-generic operand 2))
		  (generic-add4-code   (add-generic operand 4))
		  (generic-sub1-code   (add-generic operand -1))
		  (generic-sub2-code   (add-generic operand -2))
		  (generic-sub4-code   (add-generic operand -4))
		  (generic-test-code   (test-generic operand))
		  (generic-ash-up-code (ash-generic operand 1))
		  (generic-ash-down-code (ash-generic operand -1))
		  (t (li:tail-error "Illegal unary op dispatch" op-info))
		  ))

(defun handle-binary-op (insth instl op-info left right status)
  (prims:dispatch (byte 5. 0) op-info
     (generic-logand-code (logand-generic left right))
     (generic-logior-code (logior-generic  left right))
     (generic-logxor-code (logxor-generic left right))
     (generic-logxnor-code (logxnor-generic left right))
;     (generic-field-pass-code
;       (let ((byte-spec
;	       (hw:dpb
;		 (if (hw:32logbitp 0 insth)
;		     (hw:ldb status (byte 5. 8.) 0)
;		   (hw:ldb instl (byte 5. 0.) 0))
;		 (byte 5. 8.)
;		 (if (hw:32logbitp 1 insth)
;		     (hw:ldb status (byte 8. 0.) 0)
;		   (hw:ldb instl (byte 8. 0.) 0)))))
;	 (field-pass-generic left right byte-spec)))
     (generic-add-code (add-generic left right))
     (generic-sub-code (subtract-generic left right))
     (generic-subr-code (subtract-generic right left))
     (generic-equal-code (equal-generic left right))
     (generic-compare-code
       (compare-generic left right))
     (generic-comparer-code
       (compare-generic right left))
     (t (li:tail-error "Illegal binary op dispatch op-info"))
 ))

(defun decode-alu-op (insth instl)
  (let ((opcode	(cond
		  ((zerop (hw:ldb insth (byte 2. 26.) 0)) ; normal
		   (hw:ldb instl hw:%%i-alu-op 0))
		  ((= 1. (hw:ldb insth (byte 2. 26.) 0))  ; I16, I24
		   (hw:ldb insth hw:%%i-alui-op 0))
		  ((= 1. (hw:ldb insth (byte 2. 27.) 0))  ; I32, call, jump
		   hw:$$i-alu-op-zero-ext-right)
		  (t
		   hw:$$i-alu-reserved-1e))))    ; floating point
    (prims:dispatch (byte 7. 0.) opcode
       (hw:$$i-alu-op-not-left
	 (logior generic-unary-left-code generic-logical-code generic-lognot-code))
       (hw:$$i-alu-op-not-right
	 (logior generic-unary-right-code generic-logical-code generic-lognot-code))
       (hw:$$i-alu-op-and
	 (logior generic-binary-code generic-logical-code generic-logand-code))
       (hw:$$i-alu-op-or
	 (logior generic-binary-code generic-logical-code generic-logior-code))
       (hw:$$i-alu-op-xor
	 (if (= hw:$$i-fd-nop (hw:ldb insth (byte 7. 9.) 0))
	     (logior generic-binary-code generic-arithmetic-code generic-equal-code)
	   (logior generic-binary-code generic-logical-code generic-logxor-code)))
       (hw:$$i-alu-op-xnor
	 (logior generic-binary-code generic-logical-code generic-logxnor-code))
;       (hw:$$i-alu-op-pass-f-left
;	 (logior generic-binary-code generic-logical-code generic-field-pass-code))
       (hw:$$i-alu-op-add
	 (logior generic-binary-code generic-arithmetic-code generic-add-code))
       (hw:$$i-alu-op-sub
	 (if (= hw:$$i-fd-nop (hw:ldb insth (byte 7. 9.) 0))
	     (logior generic-binary-code generic-arithmetic-code generic-compare-code)
	   (logior generic-binary-code generic-arithmetic-code generic-sub-code)))
       (hw:$$i-alu-op-subr
	 (if (= hw:$$i-fd-nop (hw:ldb insth (byte 7. 9.) 0))
	     (logior generic-binary-code generic-arithmetic-code generic-comparer-code)
	   (logior generic-binary-code generic-arithmetic-code generic-subr-code)))
       (hw:$$i-alu-op-incr1-left
	 (logior generic-unary-left-code generic-arithmetic-code generic-add1-code))
       (hw:$$i-alu-op-incr2-left
	 (logior generic-unary-left-code generic-arithmetic-code generic-add2-code))
       (hw:$$i-alu-op-incr4-left
	 (logior generic-unary-left-code generic-arithmetic-code generic-add4-code))
       (hw:$$i-alu-op-incr1-right
	 (logior generic-unary-right-code generic-arithmetic-code generic-add1-code))
       (hw:$$i-alu-op-incr2-right
	 (logior generic-unary-right-code generic-arithmetic-code generic-add2-code))
       (hw:$$i-alu-op-incr4-right
	 (logior generic-unary-right-code generic-arithmetic-code generic-add4-code))
       (hw:$$i-alu-op-decr1-left
	 (logior generic-unary-left-code generic-arithmetic-code generic-sub1-code))
       (hw:$$i-alu-op-decr2-left
	 (logior generic-unary-left-code generic-arithmetic-code generic-sub2-code))
       (hw:$$i-alu-op-decr4-left
	 (logior generic-unary-left-code generic-arithmetic-code generic-sub4-code))
       (hw:$$i-alu-op-decr1-right
	 (logior generic-unary-right-code generic-arithmetic-code generic-sub1-code))
       (hw:$$i-alu-op-decr2-right
	 (logior generic-unary-right-code generic-arithmetic-code generic-sub2-code))
       (hw:$$i-alu-op-decr4-right
	 (logior generic-unary-right-code generic-arithmetic-code generic-sub4-code))
       (hw:$$i-alu-op-zero-ext-left
	 (logior generic-unary-left-code generic-arithmetic-code generic-test-code))
       (hw:$$i-alu-op-zero-ext-right
	 (logior generic-unary-right-code generic-arithmetic-code generic-test-code))
       (hw:$$i-alu-op-dnl-ar-left
	 (logior generic-unary-left-code generic-logical-code generic-ash-down-code))
       (hw:$$i-alu-op-dnl-ar-right
	 (logior generic-unary-right-code generic-logical-code generic-ash-down-code))
       (hw:$$i-alu-op-upl-0f-left
	 (logior generic-unary-left-code generic-logical-code generic-ash-up-code))
       (hw:$$i-alu-op-upl-0f-right
	 (logior generic-unary-right-code generic-logical-code generic-ash-up-code))
       (t
	 (li:tail-error "Datatype and overflow trapping not handled on this opcode" opcode))
 )))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; type coercion
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun generic-math-type-coercer (x y)
  (if (and (hw:32logbitp 0 (k2:boxed-bit x)) (hw:32logbitp 0 (k2:boxed-bit y)))
      (dispatch vinc::%%data-type x
		($$dtp-fixnum
		  (dispatch vinc::%%data-type y
			    ($$dtp-fixnum		nil)
			    ($$dtp-bignum 		(setq x (convert-fixnum-to-bignum x)))
			    ($$dtp-rational 	(setq x (convert-fixnum-to-rational x)))
			    ($$dtp-short-float	(setq x (convert-fixnum-to-short x)))
			    ($$dtp-single-float	(setq x (convert-fixnum-to-single x)))
			    ($$dtp-double-float	(setq x (convert-fixnum-to-double x)))
			    ($$dtp-complex		(setq x (convert-fixnum-to-complex x)))
			    (t (generic-math-coercion-fail y))))
		($$dtp-bignum
		  (dispatch vinc::%%data-type y
			    ($$dtp-fixnum		(setq y (convert-fixnum-to-bignum y)))
			    ($$dtp-bignum 		nil)
			    ($$dtp-rational 	(setq x (convert-bignum-to-rational x)))
			    ($$dtp-short-float	(setq x (convert-bignum-to-short x)))
			    ($$dtp-single-float	(setq x (convert-bignum-to-single x)))
			    ($$dtp-double-float	(setq x (convert-bignum-to-double x)))
			    ($$dtp-complex		(setq x (convert-bignum-to-complex x)))
			    (t (generic-math-coercion-fail y))))
		($$dtp-rational
		  (dispatch vinc::%%data-type y
			    ($$dtp-fixnum		(setq y (convert-fixnum-to-rational y)))
			    ($$dtp-bignum 		(setq y (convert-bignum-to-rational y)))
			    ($$dtp-rational 	nil)
			    ($$dtp-short-float	(setq x (convert-rational-to-short x)))
			    ($$dtp-single-float	(setq x (convert-rational-to-single x)))
			    ($$dtp-double-float	(setq x (convert-rational-to-double x)))
			    ($$dtp-complex		(setq x (convert-rational-to-complex x)))
			    (t (generic-math-coercion-fail y))))
		($$dtp-short-float
		  (dispatch vinc::%%data-type y
			    ($$dtp-fixnum		(setq y (convert-fixnum-to-short y)))
			    ($$dtp-bignum 		(setq y (convert-bignum-to-short y)))
			    ($$dtp-rational 	(setq y (convert-rational-to-short y)))
			    ($$dtp-short-float	nil)
			    ($$dtp-single-float	(setq x (convert-short-to-single x)))
			    ($$dtp-double-float	(setq x (convert-short-to-double x)))
			    ($$dtp-complex		(setq x (convert-short-to-complex x)))
			    (t (generic-math-coercion-fail y))))
		($$dtp-single-float
		  (dispatch vinc::%%data-type y
			    ($$dtp-fixnum		(setq y (convert-fixnum-to-single y)))
			    ($$dtp-bignum 		(setq y (convert-bignum-to-single y)))
			    ($$dtp-rational 	(setq y (convert-rational-to-single y)))
			    ($$dtp-short-float	(setq y (convert-short-to-single y)))
			    ($$dtp-single-float	nil)
			    ($$dtp-double-float	(setq x (convert-single-to-double x)))
			    ($$dtp-complex		(setq x (convert-single-to-complex x)))
			    (t (generic-math-coercion-fail y))))
		($$dtp-double-float
		  (dispatch vinc::%%data-type y
			    ($$dtp-fixnum		(setq y (convert-fixnum-to-double y)))
			    ($$dtp-bignum 		(setq y (convert-bignum-to-double y)))
			    ($$dtp-rational 	(setq y (convert-rational-to-double y)))
			    ($$dtp-short-float	(setq y (convert-short-to-double y)))
			    ($$dtp-single-float	(setq y (convert-single-to-double y)))
			    ($$dtp-double-float	nil)
			    ($$dtp-complex		(setq x (convert-double-to-complex x)))
			    (t (generic-math-coercion-fail y))))
		($$dtp-complex
		  (dispatch vinc::%%data-type y
			    ($$dtp-fixnum		(setq y (convert-fixnum-to-complex y)))
			    ($$dtp-bignum 		(setq y (convert-bignum-to-complex y)))
			    ($$dtp-rational 	(setq y (convert-rational-to-complex y)))
			    ($$dtp-short-float	(setq y (convert-short-to-complex y)))
			    ($$dtp-single-float	(setq y (convert-single-to-complex y)))
			    ($$dtp-double-float	(setq y (convert-double-to-complex y)))
			    ($$dtp-complex		nil)
			    (t (generic-math-coercion-fail y))))
		(t (generic-math-coercion-fail x)))
    (li:tail-error "Can't math coerce unboxed data" x y))
  (values x y))


(defun generic-math-coercion-fail (x)
  (li:tail-error "Generic math coercion failure" x))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Generic add
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun add-generic (x y)
  (multiple-value-setq (x y) (generic-math-type-coercer x y))
  (prims:dispatch vinc::%%data-type x
     ($$dtp-fixnum          (add-fixnum       x y))
     ($$dtp-bignum          (add-bignum       x y))
     ($$dtp-short-float     (add-short        x y))
     ($$dtp-single-float    (add-single       x y))
     ($$dtp-double-float    (add-double       x y))
     ($$dtp-rational        (add-rational     x y))
     ($$dtp-complex         (add-complex      x y))
     (t (li:tail-error "You can't add those!" x y))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Generic subtract
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun subtract-generic (x y)
  (multiple-value-setq (x y) (generic-math-type-coercer x y))
  (prims:dispatch vinc::%%data-type x
     ($$dtp-fixnum          (subtract-fixnum       x y))
     ($$dtp-bignum          (subtract-bignum       x y))
     ($$dtp-short-float     (subtract-short        x y))
     ($$dtp-single-float    (subtract-single       x y))
     ($$dtp-double-float    (subtract-double       x y))
     ($$dtp-rational        (subtract-rational     x y))
     ($$dtp-complex         (subtract-complex      x y))
     (t (li:tail-error "You can't subtract those!" x y))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Generic multiply
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun multiply-generic (x y)
  (multiple-value-setq (x y) (generic-math-type-coercer x y))
  (prims:dispatch vinc::%%data-type x
     ($$dtp-fixnum          (multiply-fixnum       x y))
     ($$dtp-bignum          (multiply-bignum       x y))
     ($$dtp-short-float     (multiply-short        x y))
     ($$dtp-single-float    (multiply-single       x y))
     ($$dtp-double-float    (multiply-double       x y))
     ($$dtp-rational        (multiply-rational     x y))
     ($$dtp-complex         (multiply-complex      x y))
     (t (li:tail-error "You can't multiply those!" x y))))
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Generic divide
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun DIVIDE-generic (xx yy)
  (multiple-value-bind (x y) (generic-math-type-coercer xx yy)
    (prims:dispatch vinc::%%data-type x
      (($$dtp-fixnum $$dtp-bignum) (make-canonical-rational xx yy))
      ($$dtp-short-float     (divide-short        x y))
      ($$dtp-single-float    (divide-single       x y))
      ($$dtp-double-float    (divide-double       x y))
      ($$dtp-rational        (divide-rational     x y))
      ($$dtp-complex         (divide-complex      x y))
      (t (li:tail-error "You can't divide those!" x y)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Generic truncate
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun TRUNCATE (xx &optional (yy 1))
  (multiple-value-bind (x y) (generic-math-type-coercer xx yy)
    (prims:dispatch vinc::%%data-type x
      ($$dtp-fixnum          (divide-fixnum       x y))
      ($$dtp-bignum          (divide-bignum       x y))
      ($$dtp-short-float     (truncate-short    (divide-short        x y)))
      ($$dtp-single-float    (truncate-single   (divide-single       x y)))
      ($$dtp-double-float    (truncate-double   (divide-double       x y)))
      ($$dtp-rational 	     (let ((new-divisor (* y (denominator x)))
				   quotient remainder)
			       (multiple-value-setq (quotient remainder)
				 (truncate (numerator x) new-divisor))
			       (values quotient (make-canonical-rational remainder new-divisor)))) 
      ($$dtp-complex         (li:tail-error "Can't TRUNCATE a complex"))
      (t (li:tail-error "You can't truncate those!" x y)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; some helpers for FLOOR, CEILING and ROUND
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Common LISP specifies:   QUOTIENT * DIVISOR + REMAINDER = NUMBER

(defsubst int-adjust-positive (quotient remainder divisor)
  (values (1+ quotient) (- remainder divisor)))

(defsubst int-adjust-negative (quotient remainder divisor)
  (values (1- quotient) (+ remainder divisor)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Generic FLOOR
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun FLOOR (number &optional (divisor 1))
  (multiple-value-bind (quotient remainder)
      (truncate number divisor)
    (if (zerop remainder)
	(values quotient remainder)		;no fixup necessary
      (if (< quotient 0)
	  (int-adjust-negative quotient remainder divisor)
	(values quotient remainder)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Generic CEILING
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun CEILING (number &optional (divisor 1))
  (multiple-value-bind (quotient remainder)
      (truncate number divisor)
    (if (zerop remainder)
	(values quotient remainder)		;no fixup necessary
      (if (> quotient 0)
	  (int-adjust-positive quotient remainder divisor)
	(values quotient remainder)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Generic ROUND
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun ROUND (number &optional (divisor 1))
  (multiple-value-bind (quotient remainder)
      (truncate number divisor)
    (cond ((zerop remainder)
	   (values quotient remainder))
	  ((= remainder .5)			;round toward even quotient
	   (if (li:evenp quotient)
	       (values quotient remainder)
	     (if (< quotient 0)
		 (int-adjust-negative quotient remainder divisor)
	       (int-adjust-positive quotient remainder divisor))))
	  ((< -0.5 remainder 0.5)		;round toward zero
	   (values quotient remainder))
	  (t (if (< quotient 0)			;round away from zero
		 (int-adjust-negative quotient remainder divisor)
	       (int-adjust-positive quotient remainder divisor))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Generic remainder
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun REM (x y)
  (multiple-value-bind (quotient remainder)
      (truncate x y)
    (declare (ignore quotient))
    remainder))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Generic modulus
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun MOD (x y)
  (multiple-value-bind (quotient remainder)
      (floor x y)
    (declare (ignore quotient))
    remainder))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Generic GCD
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun gcd-generic (x y)
  (multiple-value-setq (x y) (generic-math-type-coercer x y))
  (prims:dispatch vinc::%%data-type x
     ($$dtp-fixnum          (gcd-fixnum         x y))
     ($$dtp-bignum          (gcd-bignum         x y))
     (t (li:tail-error "You can't GCD those!" x y))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Generic logand
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun logand-generic (x y)
  (multiple-value-setq (x y) (generic-math-type-coercer x y))
  (prims:dispatch vinc::%%data-type x
     ($$dtp-fixnum          (logand-fixnum         x y))
     ($$dtp-bignum          (logand-bignum         x y))
     (t (li:tail-error "You can't logand those!" x y))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Generic logior
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun logior-generic (x y)
  (multiple-value-setq (x y) (generic-math-type-coercer x y))
  (prims:dispatch vinc::%%data-type x
     ($$dtp-fixnum          (logior-fixnum         x y))
     ($$dtp-bignum          (logior-bignum         x y))
     (t (li:tail-error "You can't logior those!" x y))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Generic logxor
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun logxor-generic (x y)
  (multiple-value-setq (x y) (generic-math-type-coercer x y))
  (prims:dispatch vinc::%%data-type x
     ($$dtp-fixnum          (logxor-fixnum         x y))
     ($$dtp-bignum          (logxor-bignum         x y))
     (t (li:tail-error "You can't logxor those!" x y))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Generic logxnor
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun logxnor-generic (x y)
  (multiple-value-setq (x y) (generic-math-type-coercer x y))
  (prims:dispatch vinc::%%data-type x
     ($$dtp-fixnum          (logxnor-fixnum        x y))
     ($$dtp-bignum          (logxnor-bignum        x y))
     (t (li:tail-error "You can't logxnor those!" x y))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Generic lognot
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun lognot-generic (x)
  (prims:dispatch vinc::%%data-type x
     ($$dtp-fixnum          (lognot-fixnum       x))
     ($$dtp-bignum          (lognot-bignum       x))
     (t (li:tail-error "You can't lognot that!" x))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Generic negate
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun negate-generic (x)
  (prims:dispatch vinc::%%data-type x
     ($$dtp-fixnum          (negate-fixnum        x))
     ($$dtp-bignum          (negate-bignum        x))
     ($$dtp-short-float     (negate-short         x))
     ($$dtp-single-float    (negate-single        x))
     ($$dtp-double-float    (negate-double        x))
     ($$dtp-rational        (negate-rational      x))
     ($$dtp-complex         (negate-complex       x))
     (t (li:tail-error "You can't negate that!" x))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Generic compare
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun compare-generic (x y)
  (multiple-value-setq (x y) (generic-math-type-coercer x y))
  (prims:dispatch vinc::%%data-type x
     ($$dtp-fixnum          (compare-fixnum       x y))
     ($$dtp-bignum          (compare-bignum       x y))
     ($$dtp-short-float     (compare-short        x y))
     ($$dtp-single-float    (compare-single       x y))
     ($$dtp-double-float    (compare-double       x y))
     ($$dtp-rational        (compare-rational     x y))
     (t (li:tail-error "You can't compare those!" x y))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Generic equal
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun equal-generic (x y)
  (multiple-value-setq (x y) (generic-math-type-coercer x y))
  (prims:dispatch vinc::%%data-type x
     ($$dtp-fixnum          (compare-fixnum       x y))
     ($$dtp-bignum          (compare-bignum       x y))
     ($$dtp-short-float     (compare-short        x y))
     ($$dtp-single-float    (compare-single       x y))
     ($$dtp-double-float    (compare-double       x y))
     ($$dtp-rational        (compare-rational     x y))
     ($$dtp-complex         (compare-complex      x y))
     (t (li:tail-error "You can't compare those!" x y))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Generic test
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun test-generic (x)
  (prims:dispatch vinc::%%data-type x
     ($$dtp-fixnum          (test-fixnum        x))
     ($$dtp-bignum          (test-bignum        x))
     ($$dtp-short-float     (test-short         x))
     ($$dtp-single-float    (test-single        x))
     ($$dtp-double-float    (test-double        x))
     ($$dtp-rational        (test-rational      x))
     ($$dtp-complex         (test-complex       x))
     (t (li:tail-error "You can't test ~s" x))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Generic ash
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun ash-generic (x y)
  (prims:dispatch vinc::%%data-type x
     ($$dtp-fixnum          (ash-fixnum            x y))
     ($$dtp-bignum          (ash-bignum            x y))
     (t (li:tail-error "You can't ash those!" x y))))