Update of /project/oct/cvsroot/oct In directory clnet:/tmp/cvs-serv23423
Modified Files: qd.lisp Log Message: Redo implementation of INTEGER-DECODE-QD. It used to return way too many digits if one of the components was 0. This causes problems because the resulting integer can't even be coerced back to a quad-double.
--- /project/oct/cvsroot/oct/qd.lisp 2007/09/18 11:20:16 1.54 +++ /project/oct/cvsroot/oct/qd.lisp 2007/10/13 15:34:51 1.55 @@ -1064,6 +1064,7 @@ lo-exp sign)))))
+#+(or) (defun integer-decode-qd (q) (declare (type %quad-double q)) ;; Integer decode each component and then create the appropriate @@ -1093,6 +1094,63 @@ q3-exp q0-sign))))))
+#+(or) +(defun integer-decode-qd (q) + (declare (type %quad-double q)) + ;; Integer decode each component and then create the appropriate + ;; integer by shifting and adding all the parts together. If any + ;; component is zero, we stop. + (multiple-value-bind (q0-int q0-exp q0-sign) + (integer-decode-float (qd-0 q)) + (if (zerop (qd-1 q)) + (values q0-int q0-exp q0-sign) + (multiple-value-bind (q1-int q1-exp q1-sign) + (integer-decode-float (qd-1 q)) + (setf q0-int (+ (ash q0-int (- q0-exp q1-exp)) + (* q1-sign q1-int))) + (if (zerop (qd-2 q)) + (values q0-int q1-exp q0-sign) + (multiple-value-bind (q2-int q2-exp q2-sign) + (integer-decode-float (qd-2 q)) + (setf q0-int (+ (ash q0-int (- q1-exp q2-exp)) + (* q2-sign q2-int))) + (if (zerop (qd-3 q)) + (values q0-int q2-exp q0-sign) + (multiple-value-bind (q3-int q3-exp q3-sign) + (integer-decode-float (qd-3 q)) + (values (+ (ash q0-int (- q2-exp q3-exp)) + (* q3-sign q3-int)) + q3-exp + q0-sign))))))))) + +(defun integer-decode-qd (q) + (declare (type %quad-double q)) + ;; Integer decode each component and then create the appropriate + ;; integer by shifting and adding all the parts together. If any + ;; component is zero, we stop. + (multiple-value-bind (q0-int q0-exp q0-sign) + (integer-decode-float (qd-0 q)) + (when (zerop (qd-1 q)) + (return-from integer-decode-qd (values q0-int q0-exp q0-sign))) + (multiple-value-bind (q1-int q1-exp q1-sign) + (integer-decode-float (qd-1 q)) + (setf q0-int (+ (ash q0-int (- q0-exp q1-exp)) + (* q1-sign q1-int))) + (when (zerop (qd-2 q)) + (return-from integer-decode-qd (values q0-int q1-exp q0-sign))) + (multiple-value-bind (q2-int q2-exp q2-sign) + (integer-decode-float (qd-2 q)) + (setf q0-int (+ (ash q0-int (- q1-exp q2-exp)) + (* q2-sign q2-int))) + (when (zerop (qd-3 q)) + (return-from integer-decode-qd (values q0-int q2-exp q0-sign))) + (multiple-value-bind (q3-int q3-exp q3-sign) + (integer-decode-float (qd-3 q)) + (values (+ (ash q0-int (- q2-exp q3-exp)) + (* q3-sign q3-int)) + q3-exp + q0-sign)))))) + (declaim (inline scale-float-qd)) #+(or) (defun scale-float-qd (qd k)