X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-introspect%2Fsb-introspect.lisp;h=777ab6d70d38cc649ad831729b6268beff4d7b98;hb=762cc09a6fc92af20c0581cfc97d1630fa642ddb;hp=fe56ac439912665a213cfd193d00d00c8db8b4a5;hpb=7bc673134608823558539506525e13721b6c3333;p=sbcl.git

diff --git a/contrib/sb-introspect/sb-introspect.lisp b/contrib/sb-introspect/sb-introspect.lisp
index fe56ac4..777ab6d 100644
--- a/contrib/sb-introspect/sb-introspect.lisp
+++ b/contrib/sb-introspect/sb-introspect.lisp
@@ -140,7 +140,17 @@ If an unsupported TYPE is requested, the function will return NIL.
   (flet ((listify (x)
            (if (listp x)
                x
-               (list x))))
+               (list x)))
+         (get-class (name)
+           (and (symbolp name)
+                (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)
@@ -166,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)))))
@@ -175,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))
@@ -192,7 +203,7 @@ If an unsupported TYPE is requested, the function will return NIL.
                                                       (symbol-function expander)
                                                       expander)))))
        ((:structure)
-        (let ((class (find-class name nil)))
+        (let ((class (get-class name)))
           (if class
               (when (typep class 'sb-pcl::structure-class)
                 (find-definition-source class))
@@ -200,8 +211,9 @@ If an unsupported TYPE is requested, the function will return NIL.
                 (translate-source-location
                  (sb-int:info :source-location :typed-structure name))))))
        ((:condition :class)
-        (let ((class (find-class name nil)))
-          (when class
+        (let ((class (get-class name)))
+          (when (and class
+                     (not (typep class 'sb-pcl::structure-class)))
             (when (eq (not (typep class 'sb-pcl::condition-class))
                       (not (eq type :condition)))
               (find-definition-source class)))))
@@ -280,8 +292,8 @@ If an unsupported TYPE is requested, the function will return NIL.
               (sb-kernel::layout-source-location layout)))))))
     (method-combination
      (car
-      (find-definition-sources-by-name (sb-pcl::method-combination-type object)
-                                       :method-combination)))
+      (find-definition-sources-by-name
+       (sb-pcl::method-combination-type-name object) :method-combination)))
     (package
      (translate-source-location (sb-impl::package-source-location object)))
     (class
@@ -306,6 +318,11 @@ If an unsupported TYPE is requested, the function will return NIL.
                        (sb-pcl::unparse-specializers
                         (sb-mop:method-specializers object)))))
        source))
+    #+sb-eval
+    (sb-eval:interpreted-function
+     (let ((source (translate-source-location
+                    (sb-eval:interpreted-function-source-location object))))
+       source))
     (function
      (cond ((struct-accessor-p object)
             (find-definition-source
@@ -376,14 +393,19 @@ If an unsupported TYPE is requested, the function will return NIL.
 
 ;;; FIXME: maybe this should be renamed as FUNCTION-LAMBDA-LIST?
 (defun function-arglist (function)
-  "Describe the lambda list for the function designator FUNCTION.
-Works for special-operators, macros, simple functions and generic
-functions.  Signals error if not found"
+  "Describe the lambda list for the extended function designator FUNCTION.
+Works for special-operators, macros, simple functions,
+interpreted functions, and generic functions.  Signals error if
+not found"
   (cond ((valid-function-name-p function)
-         (function-arglist
-          (or (macro-function function) (fdefinition function))))
+         (function-arglist (or (and (symbolp function)
+                                    (macro-function function))
+                               (fdefinition function))))
         ((typep function 'generic-function)
          (sb-pcl::generic-function-pretty-arglist function))
+        #+sb-eval
+        ((typep function 'sb-eval:interpreted-function)
+         (sb-eval:interpreted-function-lambda-list function))
         (t (sb-impl::%simple-fun-arglist
             (sb-impl::%closure-fun function)))))