[slime-cvs] CVS slime

[CVS User heller]

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

Modified Files:
	ChangeLog slime.el swank-lispworks.lisp 
Log Message:
Improve frame-source-location for Lispworks.

* swank-lispworks.lisp (frame-source-location): Exctract the
edit-path from the frame and pass it to Emacs.
(edit-path-to-cmucl-source-path): New function.
(frame-location): Use it.

* slime.el (slime-location-offset): Add a :edit-path property.
(slime-search-edit-path): New function.
(slime-search-call-site): Fix regexp to match
zero arg functions.

--- /project/slime/cvsroot/slime/ChangeLog	2010/11/07 19:48:21	1.2163
+++ /project/slime/cvsroot/slime/ChangeLog	2010/11/12 19:42:51	1.2164
@@ -1,3 +1,17 @@
+2010-11-12  Helmut Eller  <heller at common-lisp.net>
+
+	Improve frame-source-location for Lispworks.
+
+	* swank-lispworks.lisp (frame-source-location): Exctract the
+	edit-path from the frame and pass it to Emacs.
+	(edit-path-to-cmucl-source-path): New function.
+	(frame-location): Use it.
+
+	* slime.el (slime-location-offset): Add a :edit-path property.
+	(slime-search-edit-path): New function.
+	(slime-search-call-site): Fix regexp to match
+	zero arg functions.
+
 2010-11-07  Helmut Eller  <heller at common-lisp.net>
 
 	* swank-backend.lisp (label-value-line): Remove display-nil-value.
--- /project/slime/cvsroot/slime/slime.el	2010/10/23 12:18:28	1.1349
+++ /project/slime/cvsroot/slime/slime.el	2010/11/12 19:42:51	1.1350
@@ -3338,12 +3338,21 @@
   (save-restriction 
     (narrow-to-defun)
     (let ((start (point))
-          (regexp (concat "(" fname "[\n \t]")))
+          (regexp (concat "(" fname "[)\n \t]"))
+          (case-fold-search t))
       (cond ((and (re-search-forward regexp nil t)
                   (not (re-search-forward regexp nil t)))
              (goto-char (match-beginning 0)))
             (t (goto-char start))))))
 
+(defun slime-search-edit-path (edit-path)
+  "Move to EDIT-PATH starting at the current toplevel form."
+  (when edit-path
+    (unless (and (= (current-column) 0)
+                 (looking-at "("))
+      (beginning-of-defun))
+    (slime-forward-source-path edit-path)))
+
 (defun slime-goto-source-location (location &optional noerror)
   "Move to the source location LOCATION.  Several kinds of locations
 are supported:
@@ -3383,6 +3392,8 @@
     (let ((hints (slime-location.hints location)))
       (when-let (snippet (getf hints :snippet))
         (slime-isearch snippet))
+      (when-let (snippet (getf hints :edit-path))
+        (slime-search-edit-path snippet))
       (when-let (fname (getf hints :call-site))
         (slime-search-call-site fname))
       (when (getf hints :align)
--- /project/slime/cvsroot/slime/swank-lispworks.lisp	2010/11/02 12:32:10	1.138
+++ /project/slime/cvsroot/slime/swank-lispworks.lisp	2010/11/12 19:42:51	1.139
@@ -336,7 +336,7 @@
 
 (defun nth-frame (index)
   (nth-next-frame *sldb-top-frame* index))
-           
+
 (defun find-top-frame ()
   "Return the most suitable top-frame for the debugger."
   (or (do ((frame (dbg::debugger-stack-current-frame dbg::*debugger-stack*)
@@ -406,9 +406,11 @@
     (if (dbg::call-frame-p frame)
 	(let ((dspec (dbg::call-frame-function-name frame))
               (cname (and (dbg::call-frame-p callee)
-                          (dbg::call-frame-function-name callee))))
+                          (dbg::call-frame-function-name callee)))
+              (path (and (dbg::call-frame-p frame)
+                         (dbg::call-frame-edit-path frame))))
 	  (if dspec
-              (frame-location dspec cname))))))
+              (frame-location dspec cname path))))))
 
 (defimplementation eval-in-frame (form frame-number)
   (let ((frame (nth-frame frame-number)))
@@ -432,19 +434,34 @@
 
 ;;; Definition finding
 
-(defun frame-location (dspec callee-name)
+(defun frame-location (dspec callee-name edit-path)
   (let ((infos (dspec:find-dspec-locations dspec)))
     (cond (infos 
            (destructuring-bind ((rdspec location) &rest _) infos
              (declare (ignore _))
              (let ((name (and callee-name (symbolp callee-name)
-                              (string callee-name))))
-               (make-dspec-location rdspec location 
-                                    `(:call-site ,name)))))
+                              (string callee-name)))
+                   (path (edit-path-to-cmucl-source-path edit-path)))
+               (make-dspec-location rdspec location
+                                    `(:call-site ,name :edit-path ,path)))))
           (t 
            (list :error (format nil "Source location not available for: ~S" 
                                 dspec))))))
 
+;; dbg::call-frame-edit-path is not documented but lets assume the
+;; binary representation of the integer EDIT-PATH should be
+;; interpreted as a sequence of CAR or CDR.  #b1111010 is roughly the
+;; same as cadadddr.  Something is odd with the highest bit.
+(defun edit-path-to-cmucl-source-path (edit-path)
+  (and edit-path
+       (cons 0
+             (let ((n -1))
+               (loop for i from (1- (integer-length edit-path)) downto 0
+                     if (logbitp i edit-path) do (incf n)
+                     else collect (prog1 n (setq n 0)))))))
+
+;; (edit-path-to-cmucl-source-path #b1111010) => (0 3 1)
+
 (defimplementation find-definitions (name)
   (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))
     (loop for (dspec location) in locations