[Sbcl-commits] CVS: sbcl/src/code early-pprint.lisp,1.4,1.5

[Christophe R. <cr...@us...>]

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv31742/src/code

Modified Files:
	early-pprint.lisp 
Log Message:
0.8.14.22:
	Fix spurious code deletion notes from PPRINT-LOGICAL-BLOCK


Index: early-pprint.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/early-pprint.lisp,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -d -r1.4 -r1.5
--- early-pprint.lisp	11 Aug 2004 08:28:36 -0000	1.4
+++ early-pprint.lisp	14 Sep 2004 14:07:10 -0000	1.5
@@ -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))