[slime-cvs] CVS slime

[CVS User trittweiler]

Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv3860

Modified Files:
	slime.el swank-backend.lisp 
Log Message:
	Make it possible for SWANK backends to specify locations based on
	a TAGS file.

	* slime.el (slime-postprocess-xref, slime-postprocess-xrefs): New
	functions. They convert TAGS based locations from SWANK into
	file+position based locations because the rest of Slime expects
	and works with those.
	(slime-find-definitions): Call slime-postprocess-xrefs.
	(slime-xref): Ditto.
	(slime-etags-to-locations): The function which does the actual
	conversion. Extracted from `slime-etags-definitions'.
	(slime-etags-definitions): Use it.

	* swank-backend (defimplementation): Add implicit BLOCK.
	(:etags-file, :tag): Mentioned for possible values in :LOCATION.


--- /project/slime/cvsroot/slime/slime.el	2010/02/20 14:37:32	1.1278
+++ /project/slime/cvsroot/slime/slime.el	2010/02/22 12:40:30	1.1279
@@ -3857,9 +3857,33 @@
     (window    (pop-to-buffer (current-buffer) t))
     (frame     (let ((pop-up-frames t)) (pop-to-buffer (current-buffer) t)))))
 
+(defun slime-postprocess-xref (original-xref)
+  "Process (for normalization purposes) an Xref comming directly
+from SWANK before the rest of Slime sees it. In particular,
+convert ETAGS based xrefs to actual file+position based
+locations."
+  (if (not (slime-xref-has-location-p original-xref))
+      (list original-xref)
+      (let ((loc (slime-xref.location original-xref)))
+        (destructure-case (slime-location.buffer loc)
+          ((:etags-file tags-file)
+           (destructure-case (slime-location.position loc)
+             ((:tag &rest tags)
+              (visit-tags-table tags-file)
+              (mapcar #'(lambda (loc)
+                          (make-slime-xref 
+                           :dspec (slime-xref.dspec original-xref)
+                           :location loc))
+                      (mapcan #'slime-etags-to-locations tags)))))
+          (t 
+           (list original-xref))))))
+
+(defun slime-postprocess-xrefs (xrefs)
+  (mapcan #'slime-postprocess-xref xrefs))
+
 (defun slime-find-definitions (name)
   "Find definitions for NAME."
-  (funcall slime-find-definitions-function name))
+  (slime-postprocess-xrefs (funcall slime-find-definitions-function name)))
 
 (defun slime-find-definitions-rpc (name)
   (slime-eval `(swank:find-definitions-for-emacs ,name)))
@@ -3883,11 +3907,10 @@
           (t
            (error "No known definition for: %s" name)))))
 
-(defun slime-etags-definitions (name)
-  "Search definitions matching NAME in the tags file.
-The result is a (possibly empty) list of definitions."
-  (require 'etags)
-  (let ((defs '()))
+(defun slime-etags-to-locations (name)
+  "Search for definitions matching `name' in the currently active
+tags table. Return a possibly empty list of slime-locations."
+  (let ((locs '()))
     (save-excursion
       (let ((first-time t))
         (while (visit-tags-table-buffer (not first-time))
@@ -3896,13 +3919,20 @@
           (while (search-forward name nil t)
             (beginning-of-line)
             (destructuring-bind (hint line &rest pos) (etags-snarf-tag)
-              (unless (eq hint t)       ; hint==t if we are in a filename line
-                (let ((file (expand-file-name (file-of-tag))))
-                  (let ((loc `(:location (:file ,file)
-                                         (:line ,line)
-                                         (:snippet ,hint))))
-                    (push (list hint loc) defs))))))))
-      (reverse defs))))
+              (unless (eq hint t) ; hint==t if we are in a filename line
+                (push `(:location (:file ,(expand-file-name (file-of-tag)))
+                                  (:line ,line)
+                                  (:snippet ,hint)) 
+                       locs))))))
+      (nreverse locs))))
+
+(defun slime-etags-definitions (name)
+  "Search definitions matching NAME in the tags file.
+The result is a (possibly empty) list of definitions."
+  (mapcar #'(lambda (loc)
+              (make-slime-xref :dspec (second (slime-location.hints loc))
+                               :location loc))
+          (slime-etags-to-locations name)))
 
 ;;;;; first-change-hook
 
@@ -4772,7 +4802,8 @@
    `(swank:xref ',type ',symbol)
    (slime-rcurry (lambda (result type symbol package cont)
                    (slime-check-xref-implemented type result)
-                   (let ((file-alist (cadr (slime-analyze-xrefs result))))
+                   (let* ((xrefs (slime-postprocess-xrefs result))
+                          (file-alist (cadr (slime-analyze-xrefs result))))
                      (funcall (or cont 'slime-show-xrefs)
                               file-alist type symbol package)))
                  type 
--- /project/slime/cvsroot/slime/swank-backend.lisp	2010/02/17 17:04:46	1.192
+++ /project/slime/cvsroot/slime/swank-backend.lisp	2010/02/22 12:40:30	1.193
@@ -168,7 +168,9 @@
   (assert (every #'symbolp args) ()
           "Complex lambda-list not supported: ~S ~S" name args)
   `(progn
-     (setf (get ',name 'implementation) (lambda ,args , at body))
+     (setf (get ',name 'implementation)
+           ;; For implicit BLOCK. FLET because of interplay w/ decls.
+           (flet ((,name ,args , at body)) #',name))
      (if (member ',name *interface-functions*)
          (setq *unimplemented-interfaces*
                (remove ',name *unimplemented-interfaces*))
@@ -816,9 +818,15 @@
   hints)
 
 (defstruct (:error (:type list) :named (:constructor)) message)
-(defstruct (:file (:type list) :named (:constructor)) name)
-(defstruct (:buffer (:type list) :named (:constructor)) name)
+
+;;; Valid content for BUFFER slot
+(defstruct (:file       (:type list) :named (:constructor)) name)
+(defstruct (:buffer     (:type list) :named (:constructor)) name)
+(defstruct (:etags-file (:type list) :named (:constructor)) filename)
+
+;;; Valid content for POSITION slot
 (defstruct (:position (:type list) :named (:constructor)) pos)
+(defstruct (:tag      (:type list) :named (:constructor)) tag1 tag2)
 
 (defun make-error-location (datum &rest args)
   (cond ((typep datum 'condition)