X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fpprint.lisp;h=8d2de3bef95708fc6be5f8e2c67c1aea1bb1a8a2;hb=068cf4b55af3f8f8acf2c7c06869441612261cd4;hp=7331459d28c52a88b90f5935a521d8ae5e52cfcc;hpb=7ebe82f662f0fd0038479cbb057ec77867ab6f7e;p=sbcl.git

diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp
index 7331459..8d2de3b 100644
--- a/src/code/pprint.lisp
+++ b/src/code/pprint.lisp
@@ -138,7 +138,7 @@
     (unless (= start end)
       (sb!impl::string-dispatch (simple-base-string
                                  #!+sb-unicode
-                                 (simple-array character))
+                                 (simple-array character (*)))
           string
         ;; For POSITION transform
         (declare (optimize (speed 2)))
@@ -859,14 +859,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 +904,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))
@@ -1282,9 +1291,13 @@
 
 (defun pprint-fun-call (stream list &rest noise)
   (declare (ignore noise))
-  (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~_~}~:>")
+  (funcall (formatter "~:<~^~W~^ ~:_~:I~@{~W~^ ~:_~}~:>")
            stream
            list))
+
+(defun pprint-data-list (stream list &rest noise)
+  (declare (ignore noise))
+  (funcall (formatter "~:<~@{~W~^ ~:_~}~:>") stream list))
 
 ;;;; the interface seen by regular (ugly) printer and initialization routines
 
@@ -1302,8 +1315,10 @@
     ;; printers for regular types
     (/show0 "doing SET-PPRINT-DISPATCH for regular types")
     (set-pprint-dispatch 'array #'pprint-array)
-    (set-pprint-dispatch '(cons symbol)
+    (set-pprint-dispatch '(cons (and symbol (satisfies fboundp)))
                          #'pprint-fun-call -1)
+    (set-pprint-dispatch '(cons symbol)
+                         #'pprint-data-list -2)
     (set-pprint-dispatch 'cons #'pprint-fill -2)
     ;; cons cells with interesting things for the car
     (/show0 "doing SET-PPRINT-DISPATCH for CONS with interesting CAR")