X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=b0a4e72b31441a6dc4a17f10ec1c425a3a120f86;hb=6caf3ed5713773cb423f46bf40a29f2438c97c78;hp=7240bf86b3623e364f747907b35ea36e7ddb2105;hpb=7a2c04ec5b42fa2faf4ce0969772b10042d74c70;p=sbcl.git diff --git a/src/code/print.lisp b/src/code/print.lisp index 7240bf8..b0a4e72 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) @@ -309,21 +308,36 @@ ;;;; support for the PRINT-UNREADABLE-OBJECT macro +(defun read-unreadable-replacement () + (format *query-io* "~@") + (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) @@ -336,9 +350,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 +461,6 @@ (output-float object stream)) (ratio (output-ratio object stream)) - (ratio - (output-ratio object stream)) (complex (output-complex object stream)))) (character @@ -942,7 +954,16 @@ (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) @@ -960,7 +981,14 @@ (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)) @@ -1012,7 +1040,14 @@ (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)) @@ -1278,71 +1313,68 @@ ;; 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 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 (+ 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 @@ -1351,9 +1383,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))) @@ -1385,9 +1417,10 @@ (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)))) + ((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) @@ -1483,7 +1516,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 @@ -1550,7 +1596,16 @@ (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)