From 989f5a77df0dbf4557eda6fb92c4365e19818598 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Sat, 9 Oct 2010 22:33:41 +0000 Subject: [PATCH] 1.0.43.38: some PPRINT-LOGICAL-BLOCK issues :PER-LINE-PREFIX was multiply-evaluated, and both it, :PREFIX, and :SUFFIX caused code-deletion notes to be issued. Stick a ONCE-ONLY in there, and use (declare (string ...)) instead of (unless (typep x 'string) (error ...)) Python derives the fact that the argments must be strings by the time the TYPEP call occurs from the call to START-LOGICAL-BLOCK, hence the code-deletion note for the call to ERROR. --- NEWS | 4 +- src/code/early-pprint.lisp | 203 +++++++++++++++++++++----------------------- tests/pprint.impure.lisp | 21 +++++ version.lisp-expr | 2 +- 4 files changed, 121 insertions(+), 109 deletions(-) diff --git a/NEWS b/NEWS index 4b6d4e9..23e34b2 100644 --- a/NEWS +++ b/NEWS @@ -36,7 +36,9 @@ changes relative to sbcl-1.0.43: an error for eg. STRUCTURE. (lp#458015) * bug fix: LOOP WITH NIL = ... signalled an unused variable style-warning. (lp#613871, thanks to Roman Marynchak) - * bug fix: more reliable &REST list type derivation, a + * bug fix: more reliable &REST list type derivation. (lp#655203) + * bug fix: PPRINT-LOGICAL-BLOCK multiply-evaluated :PER-LINE-PREFIX, + and issued pointles code-deletion notes for it, :PREFIX, and :SUFFIX. changes in sbcl-1.0.43 relative to sbcl-1.0.42: * incompatible change: FD-STREAMS no longer participate in the serve-event 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 diff --git a/tests/pprint.impure.lisp b/tests/pprint.impure.lisp index 738f9f3..e59458f 100644 --- a/tests/pprint.impure.lisp +++ b/tests/pprint.impure.lisp @@ -248,5 +248,26 @@ (*print-pretty* t)) (format nil "~@<~S~:>" (make-instance 'frob)))))) +(with-test (:name :pprint-logical-block-code-deletion-node) + (handler-case + (compile nil + `(lambda (words &key a b c) + (pprint-logical-block (nil words :per-line-prefix (or a b c)) + (pprint-fill *standard-output* (sort (copy-seq words) #'string<) nil)))) + ((or sb-ext:compiler-note warning) (c) + (error e)))) + +(with-test (:name :pprint-logical-block-multiple-per-line-prefix-eval) + (funcall (compile nil + `(lambda () + (let ((n 0)) + (with-output-to-string (s) + (pprint-logical-block (s nil :per-line-prefix (if (eql 1 (incf n)) + "; " + (error "oops"))) + (pprint-newline :mandatory s) + (pprint-newline :mandatory s))) + n))))) + ;;; success diff --git a/version.lisp-expr b/version.lisp-expr index 275dcfe..330a3b2 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.43.37" +"1.0.43.38" -- 1.7.10.4