1 ;;; This is here as a discussion point, not yet a supported interface. If
2 ;;; you would like to use the functions here, or you would like other
3 ;;; functions to be here, join the debate on navel@metacircles.com.
4 ;;; List info at http://lists.metacircles.com/cgi-bin/mailman/listinfo/navel
6 ;;; For the avoidance of doubt, the exported interface is the proposed
7 ;;; supported interface. Anything else is internal, though you're
8 ;;; welcome to argue a case for exporting it.
10 ;;; If you steal the code from this file to cut and paste into your
11 ;;; own project, there will be much wailing and gnashing of teeth.
12 ;;; Your teeth. If need be, we'll kick them for you. This is a
13 ;;; contrib, we're allowed to look in internals. You're an
14 ;;; application programmer, and are not.
17 ;;; 1) structs don't have within-file location info. problem for the
18 ;;; structure itself, accessors and the predicate
19 ;;; 2) what should find-definition-source on a symbol return? there may be
20 ;;; several definitions (class, function, etc)
21 ;;; 3) error handling. Signal random errors, or handle and resignal 'our'
22 ;;; error, or return NIL?
24 ;;; 5) would be nice to have some interface to the compiler that lets us
25 ;;; fake the filename and position, for use with C-M-x
27 (declaim (optimize (debug 1)))
29 (defpackage :sb-introspect
31 (:export "FUNCTION-ARGLIST" "VALID-FUNCTION-NAME-P"
32 "FIND-DEFINITION-SOURCE"
33 "DEFINITION-SOURCE" "DEFINITION-SOURCE-PATHNAME"
34 "DEFINITION-NOT-FOUND" "DEFINITION-NAME"
35 "DEFINITION-SOURCE-FORM-PATH"
36 "DEFINITION-SOURCE-CHARACTER-OFFSET"
38 (in-package :sb-introspect)
41 (defun valid-function-name-p (name)
42 "True if NAME denotes a function name that can be passed to MACRO-FUNCTION or FDEFINITION "
43 (and (sb-int:valid-function-name-p name) t))
45 (defun function-arglist (function)
46 "Describe the lambda list for the function designator FUNCTION.
47 Works for macros, simple functions and generic functions. Signals error
49 (cond ((valid-function-name-p function)
51 (or (macro-function function) (fdefinition function))))
52 ((typep function 'generic-function)
53 (sb-pcl::generic-function-pretty-arglist function))
54 (t (sb-impl::%simple-fun-arglist
55 (sb-impl::%closure-fun function)))))
57 (defgeneric find-definition-source (thing)
58 (:documentation "Find the source location that defines THING.
59 Returns a DEFINITION-SOURCE object"))
61 ;;; This is an opaque object with accessors as per export list.
62 ;;; Might not be a struct.
64 (defstruct definition-source
65 pathname ; source file, not fasl
70 ;;; This is kludgey. We expect these functions (the underlying functions,
71 ;;; not the closures) to be in static space and so not move ever.
72 ;;; FIXME It's also possibly wrong: not all structures use these vanilla
73 ;;; accessors, e.g. when the :type option is used
74 (defvar *struct-slotplace-reader*
75 (sb-vm::%simple-fun-self #'definition-source-pathname))
76 (defvar *struct-slotplace-writer*
77 (sb-vm::%simple-fun-self #'(setf definition-source-pathname)))
78 (defvar *struct-predicate*
79 (sb-vm::%simple-fun-self #'definition-source-p))
81 ;; Internal-only, don't call this directly
82 (defun find-function-definition-source (o)
84 (sb-kernel:%code-debug-info
85 (sb-kernel:fun-code-header(sb-kernel::%closure-fun o))))
87 (car (sb-c::compiled-debug-info-source debug-info)))
88 (debug-fun (elt (sb-c::compiled-debug-info-fun-map debug-info) 0))
89 (tlf (and debug-fun (sb-c::compiled-debug-fun-tlf-number debug-fun))))
90 ;; HAZARDOUS ASSUMPTION: in CMUCL it's possible to get >1 debug-source
91 ;; for a debug-info (one per file). In SBCL the function that builds
92 ;; debug-sources always produces singleton lists
93 (sb-int:aver (not (cdr (sb-c::compiled-debug-info-source debug-info))))
94 (make-definition-source
96 (and (eql (sb-c::debug-source-from debug-source) :file)
97 (parse-namestring (sb-c::debug-source-name debug-source)))
98 ;; we don't have a real sexp path, annoyingly. Fake one from the
99 ;; top-level form number
102 (elt (sb-c::debug-source-start-positions debug-source) tlf))
103 :form-path (and tlf (list tlf)))))
105 (defmethod find-definition-source ((o function))
107 ((struct-accessor-p o)
108 (find-definition-source (struct-accessor-structure-class o)))
109 ((struct-predicate-p o)
110 (find-definition-source (struct-predicate-structure-class o)))
111 (t (find-function-definition-source o))))
113 (defmethod find-definition-source ((o method))
114 (find-definition-source (or (sb-pcl::method-fast-function o)
115 (sb-pcl:method-function o))))
117 (defmethod find-definition-source (name)
118 (and (valid-function-name-p name)
119 (find-definition-source (or (macro-function name) (fdefinition name)))))
121 ;; these are internal functions, and probably incomplete
122 (defun struct-accessor-p (function)
123 (let ((self (sb-vm::%simple-fun-self function)))
124 ;; FIXME there are other kinds of struct accessor. Fill out this list
125 (member self (list *struct-slotplace-reader*
126 *struct-slotplace-writer*))))
128 (defun struct-predicate-p (function)
129 (let ((self (sb-vm::%simple-fun-self function)))
130 ;; FIXME there may be other structure predicate functions
131 (member self (list *struct-predicate*))))
133 ;; FIXME need one for constructor too, perhaps
135 (defun struct-accessor-structure-class (function)
136 (let ((self (sb-vm::%simple-fun-self function)))
138 ((member self (list *struct-slotplace-reader* *struct-slotplace-writer*))
140 (sb-kernel::classoid-name
141 (sb-kernel::layout-classoid
142 (sb-kernel:%closure-index-ref function 1)))))
145 (defun struct-predicate-structure-class (function)
146 (let ((self (sb-vm::%simple-fun-self function)))
148 ((member self (list *struct-predicate*))
150 (sb-kernel::classoid-name
151 (sb-kernel::layout-classoid
152 (sb-kernel:%closure-index-ref function 0)))))
155 (defmethod find-definition-source ((o structure-class))
156 ;; FIXME we don't get form-number from this, which is a shame
158 (sb-kernel::structure-classoid-constructor
159 (sb-kernel:classoid-cell-classoid
160 (sb-int:info :type :classoid (class-name o))))))
161 (find-definition-source constructor)))
163 (provide 'sb-introspect)