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

diff --git a/src/code/early-pprint.lisp b/src/code/early-pprint.lisp
index 0fd0895..25d9763 100644
--- a/src/code/early-pprint.lisp
+++ b/src/code/early-pprint.lisp
@@ -33,16 +33,17 @@
 (defmacro pprint-logical-block ((stream-symbol
 				 object
 				 &key
-				 prefix
-				 per-line-prefix
-				 (suffix ""))
-				&body body)
+				 (prefix nil prefixp)
+				 (per-line-prefix nil per-line-prefix-p)
+				 (suffix "" suffixp))
+				&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
    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 +67,36 @@
 	    ;; 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 (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 (and suffixp
+                              (not (and (sb!xc:constantp suffix env)
+                                        (typep (eval suffix) 'string))))
+		     `((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,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))
@@ -128,7 +152,7 @@
    PPRINT-LOGICAL-BLOCK, and only when the LIST argument to
    PPRINT-LOGICAL-BLOCK is supplied."
   (error "PPRINT-EXIT-IF-LIST-EXHAUSTED must be lexically inside ~
-	  PPRINT-LOGICAL-BLOCK."))
+          PPRINT-LOGICAL-BLOCK."))
 
 (defmacro pprint-pop ()
   #!+sb-doc