From e60c0fcde88bf21c3b9faffe8718d07c888b934a Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Tue, 15 Jan 2008 02:45:15 +0000
Subject: [PATCH] 1.0.3.33: use NAMED-LAMBDA instead of LAMBDA for
 pretty-printer predicates

 * AKA less mysterious (LAMBDA (OBJECT)) potential in statistical
   profiling &co. (No, I haven't been overly troubled by such functions,
   but since it is easy to give these ones names, we just as well may.)
---
 src/code/pprint.lisp | 25 +++++++++++++++++--------
 version.lisp-expr    |  2 +-
 2 files changed, 18 insertions(+), 9 deletions(-)

diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp
index 0da0d3d8a..8d2de3bef 100644
--- a/src/code/pprint.lisp
+++ b/src/code/pprint.lisp
@@ -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))
diff --git a/version.lisp-expr b/version.lisp-expr
index e9909dbbe..c295d94a0 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.13.32"
+"1.0.13.33"
-- 
2.11.4.GIT