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

diff --git a/src/code/early-pprint.lisp b/src/code/early-pprint.lisp
index eb6aafe..25d9763 100644
--- a/src/code/early-pprint.lisp
+++ b/src/code/early-pprint.lisp
@@ -10,9 +10,6 @@
 ;;;; files for more information.
 
 (in-package "SB!PRETTY")
-
-(file-comment
-  "$Header$")
 
 ;;;; utilities
 
@@ -36,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)
@@ -69,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
@@ -99,15 +119,20 @@
 			    (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)))
+                     (declare (ignorable (function ,pp-pop-name)))
+		     (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)))))
@@ -127,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