\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*)
(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))
+ `(let ,(nreverse bind)
+ ,@(when ignore `((declare (ignore ,@ignore))))
+ (output-object ,object stream))))
+
(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
+ `(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
(output-float object stream))
(ratio
(output-ratio object stream))
- (ratio
- (output-ratio object stream))
(complex
(output-complex object stream))))
(character
;;; 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)))
(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