[slime-cvs] CVS update: slime/swank-lispworks.lisp

[Helmut Eller]

Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv31046

Modified Files:
	swank-lispworks.lisp 
Log Message:
Use the new format for source locations. Implement the
find-function-locations.
(list-callers, list-callers): New functions.
Date: Sun Nov 30 03:12:12 2003
Author: heller

Index: slime/swank-lispworks.lisp
diff -u slime/swank-lispworks.lisp:1.3 slime/swank-lispworks.lisp:1.4
--- slime/swank-lispworks.lisp:1.3	Sat Nov 29 02:59:12 2003
+++ slime/swank-lispworks.lisp	Sun Nov 30 03:12:11 2003
@@ -7,7 +7,7 @@
 ;;; This code has been placed in the Public Domain.  All warranties
 ;;; are disclaimed.
 ;;;
-;;;   $Id: swank-lispworks.lisp,v 1.3 2003/11/29 07:59:12 heller Exp $
+;;;   $Id: swank-lispworks.lisp,v 1.4 2003/11/30 08:12:11 heller Exp $
 ;;;
 
 (in-package :swank)
@@ -123,6 +123,18 @@
       (if result
           (list* :designator (to-string symbol) result)))))
 
+(defslimefun describe-function (symbol-name)
+  (with-output-to-string (*standard-output*)
+    (let ((sym (from-string symbol-name)))
+      (cond ((fboundp sym)
+             (format t "~%(~A~{ ~A~})~%~%~:[(not documented)~;~:*~A~]~%"
+                     (string-downcase sym)
+                     (mapcar #'string-upcase 
+                             (lispworks:function-lambda-list sym))
+                     (documentation sym 'function))
+             (describe (symbol-function sym)))
+            (t (format t "~S is not fbound" sym))))))
+
 #+(or)
 (defmethod describe-object ((sym symbol) *standard-output*)
   (format t "~A is a symbol in package ~A." sym (symbol-package sym))
@@ -231,15 +243,16 @@
 	      (dspec-source-location func))))))
 
 (defun dspec-source-location (dspec)
-  (let ((locations (dspec:dspec-definition-locations dspec)))
+  (destructuring-bind (first) (dspec-source-locations dspec)
+    first))
+
+(defun dspec-source-locations (dspec)
+  (let ((locations (dspec:find-dspec-locations dspec)))
     (cond ((not locations) 
 	   (list :error (format nil "Cannot find source for ~S" dspec)))
 	  (t
-	   (destructuring-bind ((dspec file) . others) locations
-	     (declare (ignore others))
-	     (if (eq file :unknown)
-		 (list :error (format nil "Cannot find source for ~S" dspec))
-		 (make-dspec-location dspec file)))))))
+           (loop for (dspec location) in locations
+                 collect (make-dspec-location dspec location))))))
 
 (defmethod function-source-location-for-emacs (fname)
   "Return a source position of the definition of FNAME.  The
@@ -247,6 +260,9 @@
 able to return the file name in which the definition occurs."
   (dspec-source-location (from-string fname)))
 
+(defslimefun find-function-locations (fname)
+  (dspec-source-locations (from-string fname)))
+
 ;;; callers
 
 (defun stringify-function-name-list (list)
@@ -296,17 +312,32 @@
     (delete-file filename)))
 
 (defun make-dspec-location (dspec location &optional tmpfile buffer position)
-  (flet ((from-buffer-p () (and (pathnamep location) tmpfile 
-                                (pathname-match-p location tmpfile))))
-    (make-location
-     (etypecase location
-       (pathname (cond ((from-buffer-p) `(:buffer ,buffer))
-                       (t `(:file ,(namestring (truename location)))))))
-     (cond ((from-buffer-p) `(:position ,position))
-           (t `(:dspec , (etypecase dspec
-                           (symbol (symbol-name dspec))
-                           (cons (symbol-name
-                                  (dspec:dspec-primary-name dspec))))))))))
+  (flet ((from-buffer-p () 
+           (and (pathnamep location) tmpfile 
+                (pathname-match-p location tmpfile)))
+         (filename (pathname)
+           (multiple-value-bind (truename condition)
+               (ignore-errors (truename pathname))
+             (cond (condition 
+                    (return-from make-dspec-location
+                      (list :error (format nil "~A" condition))))
+                   (t (namestring truename)))))
+         (function-name (dspec)
+           (etypecase dspec
+             (symbol (symbol-name dspec))
+             (cons (symbol-name (dspec:dspec-primary-name dspec))))))
+    (cond ((from-buffer-p)
+           (make-location `(:buffer ,buffer) `(:position ,position)))
+          (t
+           (etypecase location
+             (pathname 
+              (make-location `(:file ,(filename location))
+                             `(:function-name ,(function-name dspec))))
+             ((member :listener)
+              `(:error ,(format nil "Function defined in listener: ~S" dspec)))
+             ((member :unknown)
+              `(:error ,(format nil "Function location unkown: ~S" dspec))))
+           )))) 
 
 (defun signal-error-data-base (database &optional tmpfile buffer position)
   (map-error-database 
@@ -343,17 +374,20 @@
 
 ;;; xref
 
+(defun lookup-xrefs (finder name)
+  (xref-results-for-emacs (funcall finder (from-string name))))
+
 (defslimefun who-calls (function-name)
-  (xref-results-for-emacs (hcl:who-calls function-name)))
+  (lookup-xrefs #'hcl:who-calls function-name))
 
 (defslimefun who-references (variable)
-  (xref-results-for-emacs (hcl:who-references variable)))
+  (lookup-xrefs #'hcl:who-references variable))
 
 (defslimefun who-binds (variable)
-  (xref-results-for-emacs (hcl:who-binds variable)))
+  (lookup-xrefs #'hcl:who-binds variable))
 
 (defslimefun who-sets (variable)
-  (xref-results-for-emacs (hcl:who-sets variable)))
+  (lookup-xrefs #'hcl:who-sets variable))
 
 (defun xref-results-for-emacs (dspecs)
   (let ((xrefs '()))
@@ -363,6 +397,12 @@
                            (make-dspec-location dspec location))
                      xrefs)))
     (group-xrefs xrefs)))
+
+(defslimefun list-callers (symbol-name)
+  (lookup-xrefs #'hcl:who-calls symbol-name))
+
+(defslimefun list-callees (symbol-name)
+  (lookup-xrefs #'hcl:calls-who symbol-name))
 
 ;; (dspec:at-location 
 ;;  ('(:inside (:buffer "foo" 34)))