X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-introspect%2Fsb-introspect.lisp;h=488654d8e85f26f1b3348cc2e8a43ff278fa48c0;hb=37200d73dfca16507809778574092cfb998711d5;hp=777ab6d70d38cc649ad831729b6268beff4d7b98;hpb=597ec21a0c823bf356fd6446f279ae2dddcbde66;p=sbcl.git diff --git a/contrib/sb-introspect/sb-introspect.lisp b/contrib/sb-introspect/sb-introspect.lisp index 777ab6d..488654d 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) @@ -219,11 +224,12 @@ If an unsupported TYPE is requested, the function will return NIL. (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))))) + (find-method #'sb-mop:find-method-combination + nil + (list (find-class 'generic-function) + (list 'eql name) + t) + nil))) (when combination-fun (find-definition-source combination-fun)))) ((:package) @@ -315,8 +321,11 @@ 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 @@ -332,8 +341,10 @@ If an unsupported TYPE is requested, the function will return NIL. (struct-predicate-structure-class object))) (t (find-function-definition-source object)))) + ((or condition standard-object structure-object) + (find-definition-source (class-of object))) (t - (error "Don't know how to retrive source location for a ~S~%" + (error "Don't know how to retrieve source location for a ~S~%" (type-of object))))) (defun find-function-definition-source (function) @@ -343,8 +354,14 @@ If an unsupported TYPE is requested, the function will return NIL. (tlf (if debug-fun (sb-c::compiled-debug-fun-tlf-number debug-fun)))) (make-definition-source :pathname - (if (eql (sb-c::debug-source-from debug-source) :file) - (parse-namestring (sb-c::debug-source-name debug-source))) + ;; KLUDGE: at the moment, we don't record the correct toplevel + ;; form number for forms processed by EVAL (including EVAL-WHEN + ;; :COMPILE-TOPLEVEL). Until that's fixed, don't return a + ;; DEFINITION-SOURCE with a pathname. (When that's fixed, take + ;; out the (not (debug-source-form ...)) test. + (if (and (sb-c::debug-source-namestring debug-source) + (not (sb-c::debug-source-form debug-source))) + (parse-namestring (sb-c::debug-source-namestring debug-source))) :character-offset (if tlf (elt (sb-c::debug-source-start-positions debug-source) tlf)) @@ -406,8 +423,7 @@ not found" #+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))))) + (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))) @@ -490,7 +506,8 @@ list of the symbols :dynamic, :static, or :read-only." (lambda (obj header size) (when (= sb-vm:code-header-widetag header) (funcall fn obj size))) - space))) + space + t))) (declaim (inline map-caller-code-components)) (defun map-caller-code-components (function spaces fn) @@ -509,4 +526,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)