X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=contrib%2Fsb-introspect%2Fsb-introspect.lisp;h=6f1ef01a5902060e9c8ec3348b360156748ea234;hb=990728854b8ba017888811d1b0453b15dfa8a581;hp=debda196cbf50555cb8b9529e521e9c3ee321fa6;hpb=e15ca902a6c4eb6e4695e71400edbbd57c5e57cd;p=sbcl.git

diff --git a/contrib/sb-introspect/sb-introspect.lisp b/contrib/sb-introspect/sb-introspect.lisp
index debda19..6f1ef01 100644
--- a/contrib/sb-introspect/sb-introspect.lisp
+++ b/contrib/sb-introspect/sb-introspect.lisp
@@ -36,7 +36,12 @@
            "DEFINITION-SOURCE-PLIST"
            "DEFINITION-NOT-FOUND" "DEFINITION-NAME"
            "FIND-FUNCTION-CALLEES"
-           "FIND-FUNCTION-CALLERS"))
+           "FIND-FUNCTION-CALLERS"
+           "WHO-BINDS"
+           "WHO-CALLS"
+           "WHO-REFERENCES"
+           "WHO-SETS"
+           "WHO-MACROEXPANDS"))
 
 (in-package :sb-introspect)
 
@@ -315,8 +320,16 @@ If an unsupported TYPE is requested, the function will return NIL.
        (when source
          (setf (definition-source-description source)
                (append (method-qualifiers object)
-                       (sb-pcl::unparse-specializers
-                        (sb-mop:method-specializers object)))))
+                       (if (sb-mop:method-generic-function object)
+                           (sb-pcl::unparse-specializers
+                            (sb-mop:method-generic-function object)
+                            (sb-mop:method-specializers object))
+                           (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)
@@ -389,16 +402,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 extended function designator FUNCTION.
-Works for special-operators, macros, simple functions and generic
-functions.  Signals error if not found"
+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 (and (symbolp function)
                                     (macro-function function))
                                (fdefinition function))))
         ((typep function 'generic-function)
          (sb-pcl::generic-function-pretty-arglist function))
-        (t (sb-impl::%simple-fun-arglist
-            (sb-impl::%closure-fun function)))))
+        #+sb-eval
+        ((typep function 'sb-eval:interpreted-function)
+         (sb-eval:interpreted-function-lambda-list function))
+        (t (sb-kernel:%simple-fun-arglist (sb-kernel:%fun-fun function)))))
 
 (defun struct-accessor-structure-class (function)
   (let ((self (sb-vm::%simple-fun-self function)))
@@ -500,4 +516,76 @@ constant pool."
                          function))
             (funcall fn obj))))))))
 
+;;; XREF facility
+
+(defun get-simple-fun (functoid)
+  (etypecase functoid
+    (sb-kernel::fdefn
+     (get-simple-fun (sb-vm::fdefn-fun functoid)))
+    ((or null sb-impl::funcallable-instance)
+     nil)
+    (function
+     (sb-kernel::%closure-fun functoid))))
+
+(defun collect-xref (kind-index wanted-name)
+  (let ((ret nil))
+    (dolist (env sb-c::*info-environment* ret)
+      ;; Loop through the infodb ...
+      (sb-c::do-info (env :class class :type type :name info-name
+                          :value value)
+        ;; ... looking for function or macro definitions
+        (when (and (eql class :function)
+                   (or (eql type :macro-function)
+                       (eql type :definition)))
+          ;; Get a simple-fun for the definition, and an xref array
+          ;; from the table if available.
+          (let* ((simple-fun (get-simple-fun value))
+                 (xrefs (when simple-fun
+                          (sb-vm::%simple-fun-xrefs simple-fun)))
+                 (array (when xrefs
+                          (aref xrefs kind-index))))
+            ;; Loop through the name/path xref entries in the table
+            (loop for i from 0 below (length array) by 2
+                  for xref-name = (aref array i)
+                  for xref-path = (aref array (1+ i))
+                  do (when (eql xref-name wanted-name)
+                       (let ((source-location
+                              (find-function-definition-source simple-fun)))
+                         ;; Use the more accurate source path from
+                         ;; the xref entry.
+                         (setf (definition-source-form-path source-location)
+                               xref-path)
+                         (push (cons info-name source-location)
+                               ret))))))))))
+
+(defun who-calls (function-name)
+  "Use the xref facility to search for source locations where the
+global function named FUNCTION-NAME is called. Returns a list of
+function name, definition-source pairs."
+  (collect-xref #.(position :calls sb-c::*xref-kinds*) function-name))
+
+(defun who-binds (symbol)
+  "Use the xref facility to search for source locations where the
+special variable SYMBOL is rebound. Returns a list of function name,
+definition-source pairs."
+  (collect-xref #.(position :binds sb-c::*xref-kinds*) symbol))
+
+(defun who-references (symbol)
+  "Use the xref facility to search for source locations where the
+special variable or constant SYMBOL is read. Returns a list of function
+name, definition-source pairs."
+  (collect-xref #.(position :references sb-c::*xref-kinds*) symbol))
+
+(defun who-sets (symbol)
+  "Use the xref facility to search for source locations where the
+special variable SYMBOL is written to. Returns a list of function name,
+definition-source pairs."
+  (collect-xref #.(position :sets sb-c::*xref-kinds*) symbol))
+
+(defun who-macroexpands (macro-name)
+  "Use the xref facility to search for source locations where the
+macro MACRO-NAME is expanded. Returns a list of function name,
+definition-source pairs."
+  (collect-xref #.(position :macroexpands sb-c::*xref-kinds*) macro-name))
+
 (provide 'sb-introspect)