contrib/sb-introspect/sb-introspect.lisp

   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
   5
   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.
   9
  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.
  15
  16 ;;; TODO
  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?
  23 ;;; 4) FIXMEs
  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
  26
  27 (declaim (optimize (debug 1)))
  28
  29 (defpackage :sb-introspect
  30   (:use "CL")
  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"
  37            ))
  38 (in-package :sb-introspect)
  39
  40
  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))
  44
  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
  48 if not found"
  49   (cond ((valid-function-name-p function)
  50          (function-arglist
  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)))))
  56
  57 (defgeneric find-definition-source (thing)
  58   (:documentation "Find the source location that defines THING.
  59 Returns a DEFINITION-SOURCE object"))
  60
  61 ;;; This is an opaque object with accessors as per export list.
  62 ;;; Might not be a struct.
  63
  64 (defstruct definition-source
  65   pathname                              ; source file, not fasl
  66   form-path
  67   character-offset
  68   )
  69
  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))
  80
  81 ;; Internal-only, don't call this directly
  82 (defun find-function-definition-source (o)
  83   (let* ((debug-info
  84           (sb-kernel:%code-debug-info
  85            (sb-kernel:fun-code-header(sb-kernel::%closure-fun o))))
  86          (debug-source
  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
  95      :pathname
  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
 100      :character-offset
 101      (and tlf
 102           (elt (sb-c::debug-source-start-positions debug-source) tlf))
 103      :form-path (and tlf (list tlf)))))
 104
 105 (defmethod find-definition-source ((o function))
 106   (cond
 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))))
 112
 113 (defmethod find-definition-source ((o method))
 114   (find-definition-source (or (sb-pcl::method-fast-function o)
 115                               (sb-pcl:method-function o))))
 116
 117 (defmethod find-definition-source (name)
 118   (and (valid-function-name-p name)
 119        (find-definition-source (or (macro-function name) (fdefinition name)))))
 120
 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*))))
 127
 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*))))
 132
 133 ;; FIXME need one for constructor too, perhaps
 134
 135 (defun struct-accessor-structure-class (function)
 136   (let ((self (sb-vm::%simple-fun-self function)))
 137     (cond
 138       ((member self (list *struct-slotplace-reader* *struct-slotplace-writer*))
 139        (find-class
 140         (sb-kernel::classoid-name
 141          (sb-kernel::layout-classoid
 142           (sb-kernel:%closure-index-ref function 1)))))
 143       )))
 144
 145 (defun struct-predicate-structure-class (function)
 146   (let ((self (sb-vm::%simple-fun-self function)))
 147     (cond
 148       ((member self (list *struct-predicate*))
 149        (find-class
 150         (sb-kernel::classoid-name
 151          (sb-kernel::layout-classoid
 152           (sb-kernel:%closure-index-ref function 0)))))
 153       )))
 154
 155 (defmethod find-definition-source ((o structure-class))
 156   ;; FIXME we don't get form-number from this, which is a shame
 157   (let ((constructor
 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)))
 162