X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=276ce951ce3621f5b3d61506de0a484e2211c519;hb=d61819dea7797e94d996efc48883261392ec63ba;hp=e235f4b2b938979b5fc5ffaca66b1d447f4d7cfd;hpb=26265f96389d737bf2e1e4c787ea8943ae499944;p=sbcl.git diff --git a/src/code/print.lisp b/src/code/print.lisp index e235f4b..276ce95 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -18,8 +18,8 @@ (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 @@ -30,7 +30,7 @@ "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?") @@ -56,10 +56,10 @@ "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 @@ -69,7 +69,7 @@ (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 @@ -86,6 +86,7 @@ *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 @@ -110,6 +111,7 @@ (*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) @@ -118,17 +120,32 @@ (*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))) ;;;; routines to print objects + +;;; 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*) @@ -150,10 +167,36 @@ ((: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)) + `(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 @@ -192,27 +235,51 @@ (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 @@ -249,10 +316,12 @@ :level nil :length nil) (write-char #\space stream)) (when body + (pprint-newline :fill stream) (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) @@ -265,9 +334,9 @@ (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) ;;;; OUTPUT-OBJECT -- the main entry point @@ -376,8 +445,6 @@ (output-float object stream)) (ratio (output-ratio object stream)) - (ratio - (output-ratio object stream)) (complex (output-complex object stream)))) (character @@ -1280,9 +1347,9 @@ ;;; 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))) @@ -1412,7 +1479,20 @@ (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