From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Thu, 10 Aug 2006 11:17:27 +0000 (+0000)
Subject: 0.9.15.23: finding defintions of profiled functions
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=e15ca902a6c4eb6e4695e71400edbbd57c5e57cd;p=sbcl.git

0.9.15.23: finding defintions of profiled functions
 * Patch by Troels Henriksen.
 * Test-case missing from 0.9.15.22.
---

diff --git a/NEWS b/NEWS
index 06c3a5c..4fca016 100644
--- a/NEWS
+++ b/NEWS
@@ -7,6 +7,8 @@ changes in sbcl-0.9.16 relative to sbcl-0.9.15:
     (thanks to Lutz Euler)
   * optimization: hashing of general arrays and vectors has been
     improved. (reported by Any Fingerhut)
+  * enhancement: SB-INTROSPECT is now able to find definitions of
+    profiled functions. (thanks to Troels Henriksen)
   * fixed bug #337: use of MAKE-METHOD in method combination now works
     even in the presence of user-defined method classes.  (reported by
     Bruno Haible and Pascal Costanza)
diff --git a/contrib/sb-introspect/sb-introspect.lisp b/contrib/sb-introspect/sb-introspect.lisp
index a5ff21f..debda19 100644
--- a/contrib/sb-introspect/sb-introspect.lisp
+++ b/contrib/sb-introspect/sb-introspect.lisp
@@ -143,7 +143,14 @@ If an unsupported TYPE is requested, the function will return NIL.
                (list x)))
          (get-class (name)
            (and (symbolp name)
-                (find-class name nil))))
+                (find-class name nil)))
+         (real-fdefinition (name)
+           ;; for getting the real function object, even if the
+           ;; function is being profiled
+           (let ((profile-info (gethash name sb-profile::*profiled-fun-name->info*)))
+             (if profile-info
+                 (sb-profile::profile-info-encapsulated-fun profile-info)
+                 (fdefinition name)))))
     (listify
      (case type
        ((:variable)
@@ -169,7 +176,7 @@ If an unsupported TYPE is requested, the function will return NIL.
         (when (and (fboundp name)
                    (or (not (symbolp name))
                        (not (macro-function name))))
-          (let ((fun (fdefinition name)))
+          (let ((fun (real-fdefinition name)))
             (when (eq (not (typep fun 'generic-function))
                       (not (eq type :generic-function)))
               (find-definition-source fun)))))
@@ -178,12 +185,13 @@ If an unsupported TYPE is requested, the function will return NIL.
           (when expander-fun
             (find-definition-source expander-fun))))
        ((:method)
-        (when (and (fboundp name)
-                   (typep (fdefinition name) 'generic-function))
-          (loop for method in (sb-mop::generic-function-methods
-                               (fdefinition name))
+        (when (fboundp name)
+          (let ((fun (real-fdefinition name)))
+           (when (typep fun 'generic-function)
+             (loop for method in (sb-mop::generic-function-methods
+                                  fun)
                 for source = (find-definition-source method)
-                when source collect source)))
+                when source collect source)))))
        ((:setf-expander)
         (when (and (consp name)
                    (eq (car name) 'setf))
diff --git a/contrib/sb-introspect/test-driver.lisp b/contrib/sb-introspect/test-driver.lisp
index f647fab..6abd985 100644
--- a/contrib/sb-introspect/test-driver.lisp
+++ b/contrib/sb-introspect/test-driver.lisp
@@ -68,6 +68,9 @@
 (assert (matchp-name :method-combination 'cl-user::r 26))
 (assert (matchp-name :setf-expander 'cl-user::s 27))
 
+(sb-profile:profile cl-user::one)
+(assert (matchp-name :function 'cl-user::one 2))
+(sb-profile:unprofile cl-user::one)
 
 ;;; Unix success convention for exit codes
 (sb-ext:quit :unix-status 0)
diff --git a/tests/print.impure.lisp b/tests/print.impure.lisp
index 6a18d72..6d8072f 100644
--- a/tests/print.impure.lisp
+++ b/tests/print.impure.lisp
@@ -412,4 +412,8 @@
 
 (assert (string= (eval '(format nil "~:C" #\a)) "a"))
 (assert (string= (format nil (formatter "~:C") #\a) "a"))
+
+;;; This used to trigger an AVER instead.
+(assert (raises-error? (format t "~>") sb-format:format-error))
+
 ;;; success
diff --git a/version.lisp-expr b/version.lisp-expr
index 6640afe..75973b1 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".)
-"0.9.15.22"
+"0.9.15.23"