X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-pprint.lisp;h=8e8cff8fb3dc71bc0aacb55117272ccc029ac48f;hb=82cd148d729c241e79c8df04b700beec1b7c55de;hp=04c42b792930aba679064b278fc7a2aa878d2762;hpb=08d05510b51708853ca998154d8096b21d85edab;p=sbcl.git diff --git a/src/code/early-pprint.lisp b/src/code/early-pprint.lisp index 04c42b7..8e8cff8 100644 --- a/src/code/early-pprint.lisp +++ b/src/code/early-pprint.lisp @@ -36,117 +36,106 @@ (prefix nil prefixp) (per-line-prefix nil per-line-prefix-p) (suffix "" suffixp)) - &body body - &environment env) + &body body) #!+sb-doc "Group some output into a logical block. STREAM-SYMBOL should be either a stream, T (for *TERMINAL-IO*), or NIL (for *STANDARD-OUTPUT*). The printer control variable *PRINT-LEVEL* is automatically handled." - (when (and prefixp per-line-prefix-p) - (error "cannot specify values for both PREFIX and PER-LINE-PREFIX.")) - (multiple-value-bind (stream-var stream-expression) - (case stream-symbol - ((nil) - (values '*standard-output* '*standard-output*)) - ((t) - (values '*terminal-io* '*terminal-io*)) - (t - (values stream-symbol - (once-only ((stream stream-symbol)) - `(case ,stream - ((nil) *standard-output*) - ((t) *terminal-io*) - (t ,stream)))))) - (let* ((object-var (if object (gensym) nil)) - (block-name (sb!xc:gensym "PPRINT-LOGICAL-BLOCK-")) - (count-name (gensym "PPRINT-LOGICAL-BLOCK-LENGTH-")) - (pp-pop-name (sb!xc:gensym "PPRINT-POP-")) - (body - ;; FIXME: It looks as though PPRINT-LOGICAL-BLOCK might - ;; expand into a boatload of code, since DESCEND-INTO is a - ;; macro too. It might be worth looking at this to make - ;; sure it's not too bloated, since PPRINT-LOGICAL-BLOCK - ;; is called many times from system pretty-printing code. - ;; - ;; FIXME: I think pprint-logical-block is broken wrt - ;; argument order, multiple evaluation, etc. of its - ;; keyword (:PREFIX, :PER-LINE-PREFIX and :SUFFIX) - ;; arguments. Dunno if that's legal. - `(descend-into (,stream-var) - (let ((,count-name 0)) - (declare (type index ,count-name) (ignorable ,count-name)) - ,@(when (and (or prefixp per-line-prefix-p) - (not (sb!int:constant-typep - (or prefix per-line-prefix) - 'string - env))) - `((unless (typep ,(or prefix per-line-prefix) 'string) - (error 'type-error - :datum ,(or prefix per-line-prefix) - :expected-type 'string)))) - ,@(when (and suffixp - (not (sb!int:constant-typep suffix 'string env))) - `((unless (typep ,suffix 'string) - (error 'type-error - :datum ,suffix - :expected-type 'string)))) - (start-logical-block ,stream-var - ,(if (or prefixp per-line-prefix-p) - (or prefix per-line-prefix) - nil) - ,(if per-line-prefix-p t nil) - ,suffix) - (block ,block-name - (flet ((,pp-pop-name () - ,@(when object - `((unless (listp ,object-var) - (write-string ". " ,stream-var) - (output-object ,object-var ,stream-var) - (return-from ,block-name nil)))) - (when (and (not *print-readably*) - (eql ,count-name *print-length*)) - (write-string "..." ,stream-var) - (return-from ,block-name nil)) - ,@(when object - `((when (and ,object-var - (plusp ,count-name) - (check-for-circularity - ,object-var - nil - :logical-block)) - (write-string ". " ,stream-var) - (output-object ,object-var ,stream-var) - (return-from ,block-name nil)))) - (incf ,count-name) - ,@(if object - `((pop ,object-var)) - `(nil)))) - (declare (ignorable (function ,pp-pop-name))) - (locally - (declare (disable-package-locks - pprint-pop pprint-exit-if-list-exhausted)) - (macrolet ((pprint-pop () - '(,pp-pop-name)) - (pprint-exit-if-list-exhausted () - ,(if object - `'(when (null ,object-var) - (return-from ,block-name nil)) - `'(return-from ,block-name nil)))) - (declare (enable-package-locks - pprint-pop pprint-exit-if-list-exhausted)) - ,@body)))) - ;; FIXME: Don't we need UNWIND-PROTECT to ensure this - ;; always gets executed? - (end-logical-block ,stream-var))))) - (when object - (setf body - `(let ((,object-var ,object)) - (if (listp ,object-var) - (with-circularity-detection (,object-var ,stream-var) - ,body) - (output-object ,object-var ,stream-var))))) - `(with-pretty-stream (,stream-var ,stream-expression) - ,body)))) + (let ((prefix (cond ((and prefixp per-line-prefix-p) + (error "cannot specify values for both PREFIX and PER-LINE-PREFIX.")) + (prefixp prefix) + (per-line-prefix-p per-line-prefix)))) + (let ((object-var (if object (gensym) nil))) + (once-only ((prefix-var prefix) (suffix-var suffix)) + (multiple-value-bind (stream-var stream-expression) + (case stream-symbol + ((nil) + (values '*standard-output* '*standard-output*)) + ((t) + (values '*terminal-io* '*terminal-io*)) + (t + (values stream-symbol + (once-only ((stream stream-symbol)) + `(case ,stream + ((nil) *standard-output*) + ((t) *terminal-io*) + (t ,stream)))))) + (let* ((block-name (sb!xc:gensym "PPRINT-LOGICAL-BLOCK-")) + (count-name (gensym "PPRINT-LOGICAL-BLOCK-LENGTH-")) + (pp-pop-name (sb!xc:gensym "PPRINT-POP-")) + (body + ;; FIXME: It looks as though PPRINT-LOGICAL-BLOCK might + ;; expand into a boatload of code, since DESCEND-INTO is a + ;; macro too. It might be worth looking at this to make + ;; sure it's not too bloated, since PPRINT-LOGICAL-BLOCK + ;; is called many times from system pretty-printing code. + ;; + ;; FIXME: I think pprint-logical-block is broken wrt + ;; argument order, multiple evaluation, etc. of its + ;; keyword (:PREFIX, :PER-LINE-PREFIX and :SUFFIX) + ;; arguments. Dunno if that's legal. + `(descend-into (,stream-var) + (let ((,count-name 0)) + (declare (type index ,count-name) (ignorable ,count-name)) + ,@(when (or prefixp per-line-prefix-p) + `((declare (string ,prefix-var)))) + ,@(when (and suffixp) + `((declare (string ,suffix-var)))) + (start-logical-block ,stream-var + ,prefix-var + ,(if per-line-prefix-p t nil) + ,suffix-var) + (block ,block-name + (flet ((,pp-pop-name () + ,@(when object + `((unless (listp ,object-var) + (write-string ". " ,stream-var) + (output-object ,object-var ,stream-var) + (return-from ,block-name nil)))) + (when (and (not *print-readably*) + (eql ,count-name *print-length*)) + (write-string "..." ,stream-var) + (return-from ,block-name nil)) + ,@(when object + `((when (and ,object-var + (plusp ,count-name) + (check-for-circularity + ,object-var + nil + :logical-block)) + (write-string ". " ,stream-var) + (output-object ,object-var ,stream-var) + (return-from ,block-name nil)))) + (incf ,count-name) + ,@(if object + `((pop ,object-var)) + `(nil)))) + (declare (ignorable (function ,pp-pop-name))) + (locally + (declare (disable-package-locks + pprint-pop pprint-exit-if-list-exhausted)) + (macrolet ((pprint-pop () + '(,pp-pop-name)) + (pprint-exit-if-list-exhausted () + ,(if object + `'(when (null ,object-var) + (return-from ,block-name nil)) + `'(return-from ,block-name nil)))) + (declare (enable-package-locks + pprint-pop pprint-exit-if-list-exhausted)) + ,@body)))) + ;; FIXME: Don't we need UNWIND-PROTECT to ensure this + ;; always gets executed? + (end-logical-block ,stream-var))))) + (when object + (setf body + `(let ((,object-var ,object)) + (if (listp ,object-var) + (with-circularity-detection (,object-var ,stream-var) + ,body) + (output-object ,object-var ,stream-var))))) + `(with-pretty-stream (,stream-var ,stream-expression) + ,body))))))) (defmacro pprint-exit-if-list-exhausted () #!+sb-doc