[slime-cvs] CVS slime

[CVS User heller]

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

Modified Files:
	ChangeLog swank-allegro.lisp 
Log Message:
Some more fixes for Allegro

* swank-allegro.lisp (function-source-location): Use
xref::object-to-function-name which seems to work better for some
cases.
(fspec-definition-locations): For :top-level-forms return a list
of ((fspec loc)) not just (fspec loc).  Also deal with the file
vs. buffer issue.

--- /project/slime/cvsroot/slime/ChangeLog	2010/03/08 16:31:59	1.2027
+++ /project/slime/cvsroot/slime/ChangeLog	2010/03/09 08:02:37	1.2028
@@ -1,3 +1,14 @@
+2010-03-09  Helmut Eller  <heller at common-lisp.net>
+
+	Some more fixes for Allegro
+
+	* swank-allegro.lisp (function-source-location): Use
+	xref::object-to-function-name which seems to work better for some
+	cases.
+	(fspec-definition-locations): For :top-level-forms return a list
+	of ((fspec loc)) not just (fspec loc).  Also deal with the file
+	vs. buffer issue.
+
 2010-03-08  Stas Boukarev  <stassats at gmail.com>
 
 	* slime.el (slime-extract-context): Add defvar and defparameter.
--- /project/slime/cvsroot/slime/swank-allegro.lisp	2010/03/08 16:20:10	1.136
+++ /project/slime/cvsroot/slime/swank-allegro.lisp	2010/03/09 08:02:37	1.137
@@ -205,7 +205,7 @@
                          (car (debugger:frame-expression frame))))))))))
 
 (defun function-source-location (fun)
-  (cadr (car (fspec-definition-locations fun))))
+  (cadr (car (fspec-definition-locations (xref::object-to-function-name fun)))))
 
 #+(version>= 8 2)
 (defun pc-source-location (fun pc)
@@ -464,16 +464,22 @@
 
 ;;;; Definition Finding
 
-(defun buffer-or-file-location (file offset)
+(defun buffer-or-file (file file-fun buffer-fun)
   (let* ((probe (gethash file *temp-file-map*)))
-    (cond ((not probe)
-           (make-location `(:file ,(namestring (truename file)))
-                          `(:position ,(1+ offset))))
-          (t
+    (cond (probe 
            (destructuring-bind (buffer start file) probe
              (declare (ignore file))
-             (make-location `(:buffer ,buffer)
-                            `(:offset ,start ,offset)))))))
+             (funcall buffer-fun buffer start)))
+          (t (funcall file-fun (namestring (truename file)))))))
+
+(defun buffer-or-file-location (file offset)
+  (buffer-or-file file 
+                  (lambda (filename)
+                    (make-location `(:file ,filename)
+                                   `(:position ,(1+ offset))))
+                  (lambda (buffer start)
+                    (make-location `(:buffer ,buffer)
+                                   `(:offset ,start ,offset)))))
 
 (defun fspec-primary-name (fspec)
   (etypecase fspec
@@ -530,10 +536,8 @@
           (eql (car fspec) :top-level-form))
      (destructuring-bind (top-level-form file &optional position) fspec 
        (declare (ignore top-level-form))
-       (list fspec
-             (make-location (list :buffer file) ; FIXME: should use :file
-                            (list :position position)
-                            (list :align t)))))
+       `((,fspec
+          ,(buffer-or-file-location file position)))))
     ((and (listp fspec) (eq (car fspec) :internal))
      (destructuring-bind (_internal next _n) fspec
        (declare (ignore _internal _n))