(defvar *print-readably* nil
#!+sb-doc
- "If true, all objects will printed readably. If readable printing is
- impossible, an error will be signalled. This overrides the value of
+ "If true, all objects will be printed readably. If readable printing
+ is impossible, an error will be signalled. This overrides the value of
*PRINT-ESCAPE*.")
(defvar *print-escape* t
#!+sb-doc
"Should pretty printing be used?")
(defvar *print-base* 10.
#!+sb-doc
- "the output base for RATIONALs (including integers)")
+ "The output base for RATIONALs (including integers).")
(defvar *print-radix* nil
#!+sb-doc
"Should base be verified when printing RATIONALs?")
"Should #: prefixes be used when printing symbols with null SYMBOL-PACKAGE?")
(defvar *print-lines* nil
#!+sb-doc
- "the maximum number of lines to print per object")
+ "The maximum number of lines to print per object.")
(defvar *print-right-margin* nil
#!+sb-doc
- "the position of the right margin in ems (for pretty-printing)")
+ "The position of the right margin in ems (for pretty-printing).")
(defvar *print-miser-width* nil
#!+sb-doc
"If the remaining space between the current column and the right margin
(defvar *print-pprint-dispatch*)
#!+sb-doc
(setf (fdocumentation '*print-pprint-dispatch* 'variable)
- "the pprint-dispatch-table that controls how to pretty-print objects")
+ "The pprint-dispatch-table that controls how to pretty-print objects.")
(defmacro with-standard-io-syntax (&body body)
#!+sb-doc
*PRINT-LEVEL* NIL
*PRINT-LINES* NIL
*PRINT-MISER-WIDTH* NIL
+ *PRINT-PPRINT-DISPATCH* the standard pprint dispatch table
*PRINT-PRETTY* NIL
*PRINT-RADIX* NIL
*PRINT-READABLY* T
(*print-level* nil)
(*print-lines* nil)
(*print-miser-width* nil)
+ (*print-pprint-dispatch* sb!pretty::*standard-pprint-dispatch-table*)
(*print-pretty* nil)
(*print-radix* nil)
(*print-readably* t)
(*read-default-float-format* 'single-float)
(*read-eval* t)
(*read-suppress* nil)
- ;; FIXME: It doesn't seem like a good idea to expose our
- ;; disaster-recovery *STANDARD-READTABLE* here. What if some
- ;; enterprising user corrupts the disaster-recovery readtable
- ;; by doing destructive readtable operations within
- ;; WITH-STANDARD-IO-SYNTAX? Perhaps we should do a
- ;; COPY-READTABLE? The consing would be unfortunate, though.
(*readtable* *standard-readtable*))
(funcall function)))
\f
;;;; routines to print objects
+\f
+;;; keyword variables shared by WRITE and WRITE-TO-STRING, and
+;;; the bindings they map to.
+(eval-when (:compile-toplevel :load-toplevel)
+ (defvar *printer-keyword-variables*
+ '(:escape *print-escape*
+ :radix *print-radix*
+ :base *print-base*
+ :circle *print-circle*
+ :pretty *print-pretty*
+ :level *print-level*
+ :length *print-length*
+ :case *print-case*
+ :array *print-array*
+ :gensym *print-gensym*
+ :readably *print-readably*
+ :right-margin *print-right-margin*
+ :miser-width *print-miser-width*
+ :lines *print-lines*
+ :pprint-dispatch *print-pprint-dispatch*)))
+
(defun write (object &key
((:stream stream) *standard-output*)
((:escape *print-escape*) *print-escape*)
((:pprint-dispatch *print-pprint-dispatch*)
*print-pprint-dispatch*))
#!+sb-doc
- "Output OBJECT to the specified stream, defaulting to *STANDARD-OUTPUT*"
+ "Output OBJECT to the specified stream, defaulting to *STANDARD-OUTPUT*."
(output-object object (out-synonym-of stream))
object)
+;;; Optimize common case of constant keyword arguments
+(define-compiler-macro write (&whole form object &rest keys)
+ (let (bind ignore)
+ (do ()
+ ((not (cdr keys))
+ ;; Odd number of keys, punt
+ (when keys
+ (return-from write form)))
+ (let* ((key (pop keys))
+ (value (pop keys))
+ (variable (or (getf *printer-keyword-variables* key)
+ (when (eq :stream key)
+ 'stream)
+ (return-from write form))))
+ (when (assoc variable bind)
+ ;; First key has precedence, but we still need to execute the
+ ;; argument, and in the right order.
+ (setf variable (gensym "IGNORE"))
+ (push variable ignore))
+ (push (list variable value) bind)))
+ (unless (assoc 'stream bind)
+ (push (list 'stream '*standard-output*) bind))
+ (once-only ((object object))
+ `(let ,(nreverse bind)
+ ,@(when ignore `((declare (ignore ,@ignore))))
+ (output-object ,object (out-synonym-of stream))
+ ,object))))
+
(defun prin1 (object &optional stream)
#!+sb-doc
"Output a mostly READable printed representation of OBJECT on the specified
(values))
(defun write-to-string
- (object &key
- ((:escape *print-escape*) *print-escape*)
- ((:radix *print-radix*) *print-radix*)
- ((:base *print-base*) *print-base*)
- ((:circle *print-circle*) *print-circle*)
- ((:pretty *print-pretty*) *print-pretty*)
- ((:level *print-level*) *print-level*)
- ((:length *print-length*) *print-length*)
- ((:case *print-case*) *print-case*)
- ((:array *print-array*) *print-array*)
- ((:gensym *print-gensym*) *print-gensym*)
- ((:readably *print-readably*) *print-readably*)
- ((:right-margin *print-right-margin*) *print-right-margin*)
- ((:miser-width *print-miser-width*) *print-miser-width*)
- ((:lines *print-lines*) *print-lines*)
- ((:pprint-dispatch *print-pprint-dispatch*)
- *print-pprint-dispatch*))
+ (object &key
+ ((:escape *print-escape*) *print-escape*)
+ ((:radix *print-radix*) *print-radix*)
+ ((:base *print-base*) *print-base*)
+ ((:circle *print-circle*) *print-circle*)
+ ((:pretty *print-pretty*) *print-pretty*)
+ ((:level *print-level*) *print-level*)
+ ((:length *print-length*) *print-length*)
+ ((:case *print-case*) *print-case*)
+ ((:array *print-array*) *print-array*)
+ ((:gensym *print-gensym*) *print-gensym*)
+ ((:readably *print-readably*) *print-readably*)
+ ((:right-margin *print-right-margin*) *print-right-margin*)
+ ((:miser-width *print-miser-width*) *print-miser-width*)
+ ((:lines *print-lines*) *print-lines*)
+ ((:pprint-dispatch *print-pprint-dispatch*)
+ *print-pprint-dispatch*))
#!+sb-doc
"Return the printed representation of OBJECT as a string."
(stringify-object object))
+;;; Optimize common case of constant keyword arguments
+(define-compiler-macro write-to-string (&whole form object &rest keys)
+ (let (bind ignore)
+ (do ()
+ ((not (cdr keys))
+ ;; Odd number of keys, punt
+ (when keys
+ (return-from write-to-string form)))
+ (let* ((key (pop keys))
+ (value (pop keys))
+ (variable (or (getf *printer-keyword-variables* key)
+ (return-from write-to-string form))))
+ (when (assoc variable bind)
+ ;; First key has precedence, but we still need to execute the
+ ;; argument, and in the right order.
+ (setf variable (gensym "IGNORE"))
+ (push variable ignore))
+ (push (list variable value) bind)))
+ (if bind
+ (once-only ((object object))
+ `(let ,(nreverse bind)
+ ,@(when ignore `((declare (ignore ,@ignore))))
+ (stringify-object ,object)))
+ `(stringify-object ,object))))
+
(defun prin1-to-string (object)
#!+sb-doc
"Return the printed representation of OBJECT as a string with
\f
;;;; support for the PRINT-UNREADABLE-OBJECT macro
+(defun read-unreadable-replacement ()
+ (format *query-io* "~@<Enter an object (evaluated): ~@:>")
+ (finish-output *query-io*)
+ (list (eval (read *query-io*))))
+
;;; guts of PRINT-UNREADABLE-OBJECT
(defun %print-unreadable-object (object stream type identity body)
(declare (type (or null function) body))
(when *print-readably*
- (error 'print-not-readable :object object))
+ (restart-case
+ (error 'print-not-readable :object object)
+ (print-unreadably ()
+ :report "Print unreadably.")
+ (use-value (o)
+ :report "Supply an object to be printed instead."
+ :interactive read-unreadable-replacement
+ (write o :stream stream)
+ (return-from %print-unreadable-object nil))))
(flet ((print-description ()
(when type
(write (type-of object) :stream stream :circle nil
:level nil :length nil)
- (write-char #\space stream))
+ (write-char #\space stream)
+ (pprint-newline :fill stream))
(when body
(funcall body))
(when identity
(when (or body (not type))
(write-char #\space stream))
+ (pprint-newline :fill stream)
(write-char #\{ stream)
(write (get-lisp-obj-address object) :stream stream
:radix nil :base 16)
(pprint-logical-block (stream nil :prefix "#<" :suffix ">")
(print-description)))
(t
- (write-string "#<" stream)
- (print-description)
- (write-char #\> stream))))
+ (write-string "#<" stream)
+ (print-description)
+ (write-char #\> stream))))
nil)
\f
;;;; OUTPUT-OBJECT -- the main entry point
(default-structure-print object stream *current-level-in-print*))
(t
(write-string "#<INSTANCE but not STRUCTURE-OBJECT>" stream))))
+ (funcallable-instance
+ (cond
+ ((not (and (boundp '*print-object-is-disabled-p*)
+ *print-object-is-disabled-p*))
+ (print-object object stream))
+ (t (output-fun object stream))))
(function
- (unless (and (funcallable-instance-p object)
- (printed-as-funcallable-standard-class object stream))
- (output-fun object stream)))
+ (output-fun object stream))
(symbol
(output-symbol object stream))
(number
(output-float object stream))
(ratio
(output-ratio object stream))
- (ratio
- (output-ratio object stream))
(complex
(output-complex object stream))))
(character
(load-time-value
(array-element-type
(make-array 0 :element-type 'character))))))
- (error 'print-not-readable :object vector))
+ (restart-case
+ (error 'print-not-readable :object vector)
+ (print-unreadably ()
+ :report "Print unreadably."
+ (let ((*print-readably* nil))
+ (output-vector vector stream)))
+ (use-value (o)
+ :report "Supply an object to be printed instead."
+ :interactive read-unreadable-replacement
+ (write o :stream stream))))
((or *print-escape* *print-readably*)
(write-char #\" stream)
(quote-string vector stream)
(t
(when (and *print-readably*
(not (array-readably-printable-p vector)))
- (error 'print-not-readable :object vector))
+ (restart-case
+ (error 'print-not-readable :object vector)
+ (print-unreadably ()
+ :report "Print unreadably.")
+ (use-value (o)
+ :report "Supply an object to be printed instead."
+ :interactive read-unreadable-replacement
+ (return-from output-vector (write o :stream stream)))))
(descend-into (stream)
(write-string "#(" stream)
(dotimes (i (length vector))
;; this for now. [noted by anonymous long ago] -- WHN 19991130
`(or (char= ,char #\\)
(char= ,char #\"))))
- (with-array-data ((data string) (start) (end (length string)))
+ (with-array-data ((data string) (start) (end)
+ :check-fill-pointer t)
(do ((index start (1+ index)))
((>= index end))
(let ((char (schar data index)))
(defun output-array-guts (array stream)
(when (and *print-readably*
(not (array-readably-printable-p array)))
- (error 'print-not-readable :object array))
+ (restart-case
+ (error 'print-not-readable :object array)
+ (print-unreadably ()
+ :report "Print unreadably.")
+ (use-value (o)
+ :report "Supply an object to be printed instead."
+ :interactive read-unreadable-replacement
+ (return-from output-array-guts (write o :stream stream)))))
(write-char #\# stream)
(let ((*print-base* 10)
(*print-radix* nil))
(2 #\b)
(8 #\o)
(16 #\x)
- (t (%output-fixnum-in-base base 10 stream)
+ (t (%output-reasonable-integer-in-base base 10 stream)
#\r))
stream))
-(defun %output-fixnum-in-base (n base stream)
+(defun %output-reasonable-integer-in-base (n base stream)
(multiple-value-bind (q r)
(truncate n base)
;; Recurse until you have all the digits pushed on
;; the stack.
(unless (zerop q)
- (%output-fixnum-in-base q base stream))
+ (%output-reasonable-integer-in-base q base stream))
;; Then as each recursive call unwinds, turn the
;; digit (in remainder) into a character and output
;; the character.
(schar "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" r)
stream)))
+;;; *POWER-CACHE* is an alist mapping bases to power-vectors. It is
+;;; filled and probed by POWERS-FOR-BASE. SCRUB-POWER-CACHE is called
+;;; always prior a GC to drop overly large bignums from the cache.
+;;;
+;;; It doesn't need a lock, but if you work on SCRUB-POWER-CACHE or
+;;; POWERS-FOR-BASE, see that you don't break the assumptions!
+(defvar *power-cache* nil)
+
+(defconstant +power-cache-integer-length-limit+ 2048)
+
+(defun scrub-power-cache ()
+ (let ((cache *power-cache*))
+ (dolist (cell cache)
+ (let ((powers (cdr cell)))
+ (declare (simple-vector powers))
+ (let ((too-big (position-if
+ (lambda (x)
+ (>= (integer-length x)
+ +power-cache-integer-length-limit+))
+ powers)))
+ (when too-big
+ (setf (cdr cell) (subseq powers 0 too-big))))))
+ ;; Since base 10 is overwhelmingly common, make sure it's at head.
+ ;; Try to keep other bases in a hopefully sensible order as well.
+ (if (eql 10 (caar cache))
+ (setf *power-cache* cache)
+ ;; If we modify the list destructively we need to copy it, otherwise
+ ;; an alist lookup in progress might be screwed.
+ (setf *power-cache* (sort (copy-list cache)
+ (lambda (a b)
+ (declare (fixnum a b))
+ (cond ((= 10 a) t)
+ ((= 10 b) nil)
+ ((= 16 a) t)
+ ((= 16 b) nil)
+ ((= 2 a) t)
+ ((= 2 b) nil)
+ (t (< a b))))
+ :key #'car)))))
+
+;;; Compute (and cache) a power vector for a BASE and LIMIT:
+;;; the vector holds integers for which
+;;; (aref powers k) == (expt base (expt 2 k))
+;;; holds.
+(defun powers-for-base (base limit)
+ (flet ((compute-powers (from)
+ (let (powers)
+ (do ((p from (* p p)))
+ ((> p limit)
+ ;; We don't actually need this, but we also
+ ;; prefer not to cons it up a second time...
+ (push p powers))
+ (push p powers))
+ (nreverse powers))))
+ ;; Grab a local reference so that we won't stuff consed at the
+ ;; head by other threads -- or sorting by SCRUB-POWER-CACHE.
+ (let ((cache *power-cache*))
+ (let ((cell (assoc base cache)))
+ (if cell
+ (let* ((powers (cdr cell))
+ (len (length powers))
+ (max (svref powers (1- len))))
+ (if (> max limit)
+ powers
+ (let ((new
+ (concatenate 'vector powers
+ (compute-powers (* max max)))))
+ (setf (cdr cell) new)
+ new)))
+ (let ((powers (coerce (compute-powers base) 'vector)))
+ ;; Add new base to head: SCRUB-POWER-CACHE will later
+ ;; put it to a better place.
+ (setf *power-cache* (acons base powers cache))
+ powers))))))
+
;; Algorithm by Harald Hanche-Olsen, sbcl-devel 2005-02-05
-(defun %output-bignum-in-base (n base stream)
+(defun %output-huge-integer-in-base (n base stream)
(declare (type bignum n) (type fixnum base))
- (let ((power (make-array 10 :adjustable t :fill-pointer 0)))
- ;; Here there be the bottleneck for big bignums, in the (* p p).
- ;; A special purpose SQUARE-BIGNUM might help a bit. See eg: Dan
- ;; Zuras, "On Squaring and Multiplying Large Integers", ARITH-11:
- ;; IEEE Symposium on Computer Arithmetic, 1993, pp. 260 to 271.
- ;; Reprinted as "More on Multiplying and Squaring Large Integers",
- ;; IEEE Transactions on Computers, volume 43, number 8, August
- ;; 1994, pp. 899-908.
- (do ((p base (* p p)))
- ((> p n))
- (vector-push-extend p power))
- ;; (aref power k) == (expt base (expt 2 k))
+ ;; POWER is a vector for which the following holds:
+ ;; (aref power k) == (expt base (expt 2 k))
+ (let* ((power (powers-for-base base n))
+ (k-start (or (position-if (lambda (x) (> x n)) power)
+ (bug "power-vector too short"))))
(labels ((bisect (n k exactp)
(declare (fixnum k))
;; N is the number to bisect
;; doesn't get any leading zeros.
(bisect q k exactp)
(bisect r k (or exactp (plusp q))))))))
- (bisect n (fill-pointer power) nil))))
+ (bisect n k-start nil))))
(defun %output-integer-in-base (integer base stream)
(when (minusp integer)
(write-char #\- stream)
(setf integer (- integer)))
- (if (fixnump integer)
- (%output-fixnum-in-base integer base stream)
- (%output-bignum-in-base integer base stream)))
+ ;; The ideal cutoff point between these two algorithms is almost
+ ;; certainly quite platform dependent: this gives 87 for 32 bit
+ ;; SBCL, which is about right at least for x86/Darwin.
+ (if (or (fixnump integer)
+ (< (integer-length integer) (* 3 sb!vm:n-positive-fixnum-bits)))
+ (%output-reasonable-integer-in-base integer base stream)
+ (%output-huge-integer-in-base integer base stream)))
(defun output-integer (integer stream)
(let ((base *print-base*))
;; FIXME: I think only FORMAT-DOLLARS calls FLONUM-TO-STRING with
;; possibly-negative X.
(setf x (abs x))
- (cond ((zerop x)
- ;; Zero is a special case which FLOAT-STRING cannot handle.
- (if fdigits
- (let ((s (make-string (1+ fdigits) :initial-element #\0)))
- (setf (schar s 0) #\.)
- (values s (length s) t (zerop fdigits) 0))
- (values "." 1 t t 0)))
- (t
- (multiple-value-bind (e string)
- (if fdigits
- (flonum-to-digits x (min (- fdigits) (- (or fmin 0))))
- (if (and width (> width 1))
- (let ((w (multiple-value-list (flonum-to-digits x (1- width) t)))
- (f (multiple-value-list (flonum-to-digits x (- (or fmin 0))))))
- (cond
- ((>= (length (cadr w)) (length (cadr f)))
- (values-list w))
- (t (values-list f))))
- (flonum-to-digits x)))
- (let ((e (+ e (or scale 0)))
- (stream (make-string-output-stream)))
- (if (plusp e)
- (progn
- (write-string string stream :end (min (length string) e))
- (dotimes (i (- e (length string)))
- (write-char #\0 stream))
- (write-char #\. stream)
- (write-string string stream :start (min (length string) e))
- (when fdigits
- (dotimes (i (- fdigits
- (- (length string)
- (min (length string) e))))
- (write-char #\0 stream))))
- (progn
- (write-string "." stream)
- (dotimes (i (- e))
- (write-char #\0 stream))
- (write-string string stream)
- (when fdigits
- (dotimes (i (+ fdigits e (- (length string))))
- (write-char #\0 stream)))))
- (let ((string (get-output-stream-string stream)))
- (values string (length string)
- (char= (char string 0) #\.)
- (char= (char string (1- (length string))) #\.)
- (position #\. string))))))))
-
-;;; implementation of figure 1 from Burger and Dybvig, 1996. As the
-;;; implementation of the Dragon from Classic CMUCL (and previously in
-;;; SBCL above FLONUM-TO-STRING) says: "DO NOT EVEN THINK OF
-;;; ATTEMPTING TO UNDERSTAND THIS CODE WITHOUT READING THE PAPER!",
-;;; and in this case we have to add that even reading the paper might
-;;; not bring immediate illumination as CSR has attempted to turn
-;;; idiomatic Scheme into idiomatic Lisp.
+ (multiple-value-bind (e string)
+ (if fdigits
+ (flonum-to-digits x (min (- (+ fdigits (or scale 0)))
+ (- (or fmin 0))))
+ (if (and width (> width 1))
+ (let ((w (multiple-value-list
+ (flonum-to-digits x
+ (max 1
+ (+ (1- width)
+ (if (and scale (minusp scale))
+ scale 0)))
+ t)))
+ (f (multiple-value-list
+ (flonum-to-digits x (- (+ (or fmin 0)
+ (if scale scale 0)))))))
+ (cond
+ ((>= (length (cadr w)) (length (cadr f)))
+ (values-list w))
+ (t (values-list f))))
+ (flonum-to-digits x)))
+ (let ((e (if (zerop x)
+ e
+ (+ e (or scale 0))))
+ (stream (make-string-output-stream)))
+ (if (plusp e)
+ (progn
+ (write-string string stream :end (min (length string) e))
+ (dotimes (i (- e (length string)))
+ (write-char #\0 stream))
+ (write-char #\. stream)
+ (write-string string stream :start (min (length string) e))
+ (when fdigits
+ (dotimes (i (- fdigits
+ (- (length string)
+ (min (length string) e))))
+ (write-char #\0 stream))))
+ (progn
+ (write-string "." stream)
+ (dotimes (i (- e))
+ (write-char #\0 stream))
+ (write-string string stream :end (when fdigits
+ (min (length string)
+ (max (or fmin 0)
+ (+ fdigits e)))))
+ (when fdigits
+ (dotimes (i (+ fdigits e (- (length string))))
+ (write-char #\0 stream)))))
+ (let ((string (get-output-stream-string stream)))
+ (values string (length string)
+ (char= (char string 0) #\.)
+ (char= (char string (1- (length string))) #\.)
+ (position #\. string))))))
+
+;;; implementation of figure 1 from Burger and Dybvig, 1996. It is
+;;; extended in order to handle rounding.
+;;;
+;;; As the implementation of the Dragon from Classic CMUCL (and
+;;; previously in SBCL above FLONUM-TO-STRING) says: "DO NOT EVEN
+;;; THINK OF ATTEMPTING TO UNDERSTAND THIS CODE WITHOUT READING THE
+;;; PAPER!", and in this case we have to add that even reading the
+;;; paper might not bring immediate illumination as CSR has attempted
+;;; to turn idiomatic Scheme into idiomatic Lisp.
;;;
;;; FIXME: figure 1 from Burger and Dybvig is the unoptimized
;;; algorithm, noticeably slow at finding the exponent. Figure 2 has
;;; possible extension for the enthusiastic: printing floats in bases
;;; other than base 10.
(defconstant single-float-min-e
- (nth-value 1 (decode-float least-positive-single-float)))
+ (- 2 sb!vm:single-float-bias sb!vm:single-float-digits))
(defconstant double-float-min-e
- (nth-value 1 (decode-float least-positive-double-float)))
+ (- 2 sb!vm:double-float-bias sb!vm:double-float-digits))
#!+long-float
(defconstant long-float-min-e
(nth-value 1 (decode-float least-positive-long-float)))
(let (;; FIXME: these even tests assume normal IEEE rounding
;; mode. I wonder if we should cater for non-normal?
(high-ok (evenp f))
- (low-ok (evenp f))
- (result (make-array 50 :element-type 'base-char
- :fill-pointer 0 :adjustable t)))
- (labels ((scale (r s m+ m-)
- (do ((k 0 (1+ k))
- (s s (* s print-base)))
- ((not (or (> (+ r m+) s)
- (and high-ok (= (+ r m+) s))))
- (do ((k k (1- k))
- (r r (* r print-base))
- (m+ m+ (* m+ print-base))
- (m- m- (* m- print-base)))
- ((not (or (< (* (+ r m+) print-base) s)
- (and (not high-ok)
- (= (* (+ r m+) print-base) s))))
- (values k (generate r s m+ m-)))))))
- (generate (r s m+ m-)
- (let (d tc1 tc2)
- (tagbody
- loop
- (setf (values d r) (truncate (* r print-base) s))
- (setf m+ (* m+ print-base))
- (setf m- (* m- print-base))
- (setf tc1 (or (< r m-) (and low-ok (= r m-))))
- (setf tc2 (or (> (+ r m+) s)
- (and high-ok (= (+ r m+) s))))
- (when (or tc1 tc2)
- (go end))
- (vector-push-extend (char digit-characters d) result)
- (go loop)
- end
- (let ((d (cond
- ((and (not tc1) tc2) (1+ d))
- ((and tc1 (not tc2)) d)
- (t ; (and tc1 tc2)
- (if (< (* r 2) s) d (1+ d))))))
- (vector-push-extend (char digit-characters d) result)
- (return-from generate result)))))
- (initialize ()
- (let (r s m+ m-)
- (if (>= e 0)
- (let* ((be (expt float-radix e))
- (be1 (* be float-radix)))
- (if (/= f (expt float-radix (1- float-digits)))
- (setf r (* f be 2)
- s 2
- m+ be
- m- be)
- (setf r (* f be1 2)
- s (* float-radix 2)
- m+ be1
- m- be)))
- (if (or (= e min-e)
- (/= f (expt float-radix (1- float-digits))))
- (setf r (* f 2)
- s (* (expt float-radix (- e)) 2)
- m+ 1
- m- 1)
- (setf r (* f float-radix 2)
- s (* (expt float-radix (- 1 e)) 2)
- m+ float-radix
- m- 1)))
- (when position
- (when relativep
- (aver (> position 0))
- (do ((k 0 (1+ k))
- ;; running out of letters here
- (l 1 (* l print-base)))
- ((>= (* s l) (+ r m+))
- ;; k is now \hat{k}
- (if (< (+ r (* s (/ (expt print-base (- k position)) 2)))
- (* s (expt print-base k)))
- (setf position (- k position))
- (setf position (- k position 1))))))
- (let ((low (max m- (/ (* s (expt print-base position)) 2)))
- (high (max m+ (/ (* s (expt print-base position)) 2))))
- (when (<= m- low)
- (setf m- low)
- (setf low-ok t))
- (when (<= m+ high)
- (setf m+ high)
- (setf high-ok t))))
- (values r s m+ m-))))
- (multiple-value-bind (r s m+ m-) (initialize)
- (scale r s m+ m-)))))))
+ (low-ok (evenp f)))
+ (with-push-char (:element-type base-char)
+ (labels ((scale (r s m+ m-)
+ (do ((k 0 (1+ k))
+ (s s (* s print-base)))
+ ((not (or (> (+ r m+) s)
+ (and high-ok (= (+ r m+) s))))
+ (do ((k k (1- k))
+ (r r (* r print-base))
+ (m+ m+ (* m+ print-base))
+ (m- m- (* m- print-base)))
+ ((not (and (plusp (- r m-)) ; Extension to handle zero
+ (or (< (* (+ r m+) print-base) s)
+ (and (not high-ok)
+ (= (* (+ r m+) print-base) s)))))
+ (values k (generate r s m+ m-)))))))
+ (generate (r s m+ m-)
+ (let (d tc1 tc2)
+ (tagbody
+ loop
+ (setf (values d r) (truncate (* r print-base) s))
+ (setf m+ (* m+ print-base))
+ (setf m- (* m- print-base))
+ (setf tc1 (or (< r m-) (and low-ok (= r m-))))
+ (setf tc2 (or (> (+ r m+) s)
+ (and high-ok (= (+ r m+) s))))
+ (when (or tc1 tc2)
+ (go end))
+ (push-char (char digit-characters d))
+ (go loop)
+ end
+ (let ((d (cond
+ ((and (not tc1) tc2) (1+ d))
+ ((and tc1 (not tc2)) d)
+ (t ; (and tc1 tc2)
+ (if (< (* r 2) s) d (1+ d))))))
+ (push-char (char digit-characters d))
+ (return-from generate (get-pushed-string))))))
+ (initialize ()
+ (let (r s m+ m-)
+ (if (>= e 0)
+ (let* ((be (expt float-radix e))
+ (be1 (* be float-radix)))
+ (if (/= f (expt float-radix (1- float-digits)))
+ (setf r (* f be 2)
+ s 2
+ m+ be
+ m- be)
+ (setf r (* f be1 2)
+ s (* float-radix 2)
+ m+ be1
+ m- be)))
+ (if (or (= e min-e)
+ (/= f (expt float-radix (1- float-digits))))
+ (setf r (* f 2)
+ s (* (expt float-radix (- e)) 2)
+ m+ 1
+ m- 1)
+ (setf r (* f float-radix 2)
+ s (* (expt float-radix (- 1 e)) 2)
+ m+ float-radix
+ m- 1)))
+ (when position
+ (when relativep
+ (aver (> position 0))
+ (do ((k 0 (1+ k))
+ ;; running out of letters here
+ (l 1 (* l print-base)))
+ ((>= (* s l) (+ r m+))
+ ;; k is now \hat{k}
+ (if (< (+ r (* s (/ (expt print-base (- k position)) 2)))
+ (* s (expt print-base k)))
+ (setf position (- k position))
+ (setf position (- k position 1))))))
+ (let ((low (max m- (/ (* s (expt print-base position)) 2)))
+ (high (max m+ (/ (* s (expt print-base position)) 2))))
+ (when (<= m- low)
+ (setf m- low)
+ (setf low-ok t))
+ (when (<= m+ high)
+ (setf m+ high)
+ (setf high-ok t))))
+ (values r s m+ m-))))
+ (multiple-value-bind (r s m+ m-) (initialize)
+ (scale r s m+ m-))))))))
\f
;;; Given a non-negative floating point number, SCALE-EXPONENT returns
;;; a new floating point number Z in the range (0.1, 1.0] and an
(values (float 0.0e0 original-x) 1)
(let* ((ex (locally (declare (optimize (safety 0)))
(the fixnum
- (round (* exponent (log 2e0 10))))))
+ (round (* exponent
+ ;; this is the closest double float
+ ;; to (log 2 10), but expressed so
+ ;; that we're not vulnerable to the
+ ;; host lisp's interpretation of
+ ;; arithmetic. (FIXME: it turns
+ ;; out that sbcl itself is off by 1
+ ;; ulp in this value, which is a
+ ;; little unfortunate.)
+ (load-time-value
+ #!-long-float
+ (sb!kernel:make-double-float 1070810131 1352628735)
+ #!+long-float
+ (error "(log 2 10) not computed")))))))
(x (if (minusp ex)
(if (float-denormalized-p x)
#!-long-float
;;; Print the appropriate exponent marker for X and the specified exponent.
(defun print-float-exponent (x exp stream)
(declare (type float x) (type integer exp) (type stream stream))
- (let ((*print-radix* nil)
- (plusp (plusp exp)))
+ (let ((*print-radix* nil))
(if (typep x *read-default-float-format*)
(unless (eql exp 0)
- (format stream "e~:[~;+~]~D" plusp exp))
- (format stream "~C~:[~;+~]~D"
+ (format stream "e~D" exp))
+ (format stream "~C~D"
(etypecase x
(single-float #\f)
(double-float #\d)
(short-float #\s)
(long-float #\L))
- plusp exp))))
+ exp))))
(defun output-float-infinity (x stream)
(declare (float x) (stream stream))
(cond (*read-eval*
(write-string "#." stream))
(*print-readably*
- (error 'print-not-readable :object x))
+ (restart-case
+ (error 'print-not-readable :object x)
+ (print-unreadably ()
+ :report "Print unreadably."
+ (let ((*print-readably* nil))
+ (output-float-infinity x stream)))
+ (use-value (o)
+ :report "Supply an object to be printed instead."
+ :interactive read-unreadable-replacement
+ (write o :stream stream))))
(t
(write-string "#<" stream)))
(write-string "SB-EXT:" stream)
(print-float-exponent x 0 stream))
(t
(output-float-aux x stream -3 8)))))))
+
(defun output-float-aux (x stream e-min e-max)
(multiple-value-bind (e string)
(flonum-to-digits x)
(t (write-string string stream :end 1)
(write-char #\. stream)
(write-string string stream :start 1)
- (when (= (length string) 1)
- (write-char #\0 stream))
(print-float-exponent x (1- e) stream)))))
\f
;;;; other leaf objects
;;; the character name or the character in the #\char format.
(defun output-character (char stream)
(if (or *print-escape* *print-readably*)
- (let ((graphicp (graphic-char-p char))
+ (let ((graphicp (and (graphic-char-p char)
+ (standard-char-p char)))
(name (char-name char)))
(write-string "#\\" stream)
(if (and name (not graphicp))