[slime-cvs] CVS slime
jsnellman
jsnellman at common-lisp.net
Tue Dec 5 04:46:07 UTC 2006
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv30892
Modified Files:
ChangeLog swank-sbcl.lisp
Log Message:
Xref support for SBCL (requires SBCL 1.0.0.18).
* swank-sbcl.lisp (who-calls): New function, fetch xref data from
sb-introspect.
(who-binds): Ditto.
(who-sets): Ditto.
(who-references): Ditto.
(who-macroexpands): Ditto.
(defxref): New macro, create the above functions.
(source-location-for-xref-data): New, map from sb-introspect xref
format to the Swank xref format.
(sanitize-xrefs): Map PCL method names to something more readable.
(string-path-snippet): New function, finds a more accurate source
snippet for definition source locations which have both an
:emacs-string and a full source path available. Otherwise the xref
location would point to the toplevel form rather than the exact
form for functions compiled with C-c C-c.
(source-file-position): New function, somewhat like
source-path-file-position but uses the source-file cache, handles
missing form-paths more gracefully.
(make-definition-source-location): use the above two functions
(sbcl-with-xref-p): new function, detect whether SBCL has xref support
for backwards compability
--- /project/slime/cvsroot/slime/ChangeLog 2006/11/26 18:08:30 1.1009
+++ /project/slime/cvsroot/slime/ChangeLog 2006/12/05 04:46:06 1.1010
@@ -1,3 +1,28 @@
+2006-12-05 Juho Snellman <jsnell at iki.fi>
+ Real xref support for SBCL (requires SBCL 1.0.0.18).
+
+ * swank-sbcl.lisp (who-calls): New function, fetch xref data from
+ sb-introspect.
+ (who-binds): Ditto.
+ (who-sets): Ditto.
+ (who-references): Ditto.
+ (who-macroexpands): Ditto.
+ (defxref): New macro, create the above functions.
+ (source-location-for-xref-data): New, map from sb-introspect xref
+ format to the Swank xref format.
+ (sanitize-xrefs): Map PCL method names to something more readable.
+ (string-path-snippet): New function, finds a more accurate source
+ snippet for definition source locations which have both an
+ :emacs-string and a full source path available. Otherwise the xref
+ location would point to the toplevel form rather than the exact
+ form for functions compiled with C-c C-c.
+ (source-file-position): New function, somewhat like
+ source-path-file-position but uses the source-file cache, handles
+ missing form-paths more gracefully.
+ (make-definition-source-location): Use the above two functions.
+ (sbcl-with-xref-p): New function, detect whether SBCL has xref support
+ for backwards compability.
+
2006-11-26 Juho Snellman <jsnell at iki.fi>
* swank-source-file-cache.lisp (buffer-first-change): Check
--- /project/slime/cvsroot/slime/swank-sbcl.lisp 2006/11/19 21:33:03 1.171
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2006/12/05 04:46:06 1.172
@@ -35,6 +35,11 @@
(defun sbcl-with-weak-hash-tables ()
(if (find-symbol "HASH-TABLE-WEAKNESS" "SB-EXT")
'(and)
+ '(or)))
+ ;; And for xref support (1.0.1)
+ (defun sbcl-with-xref-p ()
+ (if (find-symbol "WHO-CALLS" "SB-INTROSPECT")
+ '(and)
'(or))))
;;; swank-mop
@@ -485,35 +490,46 @@
plist
(cond
(emacs-buffer
- (let ((pos (if form-path
- (with-debootstrapping
- (source-path-string-position
- form-path emacs-string))
- character-offset)))
+ (let* ((pos (if form-path
+ (with-debootstrapping
+ (source-path-string-position form-path emacs-string))
+ character-offset))
+ (snippet (string-path-snippet emacs-string form-path pos)))
(make-location `(:buffer ,emacs-buffer)
`(:position ,(+ pos emacs-position))
- `(:snippet ,emacs-string))))
+ `(:snippet ,snippet))))
((not pathname)
`(:error ,(format nil "Source of ~A ~A not found"
(string-downcase type) name)))
(t
(let* ((namestring (namestring (translate-logical-pathname pathname)))
- (*readtable* (guess-readtable-for-filename namestring))
- (pos (1+ (with-debootstrapping
- ;; Some internal functions have no source path
- ;; or offset available, just the file (why?).
- ;; In these cases we can at least try to open
- ;; the right file.
- (if form-path
- (source-path-file-position form-path
- pathname)
- 0))))
- (snippet (source-hint-snippet namestring
- file-write-date pos)))
+ (pos (source-file-position namestring file-write-date form-path
+ character-offset))
+ (snippet (source-hint-snippet namestring file-write-date pos)))
(make-location `(:file ,namestring)
`(:position ,pos)
`(:snippet ,snippet))))))))
+(defun string-path-snippet (string form-path position)
+ (if form-path
+ ;; If we have a form-path, use it to derive a more accurate
+ ;; snippet, so that we can point to the individual form rather
+ ;; than just the toplevel form.
+ (multiple-value-bind (data end)
+ (let ((*read-suppress* t))
+ (read-from-string string nil nil :start position))
+ (declare (ignore data))
+ (subseq string position end))
+ string))
+
+(defun source-file-position (filename write-date form-path character-offset)
+ (let ((source (get-source-code filename write-date))
+ (*readtable* (guess-readtable-for-filename filename)))
+ (1+ (with-debootstrapping
+ (if form-path
+ (source-path-string-position form-path source)
+ (or character-offset 0))))))
+
(defun source-hint-snippet (filename write-date position)
(let ((source (get-source-code filename write-date)))
(with-input-from-string (s source)
@@ -576,6 +592,30 @@
(describe (find-class symbol)))
(:type
(describe (sb-kernel:values-specifier-type symbol)))))
+
+#+#.(swank-backend::sbcl-with-xref-p)
+(progn
+ (defmacro defxref (name)
+ `(defimplementation ,name (what)
+ (sanitize-xrefs
+ (mapcar #'source-location-for-xref-data
+ (,(find-symbol (symbol-name name) "SB-INTROSPECT")
+ what)))))
+ (defxref who-calls)
+ (defxref who-binds)
+ (defxref who-sets)
+ (defxref who-references)
+ (defxref who-macroexpands))
+
+(defun source-location-for-xref-data (xref-data)
+ (let ((name (car xref-data))
+ (source-location (cdr xref-data)))
+ (list name
+ (handler-case (make-definition-source-location source-location
+ 'function
+ name)
+ (error (e)
+ (list :error (format nil "Error: ~A" e)))))))
(defimplementation list-callers (symbol)
(let ((fn (fdefinition symbol)))
@@ -587,11 +627,20 @@
(sanitize-xrefs
(mapcar #'function-dspec (sb-introspect:find-function-callees fn)))))
-(defun sanitize-xrefs (x)
+(defun sanitize-xrefs (xrefs)
(remove-duplicates
(remove-if (lambda (f)
(member f (ignored-xref-function-names)))
- x
+ (loop for entry in xrefs
+ for name = (car entry)
+ collect (if (and (consp name)
+ (member (car name)
+ '(sb-pcl::fast-method
+ sb-pcl::slow-method
+ sb-pcl::method)))
+ (cons (cons 'defmethod (cdr name))
+ (cdr entry))
+ entry))
:key #'car)
:test (lambda (a b)
(and (eq (first a) (first b))
More information about the slime-cvs
mailing list