[slime-cvs] CVS slime
heller
heller at common-lisp.net
Wed Feb 20 22:12:37 UTC 2008
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv11860
Modified Files:
ChangeLog slime.el swank.lisp
Log Message:
Better factorization for M-. and xref commands.
* slime.el (slime-xref): Renamed from slime-definition.
(slime-location, slime-location-p): New ADT def.
(slime-xref-has-location-p, slime-analyze-xrefs): New functions.
This work used to be done on the Lisp side.
(slime-pop-to-location): New function.
(slime-edit-definition, slime-edit-definition-cont): Simplified.
(slime-find-definitions): New function.
(slime-goto-definition, slime-goto-definition-other-window)
(slime-pop-to-other-window, slime-show-definitions): Deleted.
(slime-insert-xrefs): Simplified.
(slime-insert-xref-location): Deleted. No need to show the filename
twice.
* swank.lisp (find-definitions-for-emacs, xref): Use common
representation for "definitions" and "xrefs".
(xref>elisp): New helper.
(group-xrefs, alistify, parition, location-position<, xref-position)
(xref-buffer, location-valid-p): Deleted. This work is now done on
the Emacs side.
--- /project/slime/cvsroot/slime/ChangeLog 2008/02/20 22:10:38 1.1292
+++ /project/slime/cvsroot/slime/ChangeLog 2008/02/20 22:12:37 1.1293
@@ -1,5 +1,29 @@
2008-02-20 Helmut Eller <heller at common-lisp.net>
+ Better factorization for M-. and xref commands.
+
+ * slime.el (slime-xref): Renamed from slime-definition.
+ (slime-location, slime-location-p): New ADT def.
+ (slime-xref-has-location-p, slime-analyze-xrefs): New functions.
+ This work used to be done on the Lisp side.
+ (slime-pop-to-location): New function.
+ (slime-edit-definition, slime-edit-definition-cont): Simplified.
+ (slime-find-definitions): New function.
+ (slime-goto-definition, slime-goto-definition-other-window)
+ (slime-pop-to-other-window, slime-show-definitions): Deleted.
+ (slime-insert-xrefs): Simplified.
+ (slime-insert-xref-location): Deleted. No need to show the filename
+ twice.
+
+ * swank.lisp (find-definitions-for-emacs, xref): Use common
+ representation for "definitions" and "xrefs".
+ (xref>elisp): New helper.
+ (group-xrefs, alistify, parition, location-position<, xref-position)
+ (xref-buffer, location-valid-p): Deleted. This work is now done on
+ the Emacs side.
+
+2008-02-20 Helmut Eller <heller at common-lisp.net>
+
Emit a warning if the SWANK package already exists.
* swank-loader.lisp (init): Issue a warning when SWANK will not be
--- /project/slime/cvsroot/slime/slime.el 2008/02/16 19:26:22 1.905
+++ /project/slime/cvsroot/slime/slime.el 2008/02/20 22:12:37 1.906
@@ -4107,8 +4107,9 @@
(goto-char (point-min)))))
(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."
+ "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)
@@ -4118,7 +4119,7 @@
(push e (cdr probe))
(push (cons k (list e)) alist))))
;; Put them back in order.
- (loop for (key . value) in alist
+ (loop for (key . value) in (reverse alist)
collect (cons key (reverse value)))))
(defun slime-note.severity (note)
@@ -5141,28 +5142,79 @@
;; If this buffer was deleted, recurse to try the next one
(slime-pop-find-definition-stack))))))
-(defstruct (slime-definition (:conc-name slime-definition.)
- (:type list))
+(defstruct (slime-xref (:conc-name slime-xref.) (:type list))
dspec location)
+(defstruct (slime-location (:conc-name slime-location.) (:type list)
+ (:constructor nil) (:copier nil))
+ tag buffer position hints)
+(defun slime-location-p (o) (and (consp o) (eq (car o) :location)))
+
+(defun slime-xref-has-location-p (xref)
+ (slime-location-p (slime-xref.location xref)))
+
(defun slime-edit-definition (name &optional where)
"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: ")))
- (let ((definitions (slime-eval `(swank:find-definitions-for-emacs ,name))))
- (cond
- ((null definitions)
- (if slime-edit-definition-fallback-function
- (funcall slime-edit-definition-fallback-function name)
- (error "No known definition for: %s" name)))
- ((and (slime-length= definitions 1)
- (eql (car (slime-definition.location (car definitions))) :error))
- (if slime-edit-definition-fallback-function
- (funcall slime-edit-definition-fallback-function name)
- (error "%s" (cadr (slime-definition.location (car definitions))))))
- (t
- (slime-goto-definition name definitions where)))))
+ (slime-find-definitions name
+ (slime-rcurry
+ #'slime-edit-definition-cont name where)))
+
+(defun slime-edit-definition-cont (xrefs name where)
+ (destructuring-bind (1loc file-alist) (slime-analyze-xrefs xrefs)
+ (cond ((null xrefs)
+ (error "No known definition for: %s" name))
+ (1loc
+ (slime-push-definition-stack)
+ (slime-pop-to-location (slime-xref.location (car xrefs)) where))
+ ((= (length xrefs) 1)
+ (error "%s" (cadr (slime-xref.location (car xrefs)))))
+ (t
+ (slime-push-definition-stack)
+ (slime-show-xrefs file-alist 'definition name
+ (slime-current-package))))))
+
+(defun slime-analyze-xrefs (xrefs)
+ "Find common filenames in XREFS.
+Return a list (SINGLE-LOCATION FILE-ALIST).
+SINGLE-LOCATION is true if all xrefs point to the same location.
+FILE-ALIST is an alist of the form ((FILENAME . (XREF ...)) ...)."
+ (list (and xrefs
+ (let ((loc (slime-xref.location (car xrefs))))
+ (and (slime-location-p loc)
+ (every (lambda (x) (equal (slime-xref.location x) loc))
+ (cdr xrefs)))))
+ (slime-alistify xrefs
+ (lambda (x)
+ (if (slime-xref-has-location-p x)
+ (cadr
+ (slime-location.buffer (slime-xref.location x)))
+ "Error"))
+ #'equal)))
+
+(defun slime-pop-to-location (location &optional where)
+ (ecase where
+ ((nil)
+ (slime-goto-source-location location)
+ (switch-to-buffer (current-buffer)))
+ (window
+ (pop-to-buffer (current-buffer) t)
+ (slime-goto-source-location location)
+ (switch-to-buffer (current-buffer)))
+ (frame
+ (let ((pop-up-frames t))
+ (pop-to-buffer (current-buffer) t)
+ (slime-goto-source-location location)
+ (switch-to-buffer (current-buffer))))))
+
+(defun slime-find-definitions (name cont)
+ "Find definitions for NAME and pass them to CONT."
+ ;; FIXME: append SWANK xrefs and etags xrefs
+ (funcall cont
+ (or (slime-eval `(swank:find-definitions-for-emacs ,name))
+ (funcall slime-edit-definition-fallback-function name))))
(defun slime-find-tag-if-tags-table-visited (name)
"Find tag (in current tags table) whose name contains NAME.
@@ -5171,44 +5223,7 @@
(if tags-table-list
(find-tag name)
(error "No known definition for: %s; use M-x visit-tags-table RET" name)))
-
-(defun slime-goto-definition (name definitions &optional where)
- (slime-push-definition-stack)
- (let ((all-locations-equal
- (or (null definitions)
- (let ((first-location (slime-definition.location (first definitions))))
- (every (lambda (definition)
- (equal (slime-definition.location definition)
- first-location))
- (rest definitions))))))
- (if (and (slime-length> definitions 1)
- (not all-locations-equal))
- (slime-show-definitions name definitions)
- (let ((def (car definitions)))
- (destructure-case (slime-definition.location def)
- ;; Take care of errors before switching any windows/buffers.
- ((:error message)
- (error "%s" message))
- (t
- (cond ((equal where 'window)
- (slime-goto-definition-other-window (car definitions)))
- ((equal where 'frame)
- (let ((pop-up-frames t))
- (slime-goto-definition-other-window (car definitions))))
- (t
- (slime-goto-source-location (slime-definition.location
- (car definitions)))
- (switch-to-buffer (current-buffer))))))))))
-
-(defun slime-goto-definition-other-window (definition)
- (slime-pop-to-other-window)
- (slime-goto-source-location (slime-definition.location definition))
- (switch-to-buffer (current-buffer)))
-
-(defun slime-pop-to-other-window ()
- "Pop to the other window, but not to any particular buffer."
- (pop-to-buffer (current-buffer) t))
-
+
(defun slime-edit-definition-other-window (name)
"Like `slime-edit-definition' but switch to the other window."
(interactive (list (slime-read-symbol-name "Symbol: ")))
@@ -5221,10 +5236,10 @@
(defun slime-edit-definition-with-etags (name)
(interactive (list (slime-read-symbol-name "Symbol: ")))
- (let ((tagdefs (slime-etags-definitions name)))
- (cond (tagdefs
+ (let ((xrefs (slime-etags-definitions name)))
+ (cond (xrefs
(message "Using tag file...")
- (slime-goto-definition name tagdefs))
+ (slime-edit-definition-cont xrefs name nil))
(t
(error "No known definition for: %s" name)))))
@@ -5249,14 +5264,6 @@
(push (list hint loc) defs))))))))
(reverse defs))))
-(defun slime-show-definitions (name definitions)
- (slime-show-xrefs
- `((,name . ,(loop for (dspec location) in definitions
- collect (cons dspec location))))
- 'definition
- name
- (slime-current-package)))
-
;;;;; first-change-hook
(defun slime-first-change-hook ()
@@ -6060,36 +6067,19 @@
(put 'slime-with-xref-buffer 'lisp-indent-function 1)
-(defun slime-insert-xrefs (xrefs)
- "Insert XREFS in the current-buffer.
-XREFS is a list of the form ((GROUP . ((LABEL . LOCATION) ...)) ...)
-GROUP and LABEL are for decoration purposes. LOCATION is a source-location."
- (unless (bobp) (insert "\n"))
+(defun slime-insert-xrefs (xref-alist)
+ "Insert XREF-ALIST in the current-buffer.
+XREF-ALIST is of the form ((GROUP . ((LABEL LOCATION) ...)) ...).
+GROUP and LABEL are for decoration purposes. LOCATION is a
+source-location."
(loop for (group . refs) in xrefs do
- (progn
- (slime-insert-propertized '(face bold) group "\n")
- (loop
- for (label . location) in refs
- do (slime-insert-propertized
- (list 'slime-location location
- 'face 'font-lock-keyword-face)
- " " (slime-one-line-ify label))
- do (insert " - " (slime-insert-xref-location location) "\n"))))
+ (slime-insert-propertized '(face bold) group "\n")
+ (loop for (label location) in refs do
+ (slime-insert-propertized (list 'slime-location location
+ 'face 'font-lock-keyword-face)
+ " " (slime-one-line-ify label) "\n")))
;; Remove the final newline to prevent accidental window-scrolling
- (backward-char 1)
- (delete-char 1))
-
-(defun slime-insert-xref-location (location)
- (if (eql :location (car location))
- (cond ((assoc :file (cdr location))
- (second (assoc :file (cdr location))))
- ((assoc :buffer (cdr location))
- (let* ((name (second (assoc :buffer (cdr location))))
- (buffer (get-buffer name)))
- (if buffer
- (format "%S" buffer)
- (format "%s (previously existing buffer)" name)))))
- "file unknown"))
+ (backward-delete-char 1))
(defvar slime-next-location-function nil
"Function to call for going to the next location.")
@@ -6165,7 +6155,8 @@
;; buffer. (2007-08-14)
(snapshot (slime-current-emacs-snapshot)))
(lambda (result)
- (slime-show-xrefs result type symbol package snapshot)))))
+ (let ((file-alist (cadr (slime-analyze-xrefs result))))
+ (slime-show-xrefs file-alist type symbol package snapshot))))))
;;;;; XREF navigation
--- /project/slime/cvsroot/slime/swank.lisp 2008/02/20 22:07:35 1.533
+++ /project/slime/cvsroot/slime/swank.lisp 2008/02/20 22:12:37 1.534
@@ -2587,85 +2587,27 @@
(defslimefun find-definitions-for-emacs (name)
"Return a list ((DSPEC LOCATION) ...) of definitions for NAME.
DSPEC is a string and LOCATION a source location. NAME is a string."
- (multiple-value-bind (sexp error)
- (ignore-errors (values (from-string name)))
+ (multiple-value-bind (sexp error) (ignore-errors (values (from-string name)))
(unless error
- (loop for (dspec loc) in (find-definitions sexp)
- collect (list (to-string dspec) loc)))))
+ (mapcar #'xref>elisp (find-definitions sexp)))))
-(defun 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))))
- alist))
-
-(defun location-position< (pos1 pos2)
- (cond ((and (position-p pos1) (position-p pos2))
- (< (position-pos pos1)
- (position-pos pos2)))
- (t nil)))
-
-(defun partition (list test key)
- (declare (type function test key))
- (loop for e in list
- if (funcall test (funcall key e)) collect e into yes
- else collect e into no
- finally (return (values yes no))))
-
-(defstruct (xref (:conc-name xref.)
- (:type list))
- dspec location)
-
-(defun location-valid-p (location)
- (eq (car location) :location))
-
-(defun xref-buffer (xref)
- (location-buffer (xref.location xref)))
-
-(defun xref-position (xref)
- (location-buffer (xref.location xref)))
-
-(defun group-xrefs (xrefs)
- "Group XREFS, a list of the form ((DSPEC LOCATION) ...) by location.
-The result is a list of the form ((LOCATION . ((DSPEC . LOCATION) ...)) ...)."
- (multiple-value-bind (resolved errors)
- (partition xrefs #'location-valid-p #'xref.location)
- (let ((alist (alistify resolved #'xref-buffer #'equal)))
- (append
- (loop for (buffer . list) in alist
- collect (cons (second buffer)
- (mapcar (lambda (xref)
- (cons (to-string (xref.dspec xref))
- (xref.location xref)))
- (sort list #'location-position<
- :key #'xref-position))))
- (if errors
- (list (cons "Unresolved"
- (mapcar (lambda (xref)
- (cons (to-string (xref.dspec xref))
- (xref.location xref)))
- errors))))))))
-
-(defslimefun xref (type symbol-name)
- (let ((symbol (parse-symbol-or-lose symbol-name *buffer-package*)))
- (group-xrefs
- (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))))))
+
+(defun xref>elisp (xref)
+ (destructuring-bind (name loc) xref
+ (list (to-string name) loc)))
;;;; Inspecting
More information about the slime-cvs
mailing list