1.0.16.8: NCONC with dx &rest lists

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

diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp
index 0da0d3d..8798367 100644 (file)
--- a/src/code/pprint.lisp
+++ b/src/code/pprint.lisp
@@ -707,15 +707,19 @@
 
 (defun pprint-indent (relative-to n &optional stream)
   #!+sb-doc
-  "Specify the indentation to use in the current logical block if STREAM
-   (which defaults to *STANDARD-OUTPUT*) is it is a pretty-printing stream
-   and do nothing if not. (See PPRINT-LOGICAL-BLOCK.)  N is the indentation
-   to use (in ems, the width of an ``m'') and RELATIVE-TO can be either:
+  "Specify the indentation to use in the current logical block if
+STREAM \(which defaults to *STANDARD-OUTPUT*) is a pretty-printing
+stream and do nothing if not. (See PPRINT-LOGICAL-BLOCK.) N is the
+indentation to use (in ems, the width of an ``m'') and RELATIVE-TO can
+be either:
+
      :BLOCK - Indent relative to the column the current logical block
         started on.
+
      :CURRENT - Indent relative to the current column.
-   The new indentation value does not take effect until the following line
-   break."
+
+The new indentation value does not take effect until the following
+line break."
   (declare (type (member :block :current) relative-to)
            (type real n)
            (type (or stream (member t nil)) stream)
@@ -859,14 +863,15 @@
           (< (pprint-dispatch-entry-priority e1)
              (pprint-dispatch-entry-priority e2)))))
 
-(macrolet ((frob (x)
-             `(cons ',x (lambda (object) ,x))))
+(macrolet ((frob (name x)
+             `(cons ',x (named-lambda ,(symbolicate "PPRINT-DISPATCH-" name) (object)
+                            ,x))))
   (defvar *precompiled-pprint-dispatch-funs*
-    (list (frob (typep object 'array))
-          (frob (and (consp object)
-                     (symbolp (car object))
-                     (fboundp (car object))))
-          (frob (typep object 'cons)))))
+    (list (frob array (typep object 'array))
+          (frob sharp-function (and (consp object)
+                                    (symbolp (car object))
+                                    (fboundp (car object))))
+          (frob cons (typep object 'cons)))))
 
 (defun compute-test-fn (type)
   (let ((was-cons nil))
@@ -903,7 +908,15 @@
         (cond ((cdr (assoc expr *precompiled-pprint-dispatch-funs*
                            :test #'equal)))
               (t
-               (compile nil `(lambda (object) ,expr))))))))
+               (let ((name (symbolicate "PPRINT-DISPATCH-"
+                                        (if (symbolp type)
+                                            type
+                                            (write-to-string type
+                                                             :escape t
+                                                             :pretty nil
+                                                             :readably nil)))))
+                 (compile nil `(named-lambda ,name (object)
+                                 ,expr)))))))))
 
 (defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*))
   (declare (type (or pprint-dispatch-table null) table))