[slime-cvs] CVS slime
CVS User trittweiler
trittweiler at common-lisp.net
Sun Sep 20 09:39:16 UTC 2009
Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv30395
Modified Files:
swank.lisp swank-backend.lisp slime.el ChangeLog
Log Message:
Generalize M-? (or M-_ respectively.)
It will now list:
- call sites for functions,
- macroexpand sites for macros,
- binding, setting, referencing sites for variables,
- specializing methods for classes.
* slime.el (slime-xref): Deal with :not-implemented.
(slime-xrefs): New. Makes RPC request to XREFS.
(slime-edit-callers): Renamed to `slime-edit-uses'.
(slime-edit-uses): Use slime-xrefs.
* swank-backend.lisp (who-*): Add default implementation which
returns :not-implemented.
* swank.lisp (xref-doit): Extracted from XREF.
(xref): Pass over :not-implemented to Emacs side.
(xrefs): New slime fun. To return results of multiple XREF
requests at once.
--- /project/slime/cvsroot/slime/swank.lisp 2009/09/16 15:46:27 1.660
+++ /project/slime/cvsroot/slime/swank.lisp 2009/09/20 09:39:16 1.661
@@ -3235,19 +3235,32 @@
(unless error
(mapcar #'xref>elisp (find-definitions sexp)))))
+(defun xref-doit (type symbol)
+ (ecase type
+ (:calls (who-calls symbol))
+ (:calls-who (calls-who symbol))
+ (:references (who-references symbol))
+ (:binds (who-binds symbol))
+ (:sets (who-sets symbol))
+ (:macroexpands (who-macroexpands symbol))
+ (:specializes (who-specializes symbol))
+ (:callers (list-callers symbol))
+ (:callees (list-callees symbol))))
+
(defslimefun xref (type name)
- (let ((symbol (parse-symbol-or-lose name *buffer-package*)))
- (mapcar #'xref>elisp
- (ecase type
- (:calls (who-calls symbol))
- (:calls-who (calls-who symbol))
- (:references (who-references symbol))
- (:binds (who-binds symbol))
- (:sets (who-sets symbol))
- (:macroexpands (who-macroexpands symbol))
- (:specializes (who-specializes symbol))
- (:callers (list-callers symbol))
- (:callees (list-callees symbol))))))
+ (with-buffer-syntax ()
+ (let* ((symbol (parse-symbol-or-lose name))
+ (xrefs (xref-doit type symbol)))
+ (if (eq xrefs :not-implemented)
+ :not-implemented
+ (mapcar #'xref>elisp xrefs)))))
+
+(defslimefun xrefs (types name)
+ (loop for type in types
+ for xrefs = (xref type name)
+ when (and (not (eq :not-implemented xrefs))
+ (not (null xrefs)))
+ collect (cons type xrefs)))
(defun xref>elisp (xref)
(destructuring-bind (name loc) xref
--- /project/slime/cvsroot/slime/swank-backend.lisp 2009/08/10 19:30:22 1.180
+++ /project/slime/cvsroot/slime/swank-backend.lisp 2009/09/20 09:39:16 1.181
@@ -639,7 +639,7 @@
to safe reader/printer settings, and so on.")
(definterface call-with-debugger-hook (hook fun)
- "Call FUN and use HOOK as debugger hook.
+ "Call FUN and use HOOK as debugger hook. HOOK can be NIL.
HOOK should be called for both BREAK and INVOKE-DEBUGGER."
(let ((*debugger-hook* hook))
@@ -829,31 +829,45 @@
(definterface who-calls (function-name)
"Return the call sites of FUNCTION-NAME (a symbol).
-The results is a list ((DSPEC LOCATION) ...).")
+The results is a list ((DSPEC LOCATION) ...)."
+ (declare (ignore function-name))
+ :not-implemented)
(definterface calls-who (function-name)
"Return the call sites of FUNCTION-NAME (a symbol).
-The results is a list ((DSPEC LOCATION) ...).")
+The results is a list ((DSPEC LOCATION) ...)."
+ (declare (ignore function-name))
+ :not-implemented)
(definterface who-references (variable-name)
"Return the locations where VARIABLE-NAME (a symbol) is referenced.
-See WHO-CALLS for a description of the return value.")
+See WHO-CALLS for a description of the return value."
+ (declare (ignore variable-name))
+ :not-implemented)
(definterface who-binds (variable-name)
"Return the locations where VARIABLE-NAME (a symbol) is bound.
-See WHO-CALLS for a description of the return value.")
+See WHO-CALLS for a description of the return value."
+ (declare (ignore variable-name))
+ :not-implemented)
(definterface who-sets (variable-name)
"Return the locations where VARIABLE-NAME (a symbol) is set.
-See WHO-CALLS for a description of the return value.")
+See WHO-CALLS for a description of the return value."
+ (declare (ignore variable-name))
+ :not-implemented)
(definterface who-macroexpands (macro-name)
"Return the locations where MACRO-NAME (a symbol) is expanded.
-See WHO-CALLS for a description of the return value.")
+See WHO-CALLS for a description of the return value."
+ (declare (ignore macro-name))
+ :not-implemented)
(definterface who-specializes (class-name)
"Return the locations where CLASS-NAME (a symbol) is specialized.
-See WHO-CALLS for a description of the return value.")
+See WHO-CALLS for a description of the return value."
+ (declare (ignore class-name))
+ :not-implemented)
;;; Simpler variants.
--- /project/slime/cvsroot/slime/slime.el 2009/09/18 21:29:59 1.1223
+++ /project/slime/cvsroot/slime/slime.el 2009/09/20 09:39:16 1.1224
@@ -538,8 +538,8 @@
(defvar slime-parent-bindings
'(("\M-." slime-edit-definition)
("\M-," slime-pop-find-definition-stack)
- ("\M-_" slime-edit-callers) ; for German layout
- ("\M-?" slime-edit-callers) ; for USian layout
+ ("\M-_" slime-edit-uses) ; for German layout
+ ("\M-?" slime-edit-uses) ; for USian layout
("\C-x4." slime-edit-definition-other-window)
("\C-x5." slime-edit-definition-other-frame)
("\C-x\C-e" slime-eval-last-expression)
@@ -2872,30 +2872,9 @@
(setf (getf new-note :severity) new-severity)
new-note)))
-;; XXX: unused function
-(defun slime-intersperse (element list)
- "Intersperse ELEMENT between each element of LIST."
- (if (null list)
- '()
- (cons (car list)
- (mapcan (lambda (x) (list element x)) (cdr list)))))
-
(defun slime-notes-in-same-location-p (a b)
(equal (slime-note.location a) (slime-note.location b)))
-(defun slime-group-similar (similar-p list)
- "Return the list of lists of 'similar' adjacent elements of LIST.
-The function SIMILAR-P is used to test for similarity.
-The order of the input list is preserved."
- (if (null list)
- nil
- (let ((accumulator (list (list (car list)))))
- (dolist (x (cdr list))
- (if (funcall similar-p x (caar accumulator))
- (push x (car accumulator))
- (push (list x) accumulator)))
- (reverse (mapcar #'reverse accumulator)))))
-
;;;;; Compiler notes list
@@ -3069,22 +3048,6 @@
(t (< col1 col2)))))))))
locs)))
-(defun slime-alistify (list key test)
- "Partition the elements of LIST into an alist.
-KEY extracts the key from an element and TEST is used to compare
-keys."
- (declare (type function key))
- (let ((alist '()))
- (dolist (e list)
- (let* ((k (funcall key e))
- (probe (assoc* k alist :test test)))
- (if probe
- (push e (cdr probe))
- (push (cons k (list e)) alist))))
- ;; Put them back in order.
- (loop for (key . value) in (reverse alist)
- collect (cons key (reverse value)))))
-
(defun slime-note.severity (note)
(plist-get note :severity))
@@ -4004,7 +3967,7 @@
"Lookup the definition of the name at point.
If there's no name at point, or a prefix argument is given, then the
function name is prompted."
- (interactive (list (slime-read-symbol-name "Name: ")))
+ (interactive (list (slime-read-symbol-name "Edit Definition of: ")))
(or (run-hook-with-args-until-success 'slime-edit-definition-hooks
name where)
(slime-edit-definition-cont (slime-find-definitions name)
@@ -4025,23 +3988,28 @@
(slime-show-xrefs file-alist 'definition name
(slime-current-package))))))
-(defun slime-edit-callers (symbol)
- "Quite similiar to `slime-who-calls' but only shows Xref buffer
-if needed for disambiguation. Also pushes onto the definition
-stack."
- (interactive (list (slime-read-symbol-name "Edit callers of: ")))
- (slime-xref :calls symbol
- #'(lambda (xrefs type symbol package snapshot)
- (cond ((null xrefs)
- (message "No xref information found for %s." symbol))
- ((and (slime-length= xrefs 1) ; one group
- (slime-length= (cdr xrefs) 1)) ; one ref in group
- (destructuring-bind (_ . (_ loc)) (first xrefs)
- (slime-push-definition-stack)
- (slime-pop-to-location loc)))
- (t
- (slime-push-definition-stack)
- (slime-pop-xref-buffer xrefs type symbol package snapshot))))))
+;;; FIXME. TODO: Would be nice to group the symbols (in each
+;;; type-group) by their home-package.
+(defun slime-edit-uses (symbol)
+ "Lookup all the uses of SYMBOL."
+ (interactive (list (slime-read-symbol-name "Edit Uses of: ")))
+ (slime-xrefs '(:calls :macroexpands
+ :binds :references :sets
+ :specializes)
+ symbol
+ #'(lambda (xrefs type symbol package snapshot)
+ (cond
+ ((null xrefs)
+ (message "No xref information found for %s." symbol))
+ ((and (slime-length= xrefs 1) ; one group
+ (slime-length= (cdar xrefs) 1)) ; one ref in group
+ (destructuring-bind (_ (_ loc)) (first xrefs)
+ (slime-push-definition-stack)
+ (slime-pop-to-location loc)))
+ (t
+ (slime-push-definition-stack)
+ (slime-show-xref-buffer xrefs type symbol
+ package snapshot))))))
(defun slime-analyze-xrefs (xrefs)
"Find common filenames in XREFS.
@@ -4903,7 +4871,7 @@
;; Remove the final newline to prevent accidental window-scrolling
(backward-delete-char 1))
-(defun slime-pop-xref-buffer (xrefs type symbol package emacs-snapshot)
+(defun slime-show-xref-buffer (xrefs type symbol package emacs-snapshot)
(slime-with-xref-buffer (type symbol package emacs-snapshot)
(slime-insert-xrefs xrefs)
(goto-char (point-min))
@@ -4923,7 +4891,7 @@
"Show the results of an XREF query."
(if (null xrefs)
(message "No references found for %s." symbol)
- (slime-pop-xref-buffer xrefs type symbol package emacs-snapshot)))
+ (slime-show-xref-buffer xrefs type symbol package emacs-snapshot)))
;;;;; XREF commands
@@ -4977,15 +4945,41 @@
"Make an XREF request to Lisp."
(slime-eval-async
`(swank:xref ',type ',symbol)
- (slime-rcurry (lexical-let ((cont continuation))
- (lambda (result type symbol package snapshot)
- (let ((file-alist (cadr (slime-analyze-xrefs result))))
- (funcall (or cont 'slime-show-xrefs)
- file-alist type symbol package snapshot))))
+ (slime-rcurry (lambda (result type symbol package snapshot cont)
+ (slime-check-xref-implemented type result)
+ (let ((file-alist (cadr (slime-analyze-xrefs result))))
+ (funcall (or cont 'slime-show-xrefs)
+ file-alist type symbol package snapshot)))
type
symbol
(slime-current-package)
- (slime-current-emacs-snapshot))))
+ (slime-current-emacs-snapshot)
+ continuation)))
+
+(defun slime-check-xref-implemented (type xrefs)
+ (when (eq xrefs :not-implemented)
+ (error "%s is not implemented yet on %s."
+ (slime-xref-type type)
+ (slime-lisp-implementation-name))))
+
+(defun slime-xref-type (type)
+ (format "who-%s" (slime-cl-symbol-name type)))
+
+(defun slime-xrefs (types symbol &optional continuation)
+ "Make multiple XREF requests at once."
+ (slime-eval-async
+ `(swank:xrefs ',types ',symbol)
+ (slime-rcurry (lambda (result types symbol package snapshot cont)
+ (funcall (or cont 'slime-show-xrefs)
+ (slime-map-alist #'slime-xref-type
+ #'identity
+ result)
+ types symbol package snapshot))
+ types
+ symbol
+ (slime-current-package)
+ (slime-current-emacs-snapshot)
+ continuation)))
;;;;; XREF navigation
@@ -8269,6 +8263,55 @@
;;;; Utilities
+;;;; List frobbing
+
+(defun slime-map-alist (car-fn cdr-fn alist)
+ "Map over ALIST, calling CAR-FN on the car, and CDR-FN on the
+cdr of each entry."
+ (mapcar #'(lambda (entry)
+ (cons (funcall car-fn (car entry))
+ (funcall cdr-fn (cdr entry))))
+ alist))
+
+;; XXX: unused function
+(defun slime-intersperse (element list)
+ "Intersperse ELEMENT between each element of LIST."
+ (if (null list)
+ '()
+ (cons (car list)
+ (mapcan (lambda (x) (list element x)) (cdr list)))))
+
+;;; FIXME: this looks almost slime `slime-alistify', perhaps the two
+;;; functions can be merged.
+(defun slime-group-similar (similar-p list)
+ "Return the list of lists of 'similar' adjacent elements of LIST.
+The function SIMILAR-P is used to test for similarity.
+The order of the input list is preserved."
+ (if (null list)
+ nil
+ (let ((accumulator (list (list (car list)))))
+ (dolist (x (cdr list))
+ (if (funcall similar-p x (caar accumulator))
+ (push x (car accumulator))
+ (push (list x) accumulator)))
+ (reverse (mapcar #'reverse accumulator)))))
+
+(defun slime-alistify (list key test)
+ "Partition the elements of LIST into an alist.
+KEY extracts the key from an element and TEST is used to compare
+keys."
+ (declare (type function key))
+ (let ((alist '()))
+ (dolist (e list)
+ (let* ((k (funcall key e))
+ (probe (assoc* k alist :test test)))
+ (if probe
+ (push e (cdr probe))
+ (push (cons k (list e)) alist))))
+ ;; Put them back in order.
+ (loop for (key . value) in (reverse alist)
+ collect (cons key (reverse value)))))
+
;;;;; Misc.
(defun slime-length= (seq n)
--- /project/slime/cvsroot/slime/ChangeLog 2009/09/20 09:04:53 1.1859
+++ /project/slime/cvsroot/slime/ChangeLog 2009/09/20 09:39:16 1.1860
@@ -1,3 +1,30 @@
+2009-09-20 Tobias C. Rittweiler <tcr at freebits.de>
+
+ Generalize M-? (or M-_ respectively.)
+
+ It will now list:
+
+ - call sites for functions,
+
+ - macroexpand sites for macros,
+
+ - binding, setting, referencing sites for variables,
+
+ - specializing methods for classes.
+
+ * slime.el (slime-xref): Deal with :not-implemented.
+ (slime-xrefs): New. Makes RPC request to XREFS.
+ (slime-edit-callers): Renamed to `slime-edit-uses'.
+ (slime-edit-uses): Use slime-xrefs.
+
+ * swank-backend.lisp (who-*): Add default implementation which
+ returns :not-implemented.
+
+ * swank.lisp (xref-doit): Extracted from XREF.
+ (xref): Pass over :not-implemented to Emacs side.
+ (xrefs): New slime fun. To return results of multiple XREF
+ requests at once.
+
2009-09-20 Mark Evenson <evenson at panix.com>
Use *INVOKE-DEBUGGER-HOOK* introduced in ABCL by analogy to SBCL
More information about the slime-cvs
mailing list