X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fprint.lisp;h=ee80b94d97c50046ad91e313350a2f02ce5e964a;hb=1463431b1efcc020533afeaa68d99dc70fb93f89;hp=fd90bd2044b04b1e7358ac52c0f32c3561023a0a;hpb=06fbb54c129639135c270025ef8c3303fe9a026b;p=sbcl.git diff --git a/src/code/print.lisp b/src/code/print.lisp index fd90bd2..ee80b94 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -308,38 +308,54 @@ ;;;; support for the PRINT-UNREADABLE-OBJECT macro +(defun print-not-readable-error (object stream) + (restart-case + (error 'print-not-readable :object object) + (print-unreadably () + :report "Print unreadably." + (let ((*print-readably* nil)) + (output-object object stream) + object)) + (use-value (o) + :report "Supply an object to be printed instead." + :interactive + (lambda () + (read-evaluated-form "~@")) + (output-object o stream) + o))) + ;;; 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)) - (flet ((print-description () - (when type - (write (type-of object) :stream stream :circle nil - :level nil :length nil) - (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) - (write-char #\} stream)))) - (cond ((print-pretty-on-stream-p stream) - ;; Since we're printing prettily on STREAM, format the - ;; object within a logical block. PPRINT-LOGICAL-BLOCK does - ;; not rebind the stream when it is already a pretty stream, - ;; so output from the body will go to the same stream. - (pprint-logical-block (stream nil :prefix "#<" :suffix ">") - (print-description))) - (t - (write-string "#<" stream) - (print-description) - (write-char #\> stream)))) + (if *print-readably* + (print-not-readable-error object stream) + (flet ((print-description () + (when type + (write (type-of object) :stream stream :circle nil + :level nil :length nil) + (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) + (write-char #\} stream)))) + (cond ((print-pretty-on-stream-p stream) + ;; Since we're printing prettily on STREAM, format the + ;; object within a logical block. PPRINT-LOGICAL-BLOCK does + ;; not rebind the stream when it is already a pretty stream, + ;; so output from the body will go to the same stream. + (pprint-logical-block (stream nil :prefix "#<" :suffix ">") + (print-description))) + (t + (write-string "#<" stream) + (print-description) + (write-char #\> stream))))) nil) ;;;; OUTPUT-OBJECT -- the main entry point @@ -941,7 +957,7 @@ (load-time-value (array-element-type (make-array 0 :element-type 'character)))))) - (error 'print-not-readable :object vector)) + (print-not-readable-error vector stream)) ((or *print-escape* *print-readably*) (write-char #\" stream) (quote-string vector stream) @@ -959,7 +975,8 @@ (t (when (and *print-readably* (not (array-readably-printable-p vector))) - (error 'print-not-readable :object vector)) + (return-from output-vector + (print-not-readable-error vector stream))) (descend-into (stream) (write-string "#(" stream) (dotimes (i (length vector)) @@ -1011,7 +1028,8 @@ (defun output-array-guts (array stream) (when (and *print-readably* (not (array-readably-printable-p array))) - (error 'print-not-readable :object array)) + (return-from output-array-guts + (print-not-readable-error array stream))) (write-char #\# stream) (let ((*print-base* 10) (*print-radix* nil)) @@ -1277,71 +1295,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 @@ -1384,9 +1399,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) @@ -1562,7 +1578,8 @@ (cond (*read-eval* (write-string "#." stream)) (*print-readably* - (error 'print-not-readable :object x)) + (return-from output-float-infinity + (print-not-readable-error x stream))) (t (write-string "#<" stream))) (write-string "SB-EXT:" stream) @@ -1691,15 +1708,15 @@ nil) (defun output-fun (object stream) - (let* ((*print-length* 3) ; in case we have to.. - (*print-level* 3) ; ..print an interpreted function definition - (name (%fun-name object)) - (proper-name-p (and (legal-fun-name-p name) (fboundp name) - (eq (fdefinition name) object)))) - (print-unreadable-object (object stream :identity (not proper-name-p)) - (format stream "~:[FUNCTION~;CLOSURE~]~@[ ~S~]" - (closurep object) - name)))) + (let* ((*print-length* 4) ; in case we have to.. + (*print-level* 3) ; ..print an interpreted function definition + (name (%fun-name object)) + (proper-name-p (and (legal-fun-name-p name) (fboundp name) + (eq (fdefinition name) object)))) + (print-unreadable-object (object stream :identity (not proper-name-p)) + (format stream "~:[FUNCTION~;CLOSURE~]~@[ ~S~]" + (closurep object) + name)))) ;;;; catch-all for unknown things