0.8.13.58:

	Fix for PPRINT-LOGICAL-BLOCK: signal type-error if :PREFIX or
	:PER-LINE-PREFIX doesn't evaluate to a string.

diff --git a/NEWS b/NEWS
index 026773d..fd0a867 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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"