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

diff --git a/src/code/early-pprint.lisp b/src/code/early-pprint.lisp
index 0fd0895..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