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

diff --git a/contrib/sb-introspect/sb-introspect.lisp b/contrib/sb-introspect/sb-introspect.lisp
index a9af9c4..777ab6d 100644
--- a/contrib/sb-introspect/sb-introspect.lisp
+++ b/contrib/sb-introspect/sb-introspect.lisp
@@ -140,125 +140,146 @@ If an unsupported TYPE is requested, the function will return NIL.
   (flet ((listify (x)
            (if (listp x)
                x
-               (list x))))
-  (listify
-   (case type
-     ((:variable)
-      (when (eq (sb-int:info :variable :kind name) :special)
-        (translate-source-location (sb-int:info :source-location type name))))
-     ((:constant)
-      (when (eq (sb-int:info :variable :kind name) :constant)
-        (translate-source-location (sb-int:info :source-location type name))))
-     ((:symbol-macro)
-      (when (eq (sb-int:info :variable :kind name) :macro)
-        (translate-source-location (sb-int:info :source-location type name))))
-     ((:macro)
-      (when (and (symbolp name)
-                 (macro-function name))
-        (find-definition-source (macro-function name))))
-     ((:compiler-macro)
-      (when (compiler-macro-function name)
-        (find-definition-source (compiler-macro-function name))))
-     ((:function :generic-function)
-      (when (and (fboundp name)
-                 (or (not (symbolp name))
-                     (not (macro-function name))))
-        (let ((fun (fdefinition name)))
-          (when (eq (not (typep fun 'generic-function))
-                    (not (eq type :generic-function)))
-            (find-definition-source fun)))))
-     ((:type)
-      (let ((expander-fun (sb-int:info :type :expander name)))
-        (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))
-              for source = (find-definition-source method)
-              when source collect source)))
-     ((:setf-expander)
-      (when (and (consp name)
-                 (eq (car name) 'setf))
-        (setf name (cadr name)))
-      (let ((expander-fun (or (sb-int:info :setf :inverse name)
-                              (sb-int:info :setf :expander name))))
-        (when expander-fun
-          (sb-introspect:find-definition-source expander-fun))))
-     ((:structure)
-      (let ((class (ignore-errors (find-class name))))
-        (if class
-            (when (typep class 'sb-pcl::structure-class)
-              (find-definition-source class))
-            (when (sb-int:info :typed-structure :info name)
-              (translate-source-location
-               (sb-int:info :source-location :typed-structure name))))))
-     ((:condition :class)
-      (let ((class (ignore-errors (find-class name))))
-        (when class
-          (when (eq (not (typep class 'sb-pcl::condition-class))
-                    (not (eq type :condition)))
-            (find-definition-source class)))))
-     ((:method-combination)
-      (let ((combination-fun
-             (ignore-errors (find-method #'sb-mop:find-method-combination
-                                         nil
-                                         (list (find-class 'generic-function)
-                                               (list 'eql name)
-                                               t)))))
-        (when combination-fun
-          (find-definition-source combination-fun))))
-     ((:package)
-      (when (symbolp name)
-        (let ((package (find-package name)))
-          (when package
-            (find-definition-source package)))))
-     ;;; TRANSFORM and OPTIMIZER handling from swank-sbcl
-     ((:transform)
-      (let ((fun-info (sb-int:info :function :info name)))
-        (when fun-info
-          (loop for xform in (sb-c::fun-info-transforms fun-info)
-                for source = (find-definition-source
-                              (sb-c::transform-function xform))
-                for typespec = (sb-kernel:type-specifier
-                                (sb-c::transform-type xform))
-                for note = (sb-c::transform-note xform)
-                do (setf (definition-source-description source)
-                         (if (consp typespec)
-                             (list (second typespec) note)
-                             (list note)))
-                collect source))))
-     ((:optimizer)
-      (let ((fun-info (sb-int:info :function :info name)))
-        (when fun-info
-          (let ((otypes '((sb-c::fun-info-derive-type . sb-c:derive-type)
-                          (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
-                          (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
-                          (sb-c::fun-info-optimizer . sb-c:optimizer))))
-            (loop for (reader . name) in otypes
-                  for fn = (funcall reader fun-info)
-                  when fn collect
-                  (let ((source (find-definition-source fn)))
-                    (setf (definition-source-description source)
-                          (list name))
-                    source))))))
-     ((:vop)
-      (let ((fun-info (sb-int:info :function :info name)))
-        (when fun-info
-          (loop for vop in (sb-c::fun-info-templates fun-info)
-                for source = (find-definition-source
-                              (sb-c::vop-info-generator-function vop))
-                do (setf (definition-source-description source)
-                         (list (sb-c::template-name vop)
-                               (sb-c::template-note vop)))
-                collect source))))
-     ((:source-transform)
-      (let ((transform-fun (sb-int:info :function :source-transform name)))
-        (when transform-fun
-          (sb-introspect:find-definition-source transform-fun))))
-     (t
-      nil)))))
+               (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)
+        (when (and (symbolp name)
+                   (eq (sb-int:info :variable :kind name) :special))
+          (translate-source-location (sb-int:info :source-location type name))))
+       ((:constant)
+        (when (and (symbolp name)
+                   (eq (sb-int:info :variable :kind name) :constant))
+          (translate-source-location (sb-int:info :source-location type name))))
+       ((:symbol-macro)
+        (when (and (symbolp name)
+                   (eq (sb-int:info :variable :kind name) :macro))
+          (translate-source-location (sb-int:info :source-location type name))))
+       ((:macro)
+        (when (and (symbolp name)
+                   (macro-function name))
+          (find-definition-source (macro-function name))))
+       ((:compiler-macro)
+        (when (compiler-macro-function name)
+          (find-definition-source (compiler-macro-function name))))
+       ((:function :generic-function)
+        (when (and (fboundp name)
+                   (or (not (symbolp name))
+                       (not (macro-function name))))
+          (let ((fun (real-fdefinition name)))
+            (when (eq (not (typep fun 'generic-function))
+                      (not (eq type :generic-function)))
+              (find-definition-source fun)))))
+       ((:type)
+        (let ((expander-fun (sb-int:info :type :expander name)))
+          (when expander-fun
+            (find-definition-source expander-fun))))
+       ((:method)
+        (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)))))
+       ((:setf-expander)
+        (when (and (consp name)
+                   (eq (car name) 'setf))
+          (setf name (cadr name)))
+        (let ((expander (or (sb-int:info :setf :inverse name)
+                            (sb-int:info :setf :expander name))))
+          (when expander
+            (sb-introspect:find-definition-source (if (symbolp expander)
+                                                      (symbol-function expander)
+                                                      expander)))))
+       ((:structure)
+        (let ((class (get-class name)))
+          (if class
+              (when (typep class 'sb-pcl::structure-class)
+                (find-definition-source class))
+              (when (sb-int:info :typed-structure :info name)
+                (translate-source-location
+                 (sb-int:info :source-location :typed-structure name))))))
+       ((:condition :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)))))
+       ((:method-combination)
+        (let ((combination-fun
+               (ignore-errors (find-method #'sb-mop:find-method-combination
+                                           nil
+                                           (list (find-class 'generic-function)
+                                                 (list 'eql name)
+                                                 t)))))
+          (when combination-fun
+            (find-definition-source combination-fun))))
+       ((:package)
+        (when (symbolp name)
+          (let ((package (find-package name)))
+            (when package
+              (find-definition-source package)))))
+       ;; TRANSFORM and OPTIMIZER handling from swank-sbcl
+       ((:transform)
+        (when (symbolp name)
+          (let ((fun-info (sb-int:info :function :info name)))
+            (when fun-info
+              (loop for xform in (sb-c::fun-info-transforms fun-info)
+                    for source = (find-definition-source
+                                  (sb-c::transform-function xform))
+                    for typespec = (sb-kernel:type-specifier
+                                    (sb-c::transform-type xform))
+                    for note = (sb-c::transform-note xform)
+                    do (setf (definition-source-description source)
+                             (if (consp typespec)
+                                 (list (second typespec) note)
+                                 (list note)))
+                    collect source)))))
+       ((:optimizer)
+        (when (symbolp name)
+          (let ((fun-info (sb-int:info :function :info name)))
+            (when fun-info
+              (let ((otypes '((sb-c::fun-info-derive-type . sb-c:derive-type)
+                              (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
+                              (sb-c::fun-info-ltn-annotate . sb-c:ltn-annotate)
+                              (sb-c::fun-info-optimizer . sb-c:optimizer))))
+                (loop for (reader . name) in otypes
+                      for fn = (funcall reader fun-info)
+                      when fn collect
+                      (let ((source (find-definition-source fn)))
+                        (setf (definition-source-description source)
+                              (list name))
+                        source)))))))
+       ((:vop)
+        (when (symbolp name)
+          (let ((fun-info (sb-int:info :function :info name)))
+            (when fun-info
+              (loop for vop in (sb-c::fun-info-templates fun-info)
+                    for source = (find-definition-source
+                                  (sb-c::vop-info-generator-function vop))
+                    do (setf (definition-source-description source)
+                             (list (sb-c::template-name vop)
+                                   (sb-c::template-note vop)))
+                    collect source)))))
+       ((:source-transform)
+        (when (symbolp name)
+          (let ((transform-fun (sb-int:info :function :source-transform name)))
+            (when transform-fun
+              (sb-introspect:find-definition-source transform-fun)))))
+       (t
+        nil)))))
 
 (defun find-definition-source (object)
   (typecase object
@@ -271,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
@@ -297,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
@@ -367,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)))))