X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-introspect%2Fsb-introspect.lisp;h=c48eb28b38357a639ef0a58a6ca825bb4c3d7eab;hb=b6094d5640a59f36d2f727df08b271c422aa9e1c;hp=61fe9359538379529f697e1547dd8725f6cd4d7c;hpb=ab9ae982b1b242fc1b25547b5ef5939ee44aec1c;p=sbcl.git diff --git a/contrib/sb-introspect/sb-introspect.lisp b/contrib/sb-introspect/sb-introspect.lisp index 61fe935..c48eb28 100644 --- a/contrib/sb-introspect/sb-introspect.lisp +++ b/contrib/sb-introspect/sb-introspect.lisp @@ -28,16 +28,19 @@ (defpackage :sb-introspect (:use "CL") - (:export "FUNCTION-ARGLIST" "VALID-FUNCTION-NAME-P" - "FIND-DEFINITION-SOURCE" - "DEFINITION-SOURCE" "DEFINITION-SOURCE-PATHNAME" - "DEFINITION-NOT-FOUND" "DEFINITION-NAME" - "DEFINITION-SOURCE-FORM-PATH" - "DEFINITION-SOURCE-CHARACTER-OFFSET" - "DEFINITION-SOURCE-FILE-WRITE-DATE" - "FIND-FUNCTION-CALLEES" - "FIND-FUNCTION-CALLERS" - )) + (:export "FUNCTION-ARGLIST" + "VALID-FUNCTION-NAME-P" + "FIND-DEFINITION-SOURCE" + "DEFINITION-SOURCE" + "DEFINITION-SOURCE-PATHNAME" + "DEFINITION-SOURCE-FORM-PATH" + "DEFINITION-SOURCE-CHARACTER-OFFSET" + "DEFINITION-SOURCE-FILE-WRITE-DATE" + "DEFINITION-SOURCE-PLIST" + "DEFINITION-NOT-FOUND" "DEFINITION-NAME" + "FIND-FUNCTION-CALLEES" + "FIND-FUNCTION-CALLERS")) + (in-package :sb-introspect) ;;;; Internal interface for SBCL debug info @@ -74,13 +77,7 @@ include the pathname of the file and the position of the definition." (declaim (ftype (function (debug-info) debug-source) debug-info-source)) (defun debug-info-source (debug-info) - (destructuring-bind (debug-source &rest other-debug-sources) - (sb-c::compiled-debug-info-source debug-info) - ;; COMPILED-DEBUG-INFO-SOURCES can return a list but we expect - ;; this to always contain exactly one element in SBCL. The list - ;; interface is inherited from CMUCL. -luke (12/Mar/2005) - (assert (null other-debug-sources)) - debug-source)) + (sb-c::debug-info-source debug-info)) (declaim (ftype (function (debug-info) debug-function) debug-info-debug-function)) (defun debug-info-debug-function (debug-info) @@ -105,7 +102,9 @@ include the pathname of the file and the position of the definition." (character-offset nil :type (or null integer)) ;; File-write-date of the source file when compiled. ;; Null if not compiled from a file. - (file-write-date nil :type (or null integer))) + (file-write-date nil :type (or null integer)) + ;; plist from WITH-COMPILATION-UNIT + (plist nil)) (defun find-definition-source (object) (etypecase object @@ -145,7 +144,8 @@ include the pathname of the file and the position of the definition." ;; debug-source. FIXME: We could use sb-di:code-locations to get ;; a full source path. -luke (12/Mar/2005) :form-path (if tlf (list tlf)) - :file-write-date (sb-c::debug-source-created debug-source)))) + :file-write-date (sb-c::debug-source-created debug-source) + :plist (sb-c::debug-source-plist debug-source)))) ;;; This is kludgey. We expect these functions (the underlying functions, ;;; not the closures) to be in static space and so not move ever. @@ -162,7 +162,7 @@ include the pathname of the file and the position of the definition." (let ((self (sb-vm::%simple-fun-self function))) ;; FIXME there are other kinds of struct accessor. Fill out this list (member self (list *struct-slotplace-reader* - *struct-slotplace-writer*)))) + *struct-slotplace-writer*)))) (defun struct-predicate-p (function) (let ((self (sb-vm::%simple-fun-self function))) @@ -174,22 +174,22 @@ include the pathname of the file and the position of the definition." "Describe the lambda list for the function designator FUNCTION. Works for special-operators, macros, simple functions and generic functions. Signals error if not found" - (cond ((valid-function-name-p function) + (cond ((valid-function-name-p function) (function-arglist - (or (macro-function function) (fdefinition function)))) + (or (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))))) + (t (sb-impl::%simple-fun-arglist + (sb-impl::%closure-fun function))))) (defun struct-accessor-structure-class (function) (let ((self (sb-vm::%simple-fun-self function))) (cond ((member self (list *struct-slotplace-reader* *struct-slotplace-writer*)) (find-class - (sb-kernel::classoid-name - (sb-kernel::layout-classoid - (sb-kernel:%closure-index-ref function 1))))) + (sb-kernel::classoid-name + (sb-kernel::layout-classoid + (sb-kernel:%closure-index-ref function 1))))) ))) (defun struct-predicate-structure-class (function) @@ -197,14 +197,14 @@ functions. Signals error if not found" (cond ((member self (list *struct-predicate*)) (find-class - (sb-kernel::classoid-name - (sb-kernel::layout-classoid - (sb-kernel:%closure-index-ref function 0))))) + (sb-kernel::classoid-name + (sb-kernel::layout-classoid + (sb-kernel:%closure-index-ref function 0))))) ))) ;;;; find callers/callees, liberated from Helmut Eller's code in SLIME -;;; This interface is trmendously experimental. +;;; This interface is trmendously experimental. ;;; For the moment I'm taking the view that FDEFN is an internal ;;; object (one out of one CMUCL developer surveyed didn't know what @@ -219,39 +219,39 @@ functions. Signals error if not found" (defun find-function-callees (function) "Return functions called by FUNCTION." (let ((callees '())) - (map-code-constants + (map-code-constants (sb-kernel:fun-code-header function) (lambda (obj) (when (sb-kernel:fdefn-p obj) - (push (sb-kernel:fdefn-fun obj) - callees)))) + (push (sb-kernel:fdefn-fun obj) + callees)))) callees)) -(defun find-function-callers (function &optional (spaces '(:read-only :static - :dynamic))) +(defun find-function-callers (function &optional (spaces '(:read-only :static + :dynamic))) "Return functions which call FUNCTION, by searching SPACES for code objects" (let ((referrers '())) - (map-caller-code-components + (map-caller-code-components function spaces (lambda (code) (let ((entry (sb-kernel:%code-entry-points code))) - (cond ((not entry) - (push (princ-to-string code) referrers)) - (t - (loop for e = entry then (sb-kernel::%simple-fun-next e) - while e - do (pushnew e referrers))))))) + (cond ((not entry) + (push (princ-to-string code) referrers)) + (t + (loop for e = entry then (sb-kernel::%simple-fun-next e) + while e + do (pushnew e referrers))))))) referrers)) (declaim (inline map-code-constants)) (defun map-code-constants (code fn) "Call FN for each constant in CODE's constant pool." (check-type code sb-kernel:code-component) - (loop for i from sb-vm:code-constants-offset below - (sb-kernel:get-header-data code) - do (funcall fn (sb-kernel:code-header-ref code i)))) + (loop for i from sb-vm:code-constants-offset below + (sb-kernel:get-header-data code) + do (funcall fn (sb-kernel:code-header-ref code i)))) (declaim (inline map-allocated-code-components)) (defun map-allocated-code-components (spaces fn) @@ -262,7 +262,7 @@ list of the symbols :dynamic, :static, or :read-only." (sb-vm::map-allocated-objects (lambda (obj header size) (when (= sb-vm:code-header-widetag header) - (funcall fn obj size))) + (funcall fn obj size))) space))) (declaim (inline map-caller-code-components)) @@ -271,15 +271,15 @@ list of the symbols :dynamic, :static, or :read-only." constant pool." (let ((function (coerce function 'function))) (map-allocated-code-components - spaces + spaces (lambda (obj size) (declare (ignore size)) - (map-code-constants - obj - (lambda (constant) - (when (and (sb-kernel:fdefn-p constant) - (eq (sb-kernel:fdefn-fun constant) - function)) - (funcall fn obj)))))))) + (map-code-constants + obj + (lambda (constant) + (when (and (sb-kernel:fdefn-p constant) + (eq (sb-kernel:fdefn-fun constant) + function)) + (funcall fn obj)))))))) (provide 'sb-introspect)