[slime-cvs] CVS slime

[mbaringer]

Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv24624

Modified Files:
	swank-openmcl.lisp ChangeLog 
Log Message:


--- /project/slime/cvsroot/slime/swank-openmcl.lisp	2007/04/06 15:42:42	1.116
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp	2007/04/08 13:29:13	1.117
@@ -321,11 +321,43 @@
                )))))))
 
 (defun xref-locations (relation name &optional (inverse nil))
-  (loop for xref in (if inverse 
-                        (ccl::get-relation  relation name :wild :exhaustive t)
-                        (ccl::get-relation  relation :wild name :exhaustive t))
-        for function = (ccl::xref-entry-name xref)
-        collect `((function ,function) ,(function-source-location (ccl::xref-entry-name xref)))))
+  (flet ((function-source-location (entry)
+           (multiple-value-bind (info name)
+               (ccl::edit-definition-p
+                (ccl::%db-key-from-xref-entry entry)
+                (if (eql (ccl::xref-entry-type entry)
+                         'macro)
+                    'function
+                    (ccl::xref-entry-type entry)))
+             (cond ((not info)
+                    (list :error
+                          (format nil "No source info available for ~A"
+                                  (ccl::xref-entry-name entry))))
+                   ((typep (caar info) 'ccl::method)
+                    `(:location 
+                      (:file ,(remove-filename-quoting
+                               (namestring (translate-logical-pathname
+                                            (cdr (car info))))))
+                      (:method
+                          ,(princ-to-string (ccl::method-name (caar info)))
+                        ,(mapcar 'princ-to-string
+                                 (mapcar #'specializer-name
+                                         (ccl::method-specializers
+                                          (caar info))))
+                        ,@(mapcar 'princ-to-string
+                                  (ccl::method-qualifiers (caar info))))
+                      nil))
+                   (t
+                    (canonicalize-location (cdr (first info)) name))))))
+    (declare (dynamic-extent #'function-source-location))
+    (loop for xref in (if inverse 
+                          (ccl::get-relation relation name
+                                             :wild :exhaustive t)
+                          (ccl::get-relation relation
+                                             :wild name :exhaustive t))
+       for function = (ccl::xref-entry-name xref)
+       collect `((function ,function)
+                 ,(function-source-location xref)))))
 
 (defimplementation who-binds (name)
   (xref-locations :binds name))
--- /project/slime/cvsroot/slime/ChangeLog	2007/04/08 12:52:18	1.1098
+++ /project/slime/cvsroot/slime/ChangeLog	2007/04/08 13:29:13	1.1099
@@ -1,3 +1,7 @@
+2007-04-08 Takehiko Abe <keke at gol.com>
+
+	* swank-openmcl.lisp (xref-locations):
+	
 2007-04-07 Harald Hanche-Olsen <hanche at math.ntnu.no>
 
 	* slime.el (sldb-mode-map): Added key definition for follow-link.