0.8.14.22:

	Fix spurious code deletion notes from PPRINT-LOGICAL-BLOCK

diff --git a/src/code/early-pprint.lisp b/src/code/early-pprint.lisp
index c68d6b2..35af3d6 100644 (file)
--- a/src/code/early-pprint.lisp
+++ b/src/code/early-pprint.lisp
@@ -36,7 +36,8 @@
                                 (prefix nil prefixp)
                                 (per-line-prefix nil per-line-prefix-p)
                                 (suffix "" suffixp))
-                               &body body)
+                               &body body
+                                &environment env)
   #!+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
@@ -74,12 +75,18 @@
            `(descend-into (,stream-var)
               (let ((,count-name 0))
                 (declare (type index ,count-name) (ignorable ,count-name))
-                ,@(when (or prefixp per-line-prefix-p)
+                ,@(when (and (or prefixp per-line-prefix-p)
+                              (not (and (sb!xc:constantp (or prefix per-line-prefix) env)
+                                        ;; KLUDGE: EVAL-IN-ENV would
+                                        ;; be useful here.
+                                        (typep (eval (or prefix per-line-prefix)) 'string))))
                     `((unless (typep ,(or prefix per-line-prefix) 'string)
                         (error 'type-error
                                :datum ,(or prefix per-line-prefix)
                                :expected-type 'string))))
-                ,@(when suffixp
+                ,@(when (and suffixp
+                              (not (and (sb!xc:constantp suffix env)
+                                        (typep (eval suffix) 'string))))
                     `((unless (typep ,suffix 'string)
                         (error 'type-error
                                :datum ,suffix
@@ -112,6 +119,7 @@
                            (incf ,count-name)
                            ,@(when object
                                `((pop ,object-var)))))
+                     (declare (ignorable (function ,pp-pop-name)))
                     (locally
                         (declare (disable-package-locks 
                                   pprint-pop pprint-exit-if-list-exhausted))

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 1b48367..adafaf8 100644 (file)
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -1460,3 +1460,16 @@
      (PROGN
        (TAGBODY (THE INTEGER (CATCH 'CT4 (LOGORC1 C -15950))) 1)
        B))))
+
+;;; check that constant string prefix and suffix don't cause the
+;;; compiler to emit code deletion notes.
+(handler-bind ((sb-ext:code-deletion-note #'error))
+  (compile nil '(lambda (s x)
+                 (pprint-logical-block (s x :prefix "(")
+                   (print x s))))
+  (compile nil '(lambda (s x)
+                 (pprint-logical-block (s x :per-line-prefix ";")
+                   (print x s))))
+  (compile nil '(lambda (s x)
+                 (pprint-logical-block (s x :suffix ">")
+                   (print x s)))))

diff --git a/version.lisp-expr b/version.lisp-expr
index 6a34369..4b6b8bf 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.14.21"
+"0.8.14.22"