[slime-cvs] CVS slime

[CVS User heller]

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

Modified Files:
	ChangeLog swank-ccl.lisp 
Log Message:
CCL's lap-functions don't have source-notes but the name often
has.  E.g. ccl::%fixnum-truncate.  Use names as last resort.

* swank-ccl.lisp (function-name-source-note): New function.
(pc-source-location): Use it.

--- /project/slime/cvsroot/slime/ChangeLog	2009/11/02 00:24:52	1.1904
+++ /project/slime/cvsroot/slime/ChangeLog	2009/11/02 07:47:02	1.1905
@@ -1,3 +1,11 @@
+2009-11-02  Helmut Eller  <heller at common-lisp.net>
+
+	CCL's lap-functions don't have source-notes but the name often
+	has.  E.g. ccl::%fixnum-truncate.  Use names as last resort.
+
+	* swank-ccl.lisp (function-name-source-note): New function.
+	(pc-source-location): Use it.
+
 2009-11-02  Stas Boukarev  <stassats at gmail.com>
 
 	* swank.lisp (tokenize-symbol-thoroughly): Return NIL
--- /project/slime/cvsroot/slime/swank-ccl.lisp	2009/10/31 08:22:56	1.10
+++ /project/slime/cvsroot/slime/swank-ccl.lisp	2009/11/02 07:47:02	1.11
@@ -537,7 +537,8 @@
 
 (defun function-source-location (function)
   (source-note-to-source-location
-   (ccl:function-source-note function)
+   (or (ccl:function-source-note function)
+       (function-name-source-note function))
    (lambda ()
      (format nil "Function has no source note: ~A" function))
    (ccl:function-name function)))
@@ -545,11 +546,19 @@
 (defun pc-source-location (function pc)
   (source-note-to-source-location
    (or (ccl:find-source-note-at-pc function pc)
-       (ccl:function-source-note function))
+       (ccl:function-source-note function)
+       (function-name-source-note function))
    (lambda ()
      (format nil "No source note at PC: ~a[~d]" function pc))
    (ccl:function-name function)))
 
+(defun function-name-source-note (fun)
+  (let ((defs (ccl:find-definition-sources (ccl:function-name fun) 'function)))
+    (and defs
+         (destructuring-bind ((type . name) srcloc . srclocs) (car defs)
+           (declare (ignore type name srclocs))
+           srcloc))))
+
 (defun source-note-to-source-location (source if-nil-thunk &optional name)
   (labels ((filename-to-buffer (filename)
              (cond ((gethash filename *temp-file-map*)
@@ -720,14 +729,9 @@
   (queue '() :type list))
 
 (defimplementation spawn (fun &key name)
-  (flet ((entry ()
-           (handler-bind ((ccl:process-reset (lambda (c) 
-                                               (return-from entry c))))
-             (funcall fun))))
-    (ccl:process-run-function 
-     (or name "Anonymous (Swank)")
-     #'entry)))
-  
+  (ccl:process-run-function (or name "Anonymous (Swank)")
+                            fun))
+
 (defimplementation thread-id (thread)
   (ccl:process-serial-number thread))