diff --git a/code/print.lisp b/code/print.lisp index 94cea153bbac81adadb66466f83bd98251ed2039..6b0792ee663ecc013bb575d8c3c3a15286de5ed2 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.81 2001/06/11 13:48:02 pmai Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/print.lisp,v 1.82 2002/01/18 19:45:49 pmai Exp $") ;;; ;;; ********************************************************************** ;;; @@ -529,8 +529,6 @@ (output-float object stream)) (ratio (output-ratio object stream)) - (ratio - (output-ratio object stream)) (complex (output-complex object stream)))) (character @@ -1649,6 +1647,7 @@ ;;; ;;; Functioned called by OUTPUT-OBJECT to handle floats. ;;; + (defun output-float (x stream) (cond ((float-infinity-p x) @@ -1666,10 +1665,34 @@ (write-string "0.0" stream) (print-float-exponent x 0 stream)) (t - (output-float-aux x stream (float 1/1000 x) (float 10000000 x)))))))) -;;; -(defun output-float-aux (x stream e-min e-max) - (if (and (>= x e-min) (< x e-max)) + (output-float-aux x stream))))))) + +(defconstant output-float-free-format-min 1/1000 + "Minimum magnitute that allows the float printer to use free format, + instead of exponential format. See section 22.1.3.1.3: Printing Floats + in the ANSI CL standard.") +(defconstant output-float-free-format-max 10000000 + "Maximum magnitute that allows the float printer to use free format, + instead of exponential format. See section 22.1.3.1.3: Printing Floats + in the ANSI CL standard.") + +(defmacro output-float-free-format-p (x) + "Returns true if x can be printed in free format, as per ANSI CL." + (loop with x-var = (gensym) + for type in '(short-float single-float double-float long-float) + collect + `(,type + (and (>= ,x-var ,(coerce output-float-free-format-min type)) + (< ,x-var ,(coerce output-float-free-format-max type)))) + into clauses + finally + (return + `(let ((,x-var ,x)) + (etypecase ,x-var + ,@clauses))))) + +(defun output-float-aux (x stream) + (if (output-float-free-format-p x) ;;free format (multiple-value-bind (str len lpoint tpoint) (flonum-to-string x)