(find-definitions): Some tweaking.

swank-allegro.lisp

@@ -207,7 +207,6 @@
 
 ;;;; Definition Finding
 
-
 (defun find-fspec-location (fspec type)
   (let ((file (excl::fspec-pathname fspec type)))
     (etypecase file

swank-clisp.lisp

@@ -116,49 +116,28 @@ Return NIL if the symbol is unbound."
     (:function (describe (symbol-function symbol)))
     (:class (describe (find-class symbol)))))
 
-(defun fspec-pathname (symbol &optional type)
-  (declare (ignore type))
+(defun fspec-pathname (symbol)
   (let ((path (getf (gethash symbol sys::*documentation*) 'sys::file)))
     (if (and path
 	     (member (pathname-type path)
 		     custom:*compiled-file-types* :test #'string=))
-	(loop
-	   for suffix in custom:*source-file-types*
-	   thereis (make-pathname :defaults path :type suffix))
+	(loop for suffix in custom:*source-file-types*
+	      thereis (make-pathname :defaults path :type suffix))
 	path)))
 
-(defun find-multiple-definitions (fspec)
-  (list `(,fspec t)))
-
-(defun find-definition-in-file (fspec type file)
-  (declare (ignore fspec type file))
-  ;; FIXME
-  0)
-
-(defun find-fspec-location (fspec type)
-  (let ((file (fspec-pathname fspec type)))
-    (etypecase file
-      (pathname
-       (let ((start (find-definition-in-file fspec type file)))
-	 (multiple-value-bind (truename c) (ignore-errors (truename file))
-	   (cond (truename 
-		  (make-location (list :file (namestring truename))
-				 (list :function-name (string fspec))))
-		 (t (list :error (princ-to-string c)))))))
-      ((member :top-level)
-       (list :error (format nil "Defined at toplevel: ~A" fspec)))
-      (null 
-       (list :error (format nil "Unkown source location for ~A" fspec))))))
-
-(defun fspec-source-locations (fspec)
-  (let ((defs (find-multiple-definitions fspec)))
-    (loop for (fspec type) in defs 
-          collect (list fspec (find-fspec-location fspec type)))))
-
+(defun fspec-location (fspec)
+  (let ((file (fspec-pathname fspec)))
+    (cond (file
+	   (multiple-value-bind (truename c) (ignore-errors (truename file))
+	     (cond (truename 
+		    (make-location (list :file (namestring truename))
+				   (list :function-name (string fspec))))
+		   (t (list :error (princ-to-string c))))))
+	  (t (list :error (format nil "No source information available for: ~S"
+				  fspec))))))
 
 (defimplementation find-definitions (name)
-  (loop for location in (fspec-source-locations name)
-	collect (list name location)))
+  (list (list name (fspec-location name))))
 
 (defvar *sldb-topframe*)
 (defvar *sldb-botframe*)

swank-cmucl.lisp

@@ -579,6 +579,9 @@ return value is the condition or nil."
 	   (vm::find-code-object function))
        (not (eq closure function))))
 
+(defun genericp (fn)
+  (typep fn 'generic-function))
+
 (defun struct-closure-p (function)
   (or (function-code-object= function #'kernel::structure-slot-accessor)
       (function-code-object= function #'kernel::structure-slot-setter)
@@ -608,44 +611,8 @@ return value is the condition or nil."
      (coerce (if (consp constructor) (car constructor) constructor)
              'function))))
 
-(defun genericp (fn)
-  (typep fn 'generic-function))
-
-(defun gf-definition-location (gf)
-  (flet ((guess-source-file (faslfile)
-           (unix-truename
-            (merge-pathnames (make-pathname :type "lisp")
-                             faslfile))))
-    (let ((def-source (pcl::definition-source gf))
-          (name (string (pcl:generic-function-name gf))))
-      (etypecase def-source
-        (pathname (make-location
-                   `(:file ,(guess-source-file def-source))
-                   `(:function-name ,name)))
-        (cons
-         (destructuring-bind ((dg name) pathname) def-source
-           (declare (ignore dg))
-           (etypecase pathname
-             (pathname 
-              (make-location `(:file ,(guess-source-file pathname)) 
-                             `(:function-name ,(string name))))
-             (null `(:error ,(format nil "Cannot resolve: ~S" def-source)))
-             )))))))
-
-(defun method-source-location (method)
-  (function-source-location (or (pcl::method-fast-function method)
-                                (pcl:method-function method))))
-
-(defun gf-method-locations (gf)
-  (let ((ms (pcl::generic-function-methods gf)))
-    (mapcar #'method-source-location ms)))
-
-(defun gf-source-locations (gf)
-  (list* (gf-definition-location gf)
-         (gf-method-locations gf)))
-
-(defun function-source-locations (function)
-  "Return a list of source locations for FUNCTION."
+(defun function-location (function)
+  "Return the source location for FUNCTION."
   ;; First test if FUNCTION is a closure created by defstruct; if so
   ;; extract the defstruct-description (dd) from the closure and find
   ;; the constructor for the struct.  Defstruct creates a defun for
@@ -655,30 +622,76 @@ return value is the condition or nil."
   ;; For an ordinary function we return the source location of the
   ;; first code-location we find.
   (cond ((struct-closure-p function)
-	 (list 
-          (safe-definition-finding
-           (dd-source-location (struct-closure-dd function)))))
+         (safe-definition-finding
+          (dd-source-location (struct-closure-dd function))))
         ((genericp function)
-         (gf-source-locations function))
+         (gf-location function))
         (t
-         (list
-          (multiple-value-bind (code-location error)
-              (safe-definition-finding (function-first-code-location function))
-            (cond (error (list :error (princ-to-string error)))
-                  (t (code-location-source-location code-location))))))))
-
-(defun function-source-location (function)
-  (destructuring-bind (first) (function-source-locations function)
-    first))
-
-(defimplementation find-definitions (symbol)
+         (multiple-value-bind (code-location error)
+             (safe-definition-finding (function-first-code-location function))
+           (cond (error (list :error (princ-to-string error)))
+                 (t (code-location-source-location code-location)))))))
+
+(defun method-location (method)
+  (function-location (or (pcl::method-fast-function method)
+                         (pcl:method-function method))))
+
+(defun method-dspec (method)
+  (let* ((gf (pcl:method-generic-function method))
+         (name (pcl:generic-function-name gf))
+         (specializers (pcl:method-specializers method)))
+    `(method ,name ,(pcl::unparse-specializers specializers))))
+
+(defun method-definition (method)
+  (list (method-dspec method)
+        (method-location method)))
+
+(defun make-name-in-file-location (file string)
+  (multiple-value-bind (filename c)
+      (ignore-errors (unix-truename 
+                      (merge-pathnames (make-pathname :type "lisp")
+                                       file)))
+    (cond (filename (make-location `(:file ,filename)
+                                   `(:function-name ,string)))
+          (t (list :error (princ-to-string c))))))
+
+(defun gf-location (gf)
+  (let ((def-source (pcl::definition-source gf))
+        (name (string (pcl:generic-function-name gf))))
+    (etypecase def-source
+      (pathname (make-name-in-file-location def-source name))
+      (cons
+       (destructuring-bind ((dg name) pathname) def-source
+         (declare (ignore dg))
+         (etypecase pathname
+           (pathname (make-name-in-file-location pathname (string name)))
+           (null `(:error ,(format nil "Cannot resolve: ~S" def-source)))))))))
+
+(defun gf-method-definitions (gf)
+  (mapcar #'method-definition (pcl::generic-function-methods gf)))
+
+(defun function-definitions (symbol)
+  "Return definitions in the \"function namespace\", i.e.,
+regular functions, generic functions, methods and macros."
   (cond ((macro-function symbol)
-         (mapcar (lambda (loc) `((macro ,symbol) ,loc))
-                 (function-source-locations (macro-function symbol))))
+         (list `((macro ,symbol)
+                 ,(function-location (macro-function symbol)))))
+        ((special-operator-p symbol)
+         (list `((:special-operator ,symbol) 
+                 (:error ,(format nil "Don't know where `~A' is defined" 
+                                  symbol)))))
         ((fboundp symbol)
-         ;; XXX fixme
-         (mapcar (lambda (loc) `((function ,symbol) ,loc))
-                 (function-source-locations (coerce symbol 'function))))))
+         (let ((function (coerce symbol 'function)))
+           (cond ((genericp function)
+                  (cons (list `(:generic-function ,symbol)
+                              (function-location function))
+                        (gf-method-definitions function)))
+                 (t (list (list `(function ,symbol)
+                                (function-location function)))))))))
+
+(defimplementation find-definitions (symbol)
+  (function-definitions symbol))
+
 
 ;;;; Documentation.
 

swank-lispworks.lisp

@@ -157,6 +157,9 @@ Return NIL if the symbol is unbound."
 
 (defun interesting-frame-p (frame)
   (or (dbg::call-frame-p frame)
+      (dbg::derived-call-frame-p frame)
+      (dbg::foreign-frame-p frame)
+      (dbg::interpreted-call-frame-p frame)
       ;;(dbg::catch-frame-p frame)
       ))
 
@@ -203,9 +206,9 @@ Return NIL if the symbol is unbound."
 (defimplementation frame-source-location-for-emacs (frame)
   (let ((frame (nth-frame frame)))
     (if (dbg::call-frame-p frame)
-	(let ((func (dbg::call-frame-function-name frame)))
-	  (if func 
-	      (cadr (name-source-location func)))))))
+	(let ((name (dbg::call-frame-function-name frame)))
+	  (if name
+              (function-name-location name))))))
 
 (defimplementation eval-in-frame (form frame-number)
   (let ((frame (nth-frame frame-number)))
@@ -223,19 +226,16 @@ Return NIL if the symbol is unbound."
 
 ;;; Definition finding
 
-(defun name-source-location (name)
-  (first (name-source-locations name)))
-
-(defun name-source-locations (name)
-  (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))
-    (cond ((not locations) 
-	   (list :error (format nil "Cannot find source for ~S" name)))
-	  (t
-           (loop for (dspec location) in locations
-                 collect (list dspec (make-dspec-location dspec location)))))))
+(defun function-name-location (name)
+  (let ((defs (find-definitions name)))
+    (cond (defs (cadr (first defs)))
+          (t (list :error (format nil "Source location not available for: ~S" 
+                                  name))))))
 
 (defimplementation find-definitions (name)
-  (name-source-locations name))
+  (let ((locations (dspec:find-name-locations dspec:*dspec-classes* name)))
+    (loop for (dspec location) in locations
+          collect (list dspec (make-dspec-location dspec location)))))
 
 ;;; Compilation 
 
@@ -278,16 +278,8 @@ Return NIL if the symbol is unbound."
              (delete-file binary-filename))))
     (delete-file filename)))
 
-;; XXX handle all cases in dspec:*dspec-classes*
 (defun dspec-buffer-position (dspec)
-  (etypecase dspec
-    (cons (ecase (car dspec)
-            ((defun defmacro defgeneric defvar defstruct
-                    method structure package)
-             `(:function-name ,(symbol-name (cadr dspec))))
-            ;; XXX this isn't quite right
-            (lw:top-level-form `(:source-path ,(cdr dspec) nil))))
-    (symbol `(:function-name ,(symbol-name dspec)))))
+  (list :function-name (string (dspec:dspec-primary-name dspec))))
 
 (defun emacs-buffer-location-p (location)
   (and (consp location)
@@ -309,10 +301,7 @@ Return NIL if the symbol is unbound."
       ((or pathname string) 
        (make-location `(:file ,(filename location))
                       (dspec-buffer-position dspec)))
-      ((member :listener)
-       `(:error ,(format nil "Function defined in listener: ~S" dspec)))
-      ((member :unknown)
-       `(:error ,(format nil "Function location unkown: ~S" dspec)))
+      (symbol `(:error ,(format nil "Cannot resolve location: ~S" location)))
       ((satisfies emacs-buffer-location-p)
        (destructuring-bind (_ buffer offset string) location
          (declare (ignore _ offset string))

swank-sbcl.lisp

@@ -375,9 +375,7 @@ This is useful when debugging the definition-finding code.")
   (let ((methods (sb-mop:generic-function-methods gf))
         (name (sb-mop:generic-function-name gf)))
     (loop for method in methods 
-          collect (list `(method ,name ,(mapcar
-                                         #'sb-mop:class-name
-                                         (sb-mop:method-specializers method)))
+          collect (list `(method ,name ,(sb-pcl::unparse-specializers method)) 
                         (safe-function-source-location method name)))))
 
 (defun function-definitions (symbol)
@@ -387,7 +385,7 @@ This is useful when debugging the definition-finding code.")
           ((fboundp symbol)
            (let ((fun (symbol-function symbol)))
              (cond ((typep fun 'sb-mop:generic-function)
-                    (cons (list `(generic ,symbol) (loc fun symbol))
+                    (cons (list `(function ,symbol) (loc fun symbol))
                           (method-definitions fun)))
                    (t
                     (list (list symbol (loc fun symbol))))))))))