X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fearly-pprint.lisp;h=c68d6b23089014d844e2595d186d7f20844f8735;hb=62d333e05a6ae7de4e7b5c918d67608a457b3da7;hp=4b6172730a1473b6daa82a2cb546e34f1e86d02d;hpb=cea4896b2482b7b2b429c1631d774b4cfbc0efba;p=sbcl.git

diff --git a/src/code/early-pprint.lisp b/src/code/early-pprint.lisp
index 4b61727..c68d6b2 100644
--- 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
@@ -96,15 +112,19 @@
 			    (incf ,count-name)
 			    ,@(when object
 				`((pop ,object-var)))))
-		     (declare (ignorable #',pp-pop-name))
-		     (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))))
-		       ,@body)))
+		     (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)))))