[slime-cvs] CVS slime

[CVS User heller]

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

Modified Files:
	ChangeLog swank-openmcl.lisp 
Log Message:
For buffers without filename, map the name of the tempfile back to
the buffer name.

* swank-openmcl.lisp (*temp-file-map*): New variable.
(note-temp-file): New function.
(compile-temp-file, source-note-to-source-location): Use it.

--- /project/slime/cvsroot/slime/ChangeLog	2009/01/01 14:48:04	1.1616
+++ /project/slime/cvsroot/slime/ChangeLog	2009/01/01 14:48:13	1.1617
@@ -1,5 +1,14 @@
 2009-01-01  Helmut Eller  <heller at common-lisp.net>
 
+	For buffers without filename, map the name of the tempfile back to
+	the buffer name.
+
+	* swank-openmcl.lisp (*temp-file-map*): New variable.
+	(note-temp-file): New function.
+	(compile-temp-file, source-note-to-source-location): Use it.
+
+2009-01-01  Helmut Eller  <heller at common-lisp.net>
+
 	* swank.lisp (sleep-for): New function
 	* slime.el ([test] break): Use SWANK::SLEEP-FOR to help CCL pass
 	this test.
--- /project/slime/cvsroot/slime/swank-openmcl.lisp	2008/12/31 11:25:30	1.150
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp	2009/01/01 14:48:13	1.151
@@ -379,19 +379,28 @@
            (with-open-file (s filename :direction :output :if-exists :error)
              (write-string string s))
         (let ((binary-filename (compile-temp-file
-                                filename
-                                (if directory
-                                    (format nil "~a/~a" directory buffer))
-                                (1- position))))
+                                filename directory buffer position)))
           (delete-file binary-filename)))
       (delete-file filename))))
 
-(defun compile-temp-file (filename orig-file orig-offset)
+(defvar *temp-file-map* (make-hash-table :test #'equal)
+  "A mapping from tempfile names to Emacs buffer names.")
+
+(defun note-temp-file (filename directory buffer)
+  (cond (directory
+         (format nil "~a/~a" directory buffer))
+        (t
+         (setf (gethash filename *temp-file-map*) buffer)
+         filename)))
+
+(defun compile-temp-file (filename dir buffer offset)
   (if (fboundp 'ccl::function-source-note)
       (compile-file filename
                     :load t
-                    :compile-file-original-truename orig-file
-                    :compile-file-original-buffer-offset orig-offset)
+                    :compile-file-original-truename (note-temp-file filename 
+                                                                    dir
+                                                                    buffer)
+                    :compile-file-original-buffer-offset (1- offset))
       (compile-file filename :load t)))
 
 ;;; Profiling (alanr: lifted from swank-clisp)
@@ -721,15 +730,19 @@
        (format nil "No source note at PC: ~A:#x~x" function pc))))
 
   (defun source-note-to-source-location (note if-nil-thunk)
-    (cond (note
-           (handler-case
-               (let* ((file (ccl:source-note-filename note))
-                      (file (namestring (truename file))))
-                 (make-location
-                  (list :file file)
-                  (list :position (1+ (ccl:source-note-start-pos note)))))
-             (error (c) `(:error ,(princ-to-string c)))))
-          (t `(:error ,(funcall if-nil-thunk)))))
+    (labels ((filename-to-buffer (filename)
+               (cond ((probe-file filename)
+                      (list :file (namestring (truename filename))))
+                     ((gethash filename *temp-file-map*)
+                      (list :buffer (gethash filename *temp-file-map*)))
+                     (t (error "File ~s doesn't exist" filename)))))
+      (cond (note
+             (handler-case
+                 (make-location 
+                  (filename-to-buffer (ccl:source-note-filename note))
+                  (list :position (1+ (ccl:source-note-start-pos note))))
+               (error (c) `(:error ,(princ-to-string c)))))
+          (t `(:error ,(funcall if-nil-thunk))))))
 
   (defimplementation find-definitions (symbol)
     (loop for (loc . name) in (source-locations symbol)