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

;**************************************************
;*  Floating point functions			  *
;**************************************************

;;WKF: This is needed so that defconstant will work.
;;       Defconstant is evaluated at run time thus causeing problems.
;(defun new-math:unboxed-constant (arg)
;  (hw:unboxed-constant arg))
;Above does not work.  Macro def for hw:unboxed-constant is in file compiler-support.lisp

(defconstant float-error-mask (new-math:unboxed-constant
				  (cl:logior (cl:ash 1. hw:$$fpu-exact-infinity)
					     (cl:ash 1. hw:$$fpu-overflow-inexact)
					     (cl:ash 1. hw:$$fpu-x-denormalized)
					     (cl:ash 1. hw:$$fpu-y-denormalized)
					     (cl:ash 1. hw:$$fpu-xy-denormalized)
					     (cl:ash 1. hw:$$fpu-zero-divide)
					     (cl:ash 1. hw:$$fpu-x-nan)
					     (cl:ash 1. hw:$$fpu-y-nan)
					     (cl:ash 1. hw:$$fpu-xy-nan)
					     (cl:ash 1. hw:$$fpu-invalid-operation))))

(defmacro fpu-status ()
  '(hw:field-extract (hw:read-processor-status)
		     hw:%%processor-status-floating-point-status))

(defconstant alu-status-equal   #x80000)
(defconstant alu-status-greater #x00000)
(defconstant alu-status-less    #x20000)

;**************************************************
;*  Weitek floating point chip initializer
;**************************************************

(defafun init-float ()
  (falu fpu-default-mode0 nop ignore ignore fpu-load-mode fpu-unload-high)
  (falu fpu-default-mode1 nop ignore ignore fpu-load-mode fpu-unload-high)
  (falu fpu-default-mode2 nop ignore ignore fpu-load-mode fpu-unload-high)
  (falu fpu-default-mode3 nop ignore ignore fpu-load-mode fpu-unload-high)
  (fmul fpu-default-mode0 nop ignore ignore fpu-load-mode fpu-unload-high)
  (fmul fpu-default-mode1 nop ignore ignore fpu-load-mode fpu-unload-high)
  (fmul fpu-default-mode2 nop ignore ignore fpu-load-mode fpu-unload-high)
  (fmul fpu-default-mode3 nop ignore ignore fpu-load-mode fpu-unload-high)
  (return gr:*nil* boxed-right))

;**************************************************
;*  Short precision
;**************************************************

(defconstant short-float-pointer (new-math:unboxed-constant (ash vinc:$$dtp-short-float 26.)))

(defconstant %%dpb-short (byte 26. 6.))

(defun add-short (xx yy)
  (let* ((x (hw:dpb-unboxed xx %%dpb-short gr:*all-zero*))
	 (y (hw:dpb-unboxed yy %%dpb-short gr:*all-zero*))
	 (tflag (hw:trap-off))
	 (result (hw:float-add-single x y))
	 (status (fpu-status)))
      (fixup-short result status tflag)))

(defun subtract-short (xx yy)
  (let* ((x (hw:dpb-unboxed xx %%dpb-short gr:*all-zero*))
	 (y (hw:dpb-unboxed yy %%dpb-short gr:*all-zero*))
	 (tflag (hw:trap-off))
	 (result (hw:float-subtract-single x y))
	 (status (fpu-status)))
      (fixup-short result status tflag)))

(defun multiply-short (xx yy)
  (let* ((x (hw:dpb-unboxed xx %%dpb-short gr:*all-zero*))
	 (y (hw:dpb-unboxed yy %%dpb-short gr:*all-zero*))
	 (tflag (hw:trap-off))
	 (result (hw:float-multiply-single x y))
	 (status (fpu-status)))
      (fixup-short result status tflag)))

(defun divide-short (xx yy)
  (let* ((x (hw:dpb-unboxed xx %%dpb-short gr:*all-zero*))
	 (y (hw:dpb-unboxed yy %%dpb-short gr:*all-zero*))
	 (tflag (hw:trap-off))
	 (result (hw:float-divide-single x y))
	 (status (fpu-status)))
      (fixup-short result status tflag)))

(defun fixup-short (result status tflag)
  (hw:write-memory-control						 ;traps on
    (hw:dpb-unboxed tflag (byte 1 31.) (hw:read-memory-control)))
  (if (hw:32logbitp status float-error-mask)				 ;test error status
      (li:error "Short float operation" status)
    (progn
      (setq result (hw:ldb-boxed result %%dpb-short short-float-pointer)) ;make short float
      (setq status (hw:read-alu-status))				  ;save Z bit
      (values
	result
	(hw:dpb (hw:ldb result (byte 1 25.) 0) (byte 1 17.) status)))))   ;insert N bit

(defun compare-short (xx yy)
  (let* ((x (hw:dpb-unboxed xx %%dpb-short gr:*all-zero*))
	 (y (hw:dpb-unboxed yy %%dpb-short gr:*all-zero*))
	 (tflag (hw:trap-off))
	 (result (hw:float-compare-single x y))
	 (status (fpu-status)))
    (hw:write-memory-control						 ;traps on
      (hw:dpb-unboxed tflag (byte 1 31.) (hw:read-memory-control)))
    (dispatch (byte 2 0) status
       (0 (values 0  alu-status-equal))
       (1 (values -1 alu-status-less))
       (2 (values 1 alu-status-greater))
       (3 (li:error "Short float compare" status)))))

(defun test-short (xx)
  (let* ((x (hw:dpb-unboxed xx %%dpb-short gr:*all-zero*))
	 (status (hw:read-alu-status)))
    (cond ((hw:32< x gr:*all-zero*) (values -1 status))
	  ((hw:32> x gr:*all-zero*) (values  1 status))
	  (t                         (values  0 status)))))

(defun negate-short (xx)
  (setf (hw:r0) (hw:dpb-unboxed xx %%dpb-short gr:*all-zero*))
  (let* ((status (hw:read-alu-status))
	 (result (hw:dpb-xor 1 (byte 1. 25.) xx)))
    (values result status)))

;**************************************************
;*  Single precision
;**************************************************

(defun add-single (xx yy)
  (let* ((x (array:%vm-read32 xx 1))
	 (y (array:%vm-read32 yy 1))
	 (tflag (hw:trap-off))
	 (result (hw:float-add-single x y))
	 (status (fpu-status)))
      (fixup-single result status tflag)))

(defun subtract-single (xx yy)
  (let* ((x (array:%vm-read32 xx 1))
	 (y (array:%vm-read32 yy 1))
	 (tflag (hw:trap-off))
	 (result (hw:float-subtract-single x y))
	 (status (fpu-status)))
      (fixup-single result status tflag)))

(defun multiply-single (xx yy)
  (let* ((x (array:%vm-read32 xx 1))
	 (y (array:%vm-read32 yy 1))
	 (tflag (hw:trap-off))
	 (result (hw:float-multiply-single x y))
	 (status (fpu-status)))
      (fixup-single result status tflag)))

(defun divide-single (xx yy)
  (let* ((x (array:%vm-read32 xx 1))
	 (y (array:%vm-read32 yy 1))
	 (tflag (hw:trap-off))
	 (result (hw:float-divide-single x y))
	 (status (fpu-status)))
      (fixup-single result status tflag)))

(defun fixup-single (result status tflag)
  (hw:write-memory-control						 ;traps on
    (hw:dpb-unboxed tflag (byte 1 31.) (hw:read-memory-control)))
  (if (hw:32logbitp status float-error-mask)				 ;test error status
      (li:error "Single float operation" status)
    (let ((ptr (cons:allocate-structure 1 1 vinc:$$dtp-single-float
					(cons:make-header vinc:$$dtp-unboxed-header 1))))
      (array:%vm-write32 ptr 1 result)
      (setf (hw:r0) result) ;update ALU status
      (setq status (hw:read-alu-status))				  ;save Z bit
      (values
	ptr
	(hw:dpb (hw:ldb result (byte 1 31.) 0) (byte 1 17.) status)))))   ;insert N bit

(defun compare-single (xx yy)
  (let* ((x (array:%vm-read32 xx 1))
	 (y (array:%vm-read32 yy 1))
	 (tflag (hw:trap-off))
	 (result (hw:float-compare-single x y))
	 (status (fpu-status)))
    (hw:write-memory-control						 ;traps on
      (hw:dpb-unboxed tflag (byte 1 31.) (hw:read-memory-control)))
    (dispatch (byte 2 0) status
       (0 (values 0  alu-status-equal))
       (1 (values -1 alu-status-less))
       (2 (values 1 alu-status-greater))
       (3 (li:error "Single float compare" status)))))

(defun test-single (xx)
  (let* ((x (array:%vm-read32 xx 1))
	 (status (hw:read-alu-status)))
    (cond ((hw:32< x gr:*all-zero*) (values -1 status))
	  ((hw:32> x gr:*all-zero*) (values  1 status))
	  (t                         (values  0 status)))))

(defun negate-single (xx)
  (let* ((x (array:%vm-read32 xx 1))
	 (ptr (cons:allocate-structure 1 1 vinc:$$dtp-single-float
				       (cons:make-header vinc:$$dtp-unboxed-header 1)))
	 (result (hw:dpb-xor 1 (byte 31. 0) x)))
    (let ((status (hw:read-alu-status)))
      (array:%vm-write32 ptr 1 result)
      (values ptr status))))

;**************************************************
;*  Double precision
;**************************************************

(defun add-double (xx yy)
  (let* ((x-lo (array:%vm-read32 xx 1))
	 (x-hi (array:%vm-read32 xx 2))
	 (y-lo (array:%vm-read32 yy 1))
	 (y-hi (array:%vm-read32 yy 2))
	 (tflag (hw:trap-off)))
    (multiple-value-bind (result-hi result-lo)
	(hw:float-add-double x-hi x-lo y-hi y-lo)
      (let ((status (fpu-status)))
	(fixup-double result-hi result-lo status tflag)))))

(defun subtract-double (xx yy)
  (let* ((x-lo (array:%vm-read32 xx 1))
	 (x-hi (array:%vm-read32 xx 2))
	 (y-lo (array:%vm-read32 yy 1))
	 (y-hi (array:%vm-read32 yy 2))
	 (tflag (hw:trap-off)))
    (multiple-value-bind (result-hi result-lo)
	(hw:float-subtract-double x-hi x-lo y-hi y-lo)
      (let ((status (fpu-status)))
	(fixup-double result-hi result-lo status tflag)))))

(defun multiply-double (xx yy)
  (let* ((x-lo (array:%vm-read32 xx 1))
	 (x-hi (array:%vm-read32 xx 2))
	 (y-lo (array:%vm-read32 yy 1))
	 (y-hi (array:%vm-read32 yy 2))
	 (tflag (hw:trap-off)))
    (multiple-value-bind (result-hi result-lo)
	(hw:float-multiply-double x-hi x-lo y-hi y-lo)
      (let ((status (fpu-status)))
	(fixup-double result-hi result-lo status tflag)))))

(defun divide-double (xx yy)
  (let* ((x-lo (array:%vm-read32 xx 1))
	 (x-hi (array:%vm-read32 xx 2))
	 (y-lo (array:%vm-read32 yy 1))
	 (y-hi (array:%vm-read32 yy 2))
	 (tflag (hw:trap-off)))
    (multiple-value-bind (result-hi result-lo)
	(hw:float-divide-double x-hi x-lo y-hi y-lo)
      (let ((status (fpu-status)))
	(fixup-double result-hi result-lo status tflag)))))

(defun fixup-double (result-hi result-lo status tflag)
  (hw:write-memory-control						 ;traps on
    (hw:dpb-unboxed tflag (byte 1 31.) (hw:read-memory-control)))
  (if (hw:32logbitp status float-error-mask)				 ;test error status
      (li:error "Double float operation" status)
    (let ((ptr (cons:allocate-structure 1 2 vinc:$$dtp-double-float
					(cons:make-header vinc:$$dtp-unboxed-header 2))))
      (array:%vm-write32 ptr 1 result-lo)
      (array:%vm-write32 ptr 2 result-hi)
      (setf (hw:r0) (hw:32logior result-hi result-lo)) ;update alu status
      (setq status (hw:read-alu-status))				  ;save Z bit
      (values
	ptr
	(hw:dpb (hw:ldb result-hi (byte 1 31.) 0) (byte 1 17.) status)))))   ;insert N bit

(defun compare-double (xx yy)
  (let* ((x-lo (array:%vm-read32 xx 1))
	 (x-hi (array:%vm-read32 xx 2))
	 (y-lo (array:%vm-read32 yy 1))
	 (y-hi (array:%vm-read32 yy 2))
	 (tflag (hw:trap-off)))
    (multiple-value-bind (result-hi result-lo)
	(hw:float-compare-double x-hi x-lo y-hi y-lo)
      (setf (hw:r0) result-hi) ;force the stupid compiler to emit code!
      (let ((status (fpu-status)))
	(hw:write-memory-control						 ;traps on
	  (hw:dpb-unboxed tflag (byte 1 31.) (hw:read-memory-control)))
	(dispatch (byte 2 0) status
		  (0 (values 0  alu-status-equal))
		  (1 (values -1 alu-status-less))
		  (2 (values 1 alu-status-greater))
		  (3 (li:error "Double float compare" status)))))))

(defun test-double (xx)
  (let* ((x-hi (array:%vm-read32 xx 1))
	 (x-lo (array:%vm-read32 xx 2)))
        (let* ((x-or (hw:32logior x-hi x-lo))
	       (status (hw:read-alu-status)))
      (cond ((hw:32= x-or gr:*all-zero*) (values 0  alu-status-equal))
	    ((hw:32logbitp 31. x-hi)     (values -1 alu-status-less))
	    (t                           (values 1  alu-status-greater))))))

(defun negate-double (xx)
  (let* ((x-lo (array:%vm-read32 xx 1))
	 (x-hi (hw:dpb-xor 1 (byte 1. 31.) (array:%vm-read32 xx 2)))
	 (x-or (hw:32logior x-hi x-lo))
	 (status (hw:read-alu-status))
	 (ptr (cons:allocate-structure 1 2 vinc:$$dtp-single-float
				       (cons:make-header vinc:$$dtp-unboxed-header 2))))
      (array:%vm-write32 ptr 1 x-lo)
      (array:%vm-write32 ptr 2 x-hi)
      (setq status (hw:dpb (hw:ldb x-hi (byte 1. 31.) 0) (byte 1. 19.) status))
      (values ptr status)))


;**************************************************
;*  Convert fix to short
;**************************************************

(defafun convert-fixnum-to-short (i)
  (alu sex-r a1 a0 a0 bw-24 unboxed dt-both-fixnum)
  (move a2 trap-off unboxed)
  (falu single-float nop ignore a1 fpu-load-x   fpu-unload-high unboxed)
  (falu single-float nop ignore a1 fpu-load-nop fpu-unload-high unboxed)
  (falu single-float nop ignore a1 fpu-load-nop fpu-unload-high unboxed)
  (falu single-float nop ignore a1 fpu-load-nop fpu-unload-high unboxed)
  (falu single-float nop ignore a1 fpu-load-nop fpu-unload-high unboxed)
  (falu single-float a3  ignore a1 fpu-load-nop fpu-unload-high unboxed)
  (alu-field field-pass memory-control a2 memory-control (byte 1. 31.) unboxed)
  (movei a4 #.(ash vinc:$$dtp-short-float 26.) unboxed)
  (alu-field field-pass return a3 a4 (byte 26. -6.) boxed ch-return next-pc-return)
 )

;**************************************************
;*  Convert fix to single
;**************************************************

(defafun convert-fixnum-to-single (i)
  (alu sex-r a1 ignore a0 bw-24 unboxed dt-both-fixnum)
  (move a2 trap-off unboxed)
  (falu single-float nop ignore a1 fpu-load-x   fpu-unload-high unboxed)
  (falu single-float nop ignore a1 fpu-load-nop fpu-unload-high unboxed)
  (falu single-float nop ignore a1 fpu-load-nop fpu-unload-high unboxed)
  (falu single-float nop ignore a1 fpu-load-nop fpu-unload-high unboxed)
  (falu single-float nop ignore a1 fpu-load-nop fpu-unload-high unboxed)
  (falu single-float a3  ignore a1 fpu-load-nop fpu-unload-high unboxed)
  (alu-field field-pass memory-control a2 memory-control (byte 1. 31.) unboxed)
  (tail-open-call (array:make-single-float 1) (o0 a3))
 )

;**************************************************
;*  Convert fix to double
;**************************************************

(defafun convert-fixnum-to-double (i)
  (alu sex-r a1 ignore a0 bw-24 unboxed)
  (move a2 trap-off unboxed)
  (falu double-float nop ignore a1 fpu-load-x   fpu-unload-high unboxed)
  (falu double-float nop ignore a1 fpu-load-nop fpu-unload-high unboxed)
  (falu double-float nop ignore a1 fpu-load-nop fpu-unload-high unboxed)
  (falu double-float nop ignore a1 fpu-load-nop fpu-unload-high unboxed)
  (falu double-float nop ignore a1 fpu-load-nop fpu-unload-low  unboxed)
  (falu double-float o0  ignore a1 fpu-load-nop fpu-unload-low  unboxed ch-tail-open)
  (falu double-float o1  ignore a1 fpu-load-nop fpu-unload-low  unboxed)
  (alu-field field-pass memory-control a2 memory-control (byte 1. 31.) unboxed)
  (tail-call (array:make-double-float 2) ())
 )

;**************************************************
;*  Convert short to single
;**************************************************

(defun convert-short-to-single (x)
  (array:make-single-float (hw:dpb-unboxed x (byte 26. 6.) gr:*all-zero*)))

;**************************************************
;*  Convert short to double
;**************************************************

(defafun convert-short-to-double (x)
  (alu-field field-extract-r a1 ignore a0 (byte 26. 6.) unboxed-md)
  (move a2 trap-off unboxed)
  (falu single-to-double nop a1 ignore fpu-load-x   fpu-unload-high unboxed)
  (falu single-to-double nop a1 ignore fpu-load-nop fpu-unload-high unboxed)
  (falu single-to-double nop a1 ignore fpu-load-nop fpu-unload-high unboxed)
  (falu single-to-double nop a1 ignore fpu-load-nop fpu-unload-high unboxed)
  (falu single-to-double nop a1 ignore fpu-load-nop fpu-unload-low  unboxed)
  (falu single-to-double o0  a1 ignore fpu-load-nop fpu-unload-low  unboxed ch-tail-open)
  (falu single-to-double o1  a1 ignore fpu-load-nop fpu-unload-low  unboxed)
  (alu-field field-pass memory-control a3 memory-control (byte 1. 31.) unboxed)
  (tail-call (array:make-double-float 2) ())
 )

;**************************************************
;*  Convert single to double
;**************************************************

(defafun convert-single-to-double (x)
  (alu r+1 vma-start-read ignore a0 unboxed-vma unboxed-md)
  (nop)
  (move a1 md unboxed)
  (move a2 trap-off unboxed)
  (falu single-to-double nop a1 ignore fpu-load-x   fpu-unload-high unboxed)
  (falu single-to-double nop a1 ignore fpu-load-nop fpu-unload-high unboxed)
  (falu single-to-double nop a1 ignore fpu-load-nop fpu-unload-high unboxed)
  (falu single-to-double nop a1 ignore fpu-load-nop fpu-unload-high unboxed)
  (falu single-to-double nop a1 ignore fpu-load-nop fpu-unload-low  unboxed)
  (falu single-to-double o0  a1 ignore fpu-load-nop fpu-unload-low  unboxed ch-tail-open)
  (falu single-to-double o1  a1 ignore fpu-load-nop fpu-unload-low  unboxed)
  (alu-field field-pass memory-control a3 memory-control (byte 1. 31.) unboxed)
  (tail-call (array:make-double-float 2) ())
 )

;**************************************************
;*  DECODE-FLOAT
;**************************************************
;;; DECODE-FLOAT dispatches to these depending on the type of float.
;;; We should return three values:
;;;    - a floating point number of the same format as our argument but
;;;      between zero and one (a zero exponent),
;;;    - an integer representing the exponent.
;;;    - a floating point 1.0 of the same format with the same sign as the argument.

;;; short floats are the top 26 bits of the single float representation
(defun decode-float-short (float)
  (let ((sign-value (cons:make-pointer $$dtp-short-float
				       (hw:dpb-aligned float hw:%%short-float-sign
						       (hw:dpb-unboxed hw:$$short-float-exponent-excess
										   hw:%%short-float-exponent 0))))
	(one-half (hw:dpb-unboxed (1- hw:$$short-float-exponent-excess)
					      hw:%%short-float-exponent 0)))
    (if (hw:field= float (hw:unboxed-constant 0) (byte 25. 0))	;is all but sign bit = zero
	(values (cons:make-pointer $$dtp-short-float (hw:unboxed-constant 0))
		0 sign-value)
      (values (cons:make-pointer $$dtp-short-float
				 (hw:dpb-aligned float hw:%%short-float-mantissa one-half))
	      (- (hw:ldb float hw:%%short-float-exponent 0) hw:$$short-float-exponent-excess)
	      sign-value) )))

(defun decode-float-single (float)
  (let* ((word (array::%vm-read32 float 1))
	 (sign-value (array:make-single-float		;deposit sign bit into representation of 1.0
		       (hw:dpb-aligned word hw:%%single-float-sign
				       (dpb hw:$$single-float-exponent-excess
								   hw:%%single-float-exponent 0))))
	 (one-half (dpb (1- hw:$$single-float-exponent-excess)
					       hw:%%single-float-exponent 0)))
    (if (hw:field= word (hw:unboxed-constant 0) (byte 31. 0))	;is it zero?  (ignoring sign bit).
	(values (array:make-single-float (hw:unboxed-constant 0))
		0 sign-value)
      (values (array:make-single-float (hw:dpb-aligned word hw:%%single-float-mantissa one-half))
	      (- (hw:ldb word hw:%%single-float-exponent 0) hw:$$single-float-exponent-excess)
	      sign-value))))

;;; this still needs to be hacked to use the new byte specifiers
;(defun decode-float-double (float)
;  (let* ((word1 (array::%vm-read32 float 1))
;	 (word2 (array::%vm-read32 float 2))
;	 (one-half2 (dpb (1- hw:$$double-float-exponent-excess)
;			(byte-in-byte hw:%%double-float-exponent (byte 32. 32.))
;			0))
;;	 (one-half2 (hw:unboxed-constant #x3fe00000))
;	 (sign-value (array:make-double-float (hw:dpb-aligned word2
;							      (byte-in-byte hw:%%double-float-sign (byte 32. 32.))
;							      (hw:unboxed-constant #x3ff00000))
;					      (hw:unboxed-constant #x0))))
;    (if (and (hw:32= word1 (hw:unboxed-constant 0))
;	     (hw:field= word2 (hw:unboxed-constant 0)
;			(byte-in-byte (byte-union hw:double-float-exponent
;						  hw:double-float-mantissa)
;				      (byte 32. 32.))))	;is it zero?  (ignoring sign bit).
;	(values (array:make-double-float (hw:unboxed-constant 0)
;				   (hw:unboxed-constant 0))
;		0 sign-value)
;      (values (array:make-double-float (hw:dpb-aligned word2 (byte 20. 0) one-half2) word1)
;	      (- (hw:ldb word2 (byte-in-byte hw:%%double-float-exponent (byte 32. 32.)) 0)
;		 hw:$$double-float-exponent-excess)
;	      sign-value))))

(defun DECODE-FLOAT (float)
  (prims:dispatch vinc::%%data-type float
     ($$dtp-short-float     (decode-float-short float))
     ($$dtp-single-float    (decode-float-single float))
     ($$dtp-double-float    (decode-float-double float))
     (t (li:error "~d is not a floating point number" float))))

;**************************************************
;*  INTEGER-DECODE-FLOAT
;**************************************************
;;; These are similar to the DECODE-FLOAT functions except
;;; that the first value is an integer which represents the
;;; scaled mantissa.
(defun integer-decode-float-short (float)
  (let ((sign-value (cons:make-pointer $$dtp-short-float
				       (hw:dpb-aligned float hw:%%short-float-sign
						       (hw:dpb-unboxed hw:$$short-float-exponent-excess
								       hw:%%short-float-exponent 0)))))
    (if (hw:field= float (hw:unboxed-constant 0) (byte 25. 0))	;is it zero
	(values 0 0 sign-value)
      (values (hw:ldb float hw:%%short-float-mantissa
		      (hw:dpb-unboxed 1 (byte 1 (byte-size hw:%%short-float-mantissa))
				      (hw:unboxed-constant 0)))	;zero plus hidden bit
	      (- (hw:ldb float hw:%%short-float-exponent 0)
		 hw:$$short-float-exponent-excess (byte-size hw:%%short-float-mantissa))
	      sign-value) )))

(defun integer-decode-float-single (float)
  (let* ((word (array::%vm-read32 float 1))
	 (sign-value (array:make-single-float	;deposit sign bit into representation of 1.0
		       (hw:dpb-aligned word hw:%%single-float-sign
				       (hw:dpb-unboxed hw:$$single-float-exponent-excess
						       hw:%%single-float-exponent 0)))))
    (if (hw:field= word (hw:unboxed-constant 0) (byte 31. 0))	;is it zero?  (ignoring sign bit).
	(values 0 0 sign-value)
      (let ((bignum (allocate-bignum 1)))
	(array::%vm-write32 bignum 1
			    (hw:dpb-aligned word hw:%%single-float-mantissa
					    (hw:dpb-unboxed 1 (byte 1 (byte-size hw:%%single-float-mantissa))
							    (hw:unboxed-constant 0))))
	(values (shrink-bignum-structure bignum)
		(- (hw:ldb word hw:%%single-float-exponent 0)
		   hw:$$single-float-exponent-excess (byte-size hw:%%single-float-mantissa))
		sign-value)))))

;;; this still needs to be hacked to use the new byte specifiers
;(defun integer-decode-float-double (float)
;  (let* ((word1 (array::%vm-read32 float 1))
;	 (word2 (array::%vm-read32 float 2))
;	 (sign-value (array:make-double-float (hw:dpb-aligned word2
;							      (byte-in-byte hw:%%double-float-sign (byte 32. 32.))
;							      (hw:unboxed-constant #x3ff00000))
;					      (hw:unboxed-constant #x0))))
;    (if (and (hw:32= word1 (hw:unboxed-constant 0))
;	     (hw:field= word2 (hw:unboxed-constant 0)
;			(byte-in-byte (byte-union hw:double-float-exponent
;						  hw:double-float-mantissa)
;				      (byte 32. 32.))))	;is it zero?  (ignoring sign bit).
;	(values (array:make-double-float (hw:unboxed-constant 0)	;double float zero
;					 (hw:unboxed-constant 0))
;		0 sign-value)
;      (let ((bignum (allocate-bignum 2)))
;	(array::%vm-write32 bignum 1 word1)
;	(array::%vm-write32 bignum 2
;			    (HW:DPB-ALIGNED WORD2 (BYTE 20. 0)
;					    (hw:unboxed-constant #x80000)))
;	(values (shrink-bignum-structure bignum)
;		(- (HW:LDB WORD2 (byte-in-byte hw:%%double-float-exponent (byte 32. 32.)) 0)
;		   hw:$$double-float-exponent-excess
;		   (byte-size hw:%%double-float-mantissa))
;		sign-value) ))))

(defun INTEGER-DECODE-FLOAT (float)
  (prims:dispatch vinc::%%data-type float
     ($$dtp-short-float     (integer-decode-float-short float))
     ($$dtp-single-float    (integer-decode-float-single float))
     ($$dtp-double-float    (integer-decode-float-double float))
     (t (li:error "~d is not a floating point number" float))))


;**************************************************
;*  things to TRUNCATE floats
;**************************************************

;(defun truncate-fix-sign (quotient remainder sign)
;  (if (< sign 0)
;      (values (- quotient) (- remainder))
;    (values quotient remainder)))

;(defun truncate-short (float)
;  (multiple-value-bind (mantissa exponent sign)
;      (integer-decode-float-short float)
;    (flet ((haulong (n)
;	     (if (zerop n) 0 (- 32. (hw:32-prioritize n)))) )
;      (cond ((>= exponent 0)
;	     ;all bits are integer, none are fraction:
;	     (truncate-fix-sign (ash mantissa exponent) 0 sign))
;	    ((> exponent (- (1+ (byte-size hw:%%short-float-mantissa))))
;	     ;;; remember that with the hidden bit, the mantissa is one bit wider than the field it is stored in.
;	     ;;; Some bits are integer, some are fraction.  Exponent is enough to shift the binary point
;	     ;;; somewhere into the mantissa but not so big as to move it beyond the left edge.
;	     (let* ((frac-int		 (hw:ldb mantissa (byte (- exponent) 0) (hw:unboxed-constant 0)))
;		    (significant-bits	 (haulong frac-int))
;		    (mantissa-byte-width (1- significant-bits))
;		    (mantissa-byte-position (- (byte-size hw:%%short-float-mantissa)
;					       mantissa-byte-width))
;		    (new-expt (+ exponent mantissa-byte-width))
;		    (new-mant (hw:dpb-unboxed frac-int
;					      (byte mantissa-byte-width mantissa-byte-position)
;					      (hw:unboxed-constant 0))))
;	       (truncate-fix-sign int-mantissa
;				  (cons:make-pointer $$dtp-short-float
;						     (hw:dpb-unboxed (+ new-expt hw:$$short-float-exponent-excess)
;								     hw:%%short-float-exponent new-mant))
;				  sign) ))
;	    (t ;;;all the bits are fraction so the argument is the remainder
;	     (values 0 float)) ))))

;(defun truncate-single (float)
;  (multiple-value-bind (mantissa exponent sign)
;      (integer-decode-float-single float)
;    (flet ((haulong (n) (if (zerop n) 0 (- 32. (hw:32-prioritize n)))) )
;      (cond ((>= exponent 0)
;	     ;;; all bits are integer, none are fraction:
;	     (truncate-fix-sign (ash mantissa exponent) 0 sign))
;	    ((> exponent (- (1+ (byte-size hw:%%single-float-mantissa))))
;	     ;;; remember that with the hidden bit, the mantissa is one bit wider than the field it is stored in.
;	     ;;; Some bits are integer, some are fraction.  Exponent is enough to shift the binary point
;	     ;;; somewhere into the mantissa but not so big as to move it beyond the left edge.
;	     (let* ((frac-int		 (hw:ldb mantissa (byte (- exponent) 0) (hw:unboxed-constant 0)))
;		    (significant-bits	 (haulong frac-int))
;		    (mantissa-byte-width (1- significant-bits))
;		    (mantissa-byte-position (- (byte-size hw:%%single-float-mantissa)
;					       mantissa-byte-width))
;		    (new-expt (+ exponent mantissa-byte-width))
;		    (new-mant (hw:dpb-unboxed frac-int
;					      (byte mantissa-byte-width mantissa-byte-position)
;					      (hw:unboxed-constant 0))))
;	       (truncate-fix-sign int-mantissa
;				  (array:make-single-float
;				    (hw:dpb-unboxed (+ new-expt hw:$$short-float-exponent-excess)
;						    hw:%%short-float-exponent new-mant))
;				  sign) ))
;	    (t ;;;all the bits are fraction so the argument is the remainder
;	     (values 0 float)) ))))

;;; this just has the "single" code lifted for now.  rememebr to fix this before usung
;(defun truncate-double (float)
;  (multiple-value-bind (mantissa exponent sign)
;      (integer-decode-float-double float)
;    (flet ((haulong (n) (if (zerop n) 0 (- 32. (hw:32-prioritize n)))) )
;      (cond ((>= exponent 0)
;	     ;;; all bits are integer, none are fraction:
;	     (truncate-fix-sign (ash mantissa exponent) 0 sign))
;	    ((> exponent (- (1+ (byte-size hw:%%single-float-mantissa))))
;	     ;;; remember that with the hidden bit, the mantissa is one bit wider than the field it is stored in.
;	     ;;; Some bits are integer, some are fraction.  Exponent is enough to shift the binary point
;	     ;;; somewhere into the mantissa but not so big as to move it beyond the left edge.
;	     (let* ((frac-int		 (hw:ldb mantissa (byte (- exponent) 0) (hw:unboxed-constant 0)))
;		    (significant-bits	 (haulong frac-int))
;		    (mantissa-byte-width (1- significant-bits))
;		    (mantissa-byte-position (- (byte-size hw:%%single-float-mantissa)
;					       mantissa-byte-width))
;		    (new-expt (+ exponent mantissa-byte-width))
;		    (new-mant (hw:dpb-unboxed frac-int
;					      (byte mantissa-byte-width mantissa-byte-position)
;					      (hw:unboxed-constant 0))))
;	       (truncate-fix-sign int-mantissa
;				  (array:make-single-float
;				    (hw:dpb-unboxed (+ new-expt hw:$$short-float-exponent-excess)
;						    hw:short-float-exponent new-mant))
;				  sign) ))
;	    (t ;;;all the bits are fraction so the argument is the remainder
;	     (values 0 float)) )))
;  )