From 23468d8a38cdd7c2cb53a7e991436545bb26ed43 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Tue, 14 Sep 2004 14:07:09 +0000 Subject: [PATCH] 0.8.14.22: Fix spurious code deletion notes from PPRINT-LOGICAL-BLOCK --- src/code/early-pprint.lisp | 14 +++++++++++--- tests/compiler.pure.lisp | 13 +++++++++++++ version.lisp-expr | 2 +- 3 files changed, 25 insertions(+), 4 deletions(-) diff --git a/src/code/early-pprint.lisp b/src/code/early-pprint.lisp index c68d6b2..35af3d6 100644 --- 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 --- 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 --- 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" -- 1.7.10.4