From b6fc996c0489e56851d2914924c5aaec6d93a8fe Mon Sep 17 00:00:00 2001 From: rtoy <rtoy> Date: Fri, 27 Aug 2004 12:25:02 +0000 Subject: [PATCH] PRIN1 and "~F" sometimes produces different printed results due to differences in rounding for the range of numbers where PRIN1 uses the same style of output as ~F. This is due to how PRIN1 uses FLONUM-TO-DIGITS to produce the result, but ~F was using FLOAT-STRING. Hack it so FLONUM-TO-STRING calls FLONUM-TO-DIGITS when possible. --- code/print.lisp | 31 ++++++++++++++++++++++++++++++- 1 file changed, 30 insertions(+), 1 deletion(-) diff --git a/code/print.lisp b/code/print.lisp index b9c4c9d10..0a9ac33e8 100644 --- a/code/print.lisp +++ b/code/print.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/print.lisp,v 1.95 2004/08/27 03:08:56 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.96 2004/08/27 12:25:02 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1433,6 +1433,35 @@ radix-R. If you have a power-list then pass it in as PL." (setf (schar s 0) #\.) (values s (length s) t (zerop fdigits) 0)) (values "." 1 t t 0))) + ((not (or width fdigits scale fmin)) + ;; This is a hacky way to make ~f produce the same results as + ;; prin1 for the range of numbers where prin1 and ~f should + ;; agree. + (multiple-value-bind (e string) + (flonum-to-digits x) + (let* ((len (length string)) + (lpoint (not (plusp e))) + (tpoint (>= e len)) + (slen (+ 1 (if (> e len) + e + (+ len (max 0 (- e)))))) + (s (make-string slen))) + (cond ((minusp e) + (setf (aref s 0) #\.) + (fill s #\0 :start 1 :end (1+ (- e))) + (replace s string :start1 (1+ (- e)))) + (lpoint + (setf (aref s 0) #\.) + (replace s string :start1 1)) + (tpoint + (replace s string) + (fill s #\0 :start len :end e) + (setf (aref s e) #\.)) + (t + (replace s string :end2 e) + (replace s string :start1 (1+ e) :start2 e) + (setf (aref s e) #\.))) + (values s slen lpoint tpoint (max 0 e))))) (t (multiple-value-bind (sig exp) (integer-decode-float x) -- GitLab