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 3)))
  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* ((name (sb-vm::%simple-fun-name o))
  84          (debug-info
  85           (sb-kernel:%code-debug-info
  86            (sb-kernel:fun-code-header(sb-kernel::%closure-fun o))))
  87          (debug-source
  88           (car (sb-c::compiled-debug-info-source debug-info)))
  89          (debug-fun
  90           (loop for debug-fun
  91                 across (sb-c::compiled-debug-info-fun-map debug-info)
  92                 when (and (sb-c::debug-fun-p debug-fun)
  93                           (eql (sb-c::compiled-debug-fun-name debug-fun) name))
  94                 return debug-fun))
  95          (tlf (and debug-fun (sb-c::compiled-debug-fun-tlf-number debug-fun))))
  96     ;; FIXME why only the first debug-source?  can there be >1?
  97     (sb-int:aver (not (cdr (sb-c::compiled-debug-info-source debug-info))))
  98     (make-definition-source
  99      :pathname
 100      (and (eql (sb-c::debug-source-from debug-source) :file)
 101           (parse-namestring (sb-c::debug-source-name debug-source)))
 102      ;; we don't have a real sexp path, annoyingly.  Fake one from the
 103      ;; top-level form number
 104      :character-offset
 105      (and tlf
 106           (elt (sb-c::debug-source-start-positions debug-source) tlf))
 107      :form-path (and tlf (list tlf)))))
 108
 109 (defmethod find-definition-source ((o function))
 110   (cond
 111     ((struct-accessor-p o)
 112      (find-definition-source (struct-accessor-structure-class o)))
 113     ((struct-predicate-p o)
 114      (find-definition-source (struct-predicate-structure-class o)))
 115     (t (find-function-definition-source o))))
 116
 117 (defmethod find-definition-source ((o method))
 118   (find-definition-source (or (sb-pcl::method-fast-function o)
 119                               (sb-pcl:method-function o))))
 120
 121 (defmethod find-definition-source (name)
 122   (and (valid-function-name-p name)
 123        (find-definition-source (or (macro-function name) (fdefinition name)))))
 124
 125 ;; these are internal functions, and probably incomplete
 126 (defun struct-accessor-p (function)
 127   (let ((self (sb-vm::%simple-fun-self function)))
 128     ;; FIXME there are other kinds of struct accessor.  Fill out this list
 129     (member self (list *struct-slotplace-reader*
 130                        *struct-slotplace-writer*))))
 131
 132 (defun struct-predicate-p (function)
 133   (let ((self (sb-vm::%simple-fun-self function)))
 134     ;; FIXME there may be other structure predicate functions
 135     (member self (list *struct-predicate*))))
 136
 137 ;; FIXME need one for constructor too, perhaps
 138
 139 (defun struct-accessor-structure-class (function)
 140   (let ((self (sb-vm::%simple-fun-self function)))
 141     (cond
 142       ((member self (list *struct-slotplace-reader* *struct-slotplace-writer*))
 143        (find-class
 144         (sb-kernel::classoid-name
 145          (sb-kernel::layout-classoid
 146           (sb-kernel:%closure-index-ref function 1)))))
 147       )))
 148
 149 (defun struct-predicate-structure-class (function)
 150   (let ((self (sb-vm::%simple-fun-self function)))
 151     (cond
 152       ((member self (list *struct-predicate*))
 153        (find-class
 154         (sb-kernel::classoid-name
 155          (sb-kernel::layout-classoid
 156           (sb-kernel:%closure-index-ref function 0)))))
 157       )))
 158
 159 (defmethod find-definition-source ((o structure-class))
 160   ;; FIXME we don't get form-number from this, which is a shame
 161   (let ((constructor
 162          (sb-kernel::structure-classoid-constructor
 163           (sb-kernel:classoid-cell-classoid
 164            (sb-int:info :type :classoid (class-name o))))))
 165     (find-definition-source constructor)))
 166