From 62d333e05a6ae7de4e7b5c918d67608a457b3da7 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Wed, 11 Aug 2004 08:28:35 +0000 Subject: [PATCH] 0.8.13.58: Fix for PPRINT-LOGICAL-BLOCK: signal type-error if :PREFIX or :PER-LINE-PREFIX doesn't evaluate to a string. --- NEWS | 2 ++ src/code/early-pprint.lisp | 34 +++++++++++++++++++++++++--------- src/code/late-format.lisp | 2 +- version.lisp-expr | 2 +- 4 files changed, 29 insertions(+), 11 deletions(-) diff --git a/NEWS b/NEWS index 026773d..fd0a867 100644 --- a/NEWS +++ b/NEWS @@ -48,6 +48,8 @@ changes in sbcl-0.8.14 relative to sbcl-0.8.13: as specified: it no longer includes conditional newlines). ** PRINC-TO-STRING binds *PRINT-READABLY* to NIL (as well as *PRINT-ESCAPE*). + ** PPRINT-LOGICAL-BLOCK signals a TYPE-ERROR if its :PREFIX or + :PER-LINE-PREFIX argument does not evaluate to a string. changes in sbcl-0.8.13 relative to sbcl-0.8.12: * new feature: SB-PACKAGE-LOCKS. See the "Package Locks" section of diff --git a/src/code/early-pprint.lisp b/src/code/early-pprint.lisp index 0fd0895..c68d6b2 100644 --- a/src/code/early-pprint.lisp +++ b/src/code/early-pprint.lisp @@ -33,16 +33,16 @@ (defmacro pprint-logical-block ((stream-symbol object &key - prefix - per-line-prefix - (suffix "")) + (prefix nil prefixp) + (per-line-prefix nil per-line-prefix-p) + (suffix "" suffixp)) &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 prefix per-line-prefix) - (error "cannot specify both PREFIX and a PER-LINE-PREFIX values")) + (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) @@ -66,14 +66,30 @@ ;; 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) + `((unless (typep ,(or prefix per-line-prefix) 'string) + (error 'type-error + :datum ,(or prefix per-line-prefix) + :expected-type 'string)))) + ,@(when suffixp + `((unless (typep ,suffix 'string) + (error 'type-error + :datum ,suffix + :expected-type 'string)))) (start-logical-block ,stream-var - (the (or null string) - ,(or prefix per-line-prefix)) - ,(if per-line-prefix t nil) - (the string ,suffix)) + ,(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 diff --git a/src/code/late-format.lisp b/src/code/late-format.lisp index 500bf06..3dc2494 100644 --- a/src/code/late-format.lisp +++ b/src/code/late-format.lisp @@ -1002,7 +1002,7 @@ :offset (caar params))) (multiple-value-bind (prefix insides suffix) (multiple-value-bind (prefix-default suffix-default) - (if colonp (values "(" ")") (values nil "")) + (if colonp (values "(" ")") (values "" "")) (flet ((extract-string (list prefix-p) (let ((directive (find-if #'format-directive-p list))) (if directive diff --git a/version.lisp-expr b/version.lisp-expr index c621f9f..ec6b99d 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".) -"0.8.13.57" +"0.8.13.58" -- 1.7.10.4