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.

diff --git a/NEWS b/NEWS
index 4b6d4e9..23e34b2 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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)))))
+
 \f
 ;;; success

diff --git a/version.lisp-expr b/version.lisp-expr
index 275dcfe..330a3b2 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".)
-"1.0.43.37"
+"1.0.43.38"