X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=fd90bd2044b04b1e7358ac52c0f32c3561023a0a;hb=b92e0bedf7e29a43fe4fd9141b5d658751e3bef0;hp=7240bf86b3623e364f747907b35ea36e7ddb2105;hpb=7a2c04ec5b42fa2faf4ce0969772b10042d74c70;p=sbcl.git diff --git a/src/code/print.lisp b/src/code/print.lisp index 7240bf8..fd90bd2 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,12 +120,6 @@ (*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))) @@ -171,7 +167,7 @@ ((: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) @@ -197,9 +193,11 @@ (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)))) + (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 @@ -279,9 +277,10 @@ (push variable ignore)) (push (list variable value) bind))) (if bind - `(let ,(nreverse bind) - ,@(when ignore `((declare (ignore ,@ignore)))) - (stringify-object ,object)) + (once-only ((object object)) + `(let ,(nreverse bind) + ,@(when ignore `((declare (ignore ,@ignore)))) + (stringify-object ,object))) `(stringify-object ,object)))) (defun prin1-to-string (object) @@ -318,12 +317,14 @@ (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) @@ -336,9 +337,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 @@ -447,8 +448,6 @@ (output-float object stream)) (ratio (output-ratio object stream)) - (ratio - (output-ratio object stream)) (complex (output-complex object stream)))) (character @@ -1351,9 +1350,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))) @@ -1483,7 +1482,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