From 30e14368c96ec7eb0a9efe29df6742bbf66be8de Mon Sep 17 00:00:00 2001 From: Daniel Barlow Date: Sat, 11 Oct 2003 16:22:55 +0000 Subject: [PATCH] 0.8.4.20 Is that lint? DEFINITION-SOURCE now has both FORM-PATH (a la CMUCL source path, renamed because "source-path" is just too similar to "source-pathname") and CHARACTER-OFFSET accessors. DEFINITION-SOURCE now works to some extent on struct accessors and predicates. (It gets the pathname right, but I can't find anywhere to get a within-file offset) Commentary and stuff. --- contrib/sb-introspect/sb-introspect.lisp | 148 ++++++++++++++++++++++++------ 1 file changed, 119 insertions(+), 29 deletions(-) diff --git a/contrib/sb-introspect/sb-introspect.lisp b/contrib/sb-introspect/sb-introspect.lisp index fe02c07..baa9a8e 100644 --- a/contrib/sb-introspect/sb-introspect.lisp +++ b/contrib/sb-introspect/sb-introspect.lisp @@ -1,9 +1,30 @@ ;;; This is here as a discussion point, not yet a supported interface. If ;;; you would like to use the functions here, or you would like other -;;; functions to be here, join the debate on sbcl-devel +;;; functions to be here, join the debate on navel@metacircles.com. +;;; List info at http://lists.metacircles.com/cgi-bin/mailman/listinfo/navel -;;; For the avoidance of doubt, the exported interface is the -;;; proposed supported interface. +;;; For the avoidance of doubt, the exported interface is the proposed +;;; supported interface. Anything else is internal, though you're +;;; welcome to argue a case for exporting it. + +;;; If you steal the code from this file to cut and paste into your +;;; own project, there will be much wailing and gnashing of teeth. +;;; Your teeth. If need be, we'll kick them for you. This is a +;;; contrib, we're allowed to look in internals. You're an +;;; application programmer, and are not. + +;;; TODO +;;; 1) structs don't have within-file location info. problem for the +;;; structure itself, accessors and the predicate +;;; 2) what should find-definition-source on a symbol return? there may be +;;; several definitions (class, function, etc) +;;; 3) error handling. Signal random errors, or handle and resignal 'our' +;;; error, or return NIL? +;;; 4) FIXMEs +;;; 5) would be nice to have some interface to the compiler that lets us +;;; fake the filename and position, for use with C-M-x + +(declaim (optimize (debug 3))) (defpackage :sb-introspect (:use "CL") @@ -11,7 +32,8 @@ "FIND-DEFINITION-SOURCE" "DEFINITION-SOURCE" "DEFINITION-SOURCE-PATHNAME" "DEFINITION-NOT-FOUND" "DEFINITION-NAME" - "DEFINITION-SOURCE-FORM-NUMBER" ; unsure. character offset instead? + "DEFINITION-SOURCE-FORM-PATH" + "DEFINITION-SOURCE-CHARACTER-OFFSET" )) (in-package :sb-introspect) @@ -22,49 +44,75 @@ (defun function-arglist (function) "Describe the lambda list for the function designator FUNCTION. -Works for macros, simple functions and generic functions" +Works for macros, simple functions and generic functions. Signals error +if not found" (cond ((valid-function-name-p function) (function-arglist (or (macro-function function) (fdefinition function)))) ((typep function 'generic-function) (sb-pcl::generic-function-pretty-arglist function)) - (t - (sb-impl::%simple-fun-arglist function)))) + (t (sb-impl::%simple-fun-arglist + (sb-impl::%closure-fun function))))) -;;; Considering whether to throw this or something like it when a definition -;;; is unforthcoming. Presently we do something undefined (NIL or random -;;; error) -(define-condition definition-not-found (error) - ((name :initarg :name :reader definition-name)) - (:report (lambda (c s) - (format s "No definition for ~S known" (definition-name c))))) +(defgeneric find-definition-source (thing) + (:documentation "Find the source location that defines THING. +Returns a DEFINITION-SOURCE object")) -;;; find-definition-source returns a definition-source object, with accessors -;;; as per export list. Might not be a struct. -(defstruct definition-source pathname form-number) +;;; This is an opaque object with accessors as per export list. +;;; Might not be a struct. +(defstruct definition-source + pathname ; source file, not fasl + form-path + character-offset + ) -;;; the intention is that everything we're able to query the source -;;; location for, we should be able to do it through this gf -(defgeneric find-definition-source (thing)) +;;; This is kludgey. We expect these functions (the underlying functions, +;;; not the closures) to be in static space and so not move ever. +;;; FIXME It's also possibly wrong: not all structures use these vanilla +;;; accessors, e.g. when the :type option is used +(defvar *struct-slotplace-reader* + (sb-vm::%simple-fun-self #'definition-source-pathname)) +(defvar *struct-slotplace-writer* + (sb-vm::%simple-fun-self #'(setf definition-source-pathname))) +(defvar *struct-predicate* + (sb-vm::%simple-fun-self #'definition-source-p)) -;;; breaks on structure accessors, probably other closures as well -(defmethod find-definition-source ((o function)) +;; Internal-only, don't call this directly +(defun find-function-definition-source (o) (let* ((name (sb-vm::%simple-fun-name o)) (debug-info - (sb-kernel:%code-debug-info (sb-kernel:fun-code-header o))) - (debug-source (car (sb-c::compiled-debug-info-source debug-info)))) + (sb-kernel:%code-debug-info + (sb-kernel:fun-code-header(sb-kernel::%closure-fun o)))) + (debug-source + (car (sb-c::compiled-debug-info-source debug-info))) + (debug-fun + (loop for debug-fun + across (sb-c::compiled-debug-info-fun-map debug-info) + when (and (sb-c::debug-fun-p debug-fun) + (eql (sb-c::compiled-debug-fun-name debug-fun) name)) + return debug-fun)) + (tlf (and debug-fun (sb-c::compiled-debug-fun-tlf-number debug-fun)))) ;; FIXME why only the first debug-source? can there be >1? (sb-int:aver (not (cdr (sb-c::compiled-debug-info-source debug-info)))) (make-definition-source :pathname (and (eql (sb-c::debug-source-from debug-source) :file) (parse-namestring (sb-c::debug-source-name debug-source))) - :form-number - (loop for debug-fun across (sb-c::compiled-debug-info-fun-map debug-info) - when (and (sb-c::debug-fun-p debug-fun) - (eql (sb-c::compiled-debug-fun-name debug-fun) name)) - return (sb-c::compiled-debug-fun-tlf-number debug-fun))))) + ;; we don't have a real sexp path, annoyingly. Fake one from the + ;; top-level form number + :character-offset + (and tlf + (elt (sb-c::debug-source-start-positions debug-source) tlf)) + :form-path (and tlf (list tlf))))) + +(defmethod find-definition-source ((o function)) + (cond + ((struct-accessor-p o) + (find-definition-source (struct-accessor-structure-class o))) + ((struct-predicate-p o) + (find-definition-source (struct-predicate-structure-class o))) + (t (find-function-definition-source o)))) (defmethod find-definition-source ((o method)) (find-definition-source (or (sb-pcl::method-fast-function o) @@ -74,3 +122,45 @@ Works for macros, simple functions and generic functions" (and (valid-function-name-p name) (find-definition-source (or (macro-function name) (fdefinition name))))) +;; these are internal functions, and probably incomplete +(defun struct-accessor-p (function) + (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*)))) + +(defun struct-predicate-p (function) + (let ((self (sb-vm::%simple-fun-self function))) + ;; FIXME there may be other structure predicate functions + (member self (list *struct-predicate*)))) + +;; FIXME need one for constructor too, perhaps + +(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))))) + ))) + +(defun struct-predicate-structure-class (function) + (let ((self (sb-vm::%simple-fun-self function))) + (cond + ((member self (list *struct-predicate*)) + (find-class + (sb-kernel::classoid-name + (sb-kernel::layout-classoid + (sb-kernel:%closure-index-ref function 0))))) + ))) + +(defmethod find-definition-source ((o structure-class)) + ;; FIXME we don't get form-number from this, which is a shame + (let ((constructor + (sb-kernel::structure-classoid-constructor + (sb-kernel:classoid-cell-classoid + (sb-int:info :type :classoid (class-name o)))))) + (find-definition-source constructor))) + -- 1.7.10.4