diff --git a/code/format.lisp b/code/format.lisp index 7096bd923927deebc02bdde4100cb42b20a782f7..c686c13646a59899cf9db0d0a04f15ec3f204555 100644 --- a/code/format.lisp +++ b/code/format.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/format.lisp,v 1.74 2007/10/09 16:45:07 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/format.lisp,v 1.75 2007/10/09 17:05:02 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1283,104 +1283,104 @@ (prin1 number stream) ;;(multiple-value-bind (num expt) ;; (lisp::scale-exponent (abs number)) - (multiple-value-bind (expt) - (accurate-scale-exponent (abs number)) - (let* ((expt (- expt k)) - (estr (decimal-string (abs expt))) - (elen (if e (max (length estr) e) (length estr))) - (add-zero-p nil)) - (if (and w ovf e (> elen e)) ;exponent overflow - (dotimes (i w) - (write-char ovf stream)) - ;; The hairy case - (let* ((fdig (if d (if (plusp k) (1+ (- d k)) d) nil)) - (fmin (if (<= k 0) - (if d (+ d k -1) (- k)) - nil)) - (spaceleft (if w - (- w 2 elen - (if (or atsign (minusp (float-sign number))) - 1 0)) - nil))) + (let* ((expt (if (zerop number) + 0 + (- (accurate-scale-exponent (abs number)) k))) + (estr (decimal-string (abs expt))) + (elen (if e (max (length estr) e) (length estr))) + (add-zero-p nil)) + (if (and w ovf e (> elen e)) ;exponent overflow + (dotimes (i w) + (write-char ovf stream)) + ;; The hairy case + (let* ((fdig (if d (if (plusp k) (1+ (- d k)) d) nil)) + (fmin (if (<= k 0) + (if d (+ d k -1) (- k)) + nil)) + (spaceleft (if w + (- w 2 elen + (if (or atsign (minusp (float-sign number))) + 1 0)) + nil))) + #+(or) + (progn + (format t "fdig = ~A~%" fdig) + (format t "fmin = ~A~%" fmin) + (format t "spaceleft = ~A~%" spaceleft) + (format t "expt = ~S~%" expt)) + + ;; 1 extra for spaceleft so (format nil "~9,,,-1E" pi) will + ;; produce ".03142d+2" instead of "0.0314d+2". + ;; + ;; For fdig, use the larger of fdig and expt so that we'll + ;; always get at least one digit, even if the scale factor + ;; would have shifted all significant bits out. + (multiple-value-bind (fstr flen lpoint tpoint) + (lisp::flonum-to-string (abs number) + (if spaceleft (1+ spaceleft)) + (if fdig + (max fdig expt)) + (- expt) + fmin) #+(or) (progn - (format t "fdig = ~A~%" fdig) - (format t "fmin = ~A~%" fmin) - (format t "spaceleft = ~A~%" spaceleft) - (format t "expt = ~S~%" expt)) - - ;; 1 extra for spaceleft so (format nil "~9,,,-1E" pi) will - ;; produce ".03142d+2" instead of "0.0314d+2". - ;; - ;; For fdig, use the larger of fdig and expt so that we'll - ;; always get at least one digit, even if the scale factor - ;; would have shifted all significant bits out. - (multiple-value-bind (fstr flen lpoint tpoint) - (lisp::flonum-to-string (abs number) - (if spaceleft (1+ spaceleft)) - (if fdig - (max fdig expt)) - (- expt) - fmin) - #+(or) - (progn - (format t "fstr = ~S~%" fstr) - (format t "flen = ~S~%" flen) - (format t "lp = ~S~%" lpoint) - (format t "tp = ~S~%" tpoint)) - - (when (and d (zerop d)) (setq tpoint nil)) - (when w - (decf spaceleft flen) - ;; See CLHS 22.3.3.2. "If the parameter d is - ;; omitted, ... [and] if the fraction to be - ;; printed is zero then a single zero digit should - ;; appear after the decimal point." So we need to - ;; subtract one from here because we're going to - ;; add an extra 0 digit later. - (when (and (null d) (char= (aref fstr (1- flen)) #\.)) - (setf add-zero-p t) - (decf spaceleft)) - (when lpoint - (if (or (> spaceleft 0) tpoint) - (decf spaceleft) - (setq lpoint nil))) - (when (and tpoint (<= spaceleft 0)) - (setq tpoint nil))) - (cond ((and w (< spaceleft 0) ovf) - ;;significand overflow - (dotimes (i w) (write-char ovf stream))) - (t (when w - (dotimes (i spaceleft) - (write-char pad stream))) - (if (minusp (float-sign number)) - (write-char #\- stream) - (if atsign (write-char #\+ stream))) - (when lpoint (write-char #\0 stream)) - (write-string fstr stream) - ;; Add a zero if we need it. Which means - ;; we figured out we need one above, or - ;; another condition. Basically, append a - ;; zero if there are no width constraints - ;; and if the last char to print was a - ;; decimal (so the trailing fraction is - ;; zero.) - (when (or add-zero-p - (and (null w) - (char= (aref fstr (1- flen)) #\.))) - ;; It's later and we're adding the zero - ;; digit. - (write-char #\0 stream)) - (write-char (if marker - marker - (format-exponent-marker number)) - stream) - (write-char (if (minusp expt) #\- #\+) stream) - (when e - ;;zero-fill before exponent if necessary - (dotimes (i (- e (length estr))) - (write-char #\0 stream))) - (write-string estr stream))))))))) + (format t "fstr = ~S~%" fstr) + (format t "flen = ~S~%" flen) + (format t "lp = ~S~%" lpoint) + (format t "tp = ~S~%" tpoint)) + + (when (and d (zerop d)) (setq tpoint nil)) + (when w + (decf spaceleft flen) + ;; See CLHS 22.3.3.2. "If the parameter d is + ;; omitted, ... [and] if the fraction to be + ;; printed is zero then a single zero digit should + ;; appear after the decimal point." So we need to + ;; subtract one from here because we're going to + ;; add an extra 0 digit later. + (when (and (null d) (char= (aref fstr (1- flen)) #\.)) + (setf add-zero-p t) + (decf spaceleft)) + (when lpoint + (if (or (> spaceleft 0) tpoint) + (decf spaceleft) + (setq lpoint nil))) + (when (and tpoint (<= spaceleft 0)) + (setq tpoint nil))) + (cond ((and w (< spaceleft 0) ovf) + ;;significand overflow + (dotimes (i w) (write-char ovf stream))) + (t (when w + (dotimes (i spaceleft) + (write-char pad stream))) + (if (minusp (float-sign number)) + (write-char #\- stream) + (if atsign (write-char #\+ stream))) + (when lpoint (write-char #\0 stream)) + (write-string fstr stream) + ;; Add a zero if we need it. Which means + ;; we figured out we need one above, or + ;; another condition. Basically, append a + ;; zero if there are no width constraints + ;; and if the last char to print was a + ;; decimal (so the trailing fraction is + ;; zero.) + (when (or add-zero-p + (and (null w) + (char= (aref fstr (1- flen)) #\.))) + ;; It's later and we're adding the zero + ;; digit. + (write-char #\0 stream)) + (write-char (if marker + marker + (format-exponent-marker number)) + stream) + (write-char (if (minusp expt) #\- #\+) stream) + (when e + ;;zero-fill before exponent if necessary + (dotimes (i (- e (length estr))) + (write-char #\0 stream))) + (write-string estr stream)))))))) (values)) (def-format-directive #\G (colonp atsignp params)