0.8.15.15: Removing non-ANSI FTYPE proclaims and TYPE declarares from PCL

[sbcl.git] / src / code / early-pprint.lisp

diff --git a/src/code/early-pprint.lisp b/src/code/early-pprint.lisp
index 0fd0895..35af3d6 100644 (file)
--- 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))