;;; -*- Mode:LISP; Package:LISP-INTERNALS; Base:10; Readtable:CL -*-

;;; SIMPLE PREDICATES:
(defun zerop  (number)	(zerop  number))
(defun plusp  (number)	(plusp  number))
(defun minusp (number)	(minusp number))


;;; ODDP & EVENP

(defun oddp (x)
  (cond ((vinc:fixnump x)
	 (hw:32logbitp 0 x))
	((vinc:bignump x)
	 (hw:32logbitp 0 (array:%vm-read32 x 1)))
	(t (li:tail-error "ODDP: ~s in not an integer" x))))

(defun evenp (x)
  (cond ((vinc:fixnump x)
	 (not (hw:32logbitp 0 x)))
	((vinc:bignump x)
	 (not (hw:32logbitp 0 (array:%vm-read32 x 1))))
	(t (li:tail-error "EVENP: ~s in not an integer" x))))


;;; ARITHMETIC COMPARISONS:

(defmacro define-arithmetic-comparator (name)
  `(defun ,name (&rest numbers)
     (cond ((null numbers)
	    (error ,(global:format nil "No arguments to function ~s" name)))
	   ((null (cdr numbers)) t)
	   (t (block foo
		(do ((n1 numbers (cdr n1)))
		    ((null (cdr n1)) (return-from foo t))
		  (do ((n2 (cdr n1) (cdr n2)))
		      ((null n2))
		    (unless (,name (car n1) (car n2))
		      (return-from foo nil)))))))))

(define-arithmetic-comparator =)
(define-arithmetic-comparator <)
(define-arithmetic-comparator >)
(define-arithmetic-comparator <=)
(define-arithmetic-comparator >=)
(define-arithmetic-comparator //=)

(defun max (number &rest numbers)
  (let ((max number))
    (dolist (n numbers max)
      (when (> n max)
	(setq max n)))))

(defun max-2 (n1 n2)
  (if (> n1 n2) n1 n2))

(defrewrite max (&whole form)
  (let ((length-form (length form)))
    (cond ((= length-form 2)
	   (second form))
	  ((= length-form 3)
	   `(MAX-2 . ,(cdr form)))
	  (t form)))
  )

(defun min (number &rest numbers)
  (let ((min number))
    (dolist (n numbers min)
      (when (< n min)
	(setq min n)))))

(defun min-2 (n1 n2)    ;;@@@ Turn this into a macro  --wkf
  (if (< n1 n2) n1 n2))

;(defun min-3+ (n1 n2 n3 &rest numbers)
;  (let ((min (if (< n1 n2)
;		 (min-2 n1 n3)
;	       (min-2 n2 n3))))
;    (dolist (n numbers min)
;      (when (< n min)
;	(setq min n)))))

(defrewrite min (&whole form)
  (let ((length-form (length form)))
    (cond ((= length-form 2)
	   (second form))
	  ((= length-form 3)
	   `(MIN-2 . ,(cdr form)))
	  (t form))))  ;;@@@ Is it worth saving consing with a min/max-3+ ???  --wkf

(defun abs (number)
  (if (complexp number)
      (li:error "Can't ABS complex numbers yet.") ;;;(sqrt (+ (expt (realpart number) 2) (expt (imagpart number) 2)))
    (if (minusp number) (- number) number)))

(defmacro define-plus-like-function (name identity)
  `(defun ,name (&rest numbers)
     (let ((result (or (car numbers) ,identity))) ;;||| optimized 9/20/88 --wkf
       (dolist (n (cdr numbers) result)
	 (setq result (,name result n))))))

(define-plus-like-function + 0)
(define-plus-like-function * 1)

;;; The following added to support cros-compiled code.
;;; Eventually some of these will be open coded and can disappear.
;;; Still need the other TWO-ARGUMENT-FUNCTIONs in QCOPT.
;;; -smh 23sep88

;;;  moved these back into CROSS-SUPPORT  ||| 26spet88 pfc
;(defun *plus (x y)
;  (+ x y))

;(defun *times (x y)
;  (* x y))

;(defun *dif (x y)
;  (- x y))

;;; +++ How does this differ from %DIV??
;(defun *quo (x y)
;  (/ x y))

(defun - (minuend &rest subtrahends)
  (if subtrahends
      (let ((difference minuend))
	(dolist (n subtrahends difference)
	  (setq difference (- difference n))))
    (- minuend)))

(defun / (dividend &rest divisors)
  (if divisors
      (let ((quotient dividend))
	(dolist (n divisors quotient)
	  (setq quotient (new-math:divide-generic quotient n))))
    (new-math:divide-generic 1 dividend)))

(defun 1+ (number) (1+ number))
(defun 1- (number) (1- number))

(defun ^ (x y)
  (if (integerp y)
      (do ((abs-y (abs y))
	   (ans    1 (* ans x))
	   (i      0 (1+ i)))
	  ((= i abs-y) (if (minusp y)
			   (/ ans)
			 ans)))
    (li:tail-error "^ not yet defined for non-integer powers." x y)))
	   
;;; @@@ This should be a defsubst so compiled code can open compile it, but the interpreter
;;; needs to see it also.
(defun expt (x y) (^ x y))

;;; BITWISE LOGICAL OPERATIONS
(define-plus-like-function logior  0)
(define-plus-like-function logxor  0)
(define-plus-like-function logand -1)
(define-plus-like-function logeqv -1)

(defun lognand  (integer1 integer2) (lognand  integer1 integer2))
(defun lognor   (integer1 integer2) (lognor   integer1 integer2))
(defun logandc1 (integer1 integer2) (logandc1 integer1 integer2))
(defun logandc  (integer1 integer2) (logandc2 integer1 integer2))
(defun logorc1  (integer1 integer2) (logorc1  integer1 integer2))
(defun logorc2  (integer1 integer2) (logorc2  integer1 integer2))

;;; The values for these must be consistent with
;;; there locations in the boole dispatch table:
(defconstant boole-clr	0)
(defconstant boole-set	1)
(defconstant boole-1	2)
(defconstant boole-2	3)
(defconstant boole-c1	4)
(defconstant boole-c2	5)
(defconstant boole-and	6)
(defconstant boole-ior	7)
(defconstant boole-xor	8)
(defconstant boole-eqv	9)
(defconstant boole-nand	10)
(defconstant boole-nor	11)
(defconstant boole-andc1 12)
(defconstant boole-andc2 13)
(defconstant boole-orc1	14)
(defconstant boole-orc2	15)

(defun boole (operation integer1 integer2)
  (dispatch (byte 4 0) operation    ;;;@@@ We must make sure dispatch is fixed to optimize using size of byte-spec.  --wkf
	    (boole-clr	0)
	    (boole-set	-1)
	    (boole-1	integer1)
	    (boole-2	integer2)
	    (boole-c1	(lognot integer1))
	    (boole-c2	(lognot integer2))
	    (boole-and	(logand integer1 integer2))
	    (boole-ior	(logior integer1 integer2))
	    (boole-xor	(logxor integer1 integer2))
	    (boole-eqv	(logeqv integer1 integer2))
	    (boole-nand	(lognand integer1 integer2))
	    (boole-nor	(lognor integer1 integer2))
	    (boole-andc1 (logand (lognot integer1) integer2))
	    (boole-andc2 (logand integer1 (lognot integer2)))
	    (boole-orc1	(logior (lognot integer1) integer2))
	    (boole-orc2	(logior integer1 (lognot integer2)))))

(defun dpb (x byte-spec y)
  (multiple-value-setq (x y) (new-math:generic-math-type-coercer x y))
  (cond
     ((vinc:fixnump x) (new-math:field-pass-fixnum x y byte-spec nil))
     ((vinc:bignump x) (new-math:field-pass-bignum x y byte-spec nil))
     (t (li:error "You can't dpb those!" x y))))


(defun ldb (byte-spec x)
  (cond
    ((vinc:fixnump x) (new-math:field-pass-fixnum x 0 byte-spec t))
    ((vinc:bignump x) (new-math:field-pass-bignum x (new-math:convert-fixnum-to-bignum 0) byte-spec t))
    (t (li:error "You can't ldb that!" x))))

(defun ash (number count)  ;;@@@ Turn this into a macro.  --wkf
  (ash number count))

(defun integer-length (number)
  (cond
    ((vinc:fixnump number)
       (when (minusp number)
	(setq number (hw:ldb-not number vinc:%%fixnum-field 0)))
       (let ((leading-zeros (hw:ldb (hw:24-prioritize number) vinc:%%fixnum-field 0)))
	 (if (zerop leading-zeros)
	     0
	   (- 24. leading-zeros))))
    ((vinc:bignump number)
     (let* ((size-in-words (hw:ldb (array:%vm-read number) vinc:%%fixnum-field 0))
	    (high-word (array:%vm-read32 number size-in-words)))
       (when (hw:32logbitp 31. high-word)
	   (setq high-word (hw:ldb-not high-word (byte 32. 0) gr:*all-zero*)))
       (let ((leading-zeros (hw:ldb (hw:32-prioritize high-word) vinc:%%fixnum-field 0)))
	 (if (zerop leading-zeros)
	     (hw:dpb (1- size-in-words) (byte 19. 5.) 0)
	   (+ (- 32. leading-zeros) (hw:dpb (1- size-in-words) (byte 19. 5.) 0))))))
    (t (error "Not an integer to INTEGER-LENGTH"))))
       
(defun logcount (number)
  (cond
    ((vinc:fixnump number)
     (if (minusp number)
	 (%count-bits (hw:ldb-not number vinc:%%fixnum-field gr:*all-zero*))
       (%count-bits number)))
    ((vinc:bignump number)
     (let* ((size-in-words (hw:ldb (array:%vm-read number) vinc:%%fixnum-field 0))
	    (high-word (array:%vm-read32 number size-in-words)))
       (if (hw:32logbitp 31. high-word)
	   (do ((bit-count (%count-bits (hw:ldb-not high-word (byte 32. 0) gr:*all-zero*)))
		(i (1- size-in-words) (1- i)))
	       ((zerop i) bit-count)
	     (setq bit-count
		   (+ bit-count
		      (%count-bits (hw:ldb-not (array:%vm-read32 number i) (byte 32. 0) gr:*all-zero*)))))
	 (do ((bit-count (%count-bits high-word))
	      (i (1- size-in-words) (1- i)))
	     ((zerop i) bit-count)
	   (setq bit-count (+ bit-count (%count-bits (array:%vm-read32 number i))))))))
    (t (error "Not an integer to LOG-COUNT"))))

(defun %count-bits (number)
  (do ((count (hw:ldb number (byte 1 0) 0) (+ count (hw:ldb number (byte 1 0) 0)))
       (number number (hw:ldb number (byte 31. 1.) gr:*all-zero*)))
      ((hw:32zerop number) count)))


(defun logbitp (index number)
  (not (zerop (ldb (byte 1 index) number))))

(defun eight-bit-fixnump (fixnum)  ;;@@@ Turn this into a macro later  --wkf.
  "Test is same as (and (<= fixnum 127.) (>= fixnum -128.))"
  (or (hw:field= fixnum gr:*all-zero* vinc:%%byte-position-non-fixnum)   ;;positive and <=  127
      (hw:field= fixnum gr:*all-ones* vinc:%%byte-position-non-fixnum))) ;;negative and >= -128

(defun byte (size position)
  (li:%trap-if-not-both-fixnum size position)
  (when (minusp size)
    (error "BYTE can't handle negative field sizes"))
  (if (and (<= size 32.)
	   (eight-bit-fixnump position))
      (hw:dpb size vinc:%%byte-size position)
    (cons size position)))

(defun byte-size (byte-spec)
  (cond
    ((vinc:fixnump byte-spec) (let ((ans (hw:ldb byte-spec vinc:%%byte-size 0)))
				(if (zerop ans) 32. ans)))
    ((vinc:consp   byte-spec) (car byte-spec))
    (t (tail-error "That isn't a byte specifier"))))

(defun byte-position-fixnum (fixnum-bytespec) "Turns eight bit two's complement into 24 two's complement"
  (vinc:make-fixnum (hw:32-sign-extend-byte fixnum-bytespec)))

(defun byte-position (byte-spec)
  (cond
    ((vinc:fixnump byte-spec) (byte-position-fixnum byte-spec))
    ((vinc:consp   byte-spec) (cdr byte-spec))
    (t (tail-error "That isn't a byte specifier"))))

(defun ldb-test (byte-spec number)
  (not (zerop (ldb byte-spec number))))

(defun mask-field (byte-spec number)
  (logand number (dpb -1 byte-spec 0)))

(defun deposit-field (from-number byte-spec to-number)
  (dpb (ldb byte-spec from-number) byte-spec to-number))


(defconstant most-positive-fixnum  #x7FFFFF)
(defconstant most-negative-fixnum #x-800000)