[slime-cvs] CVS update: slime/swank-clisp.lisp slime/swank-cmucl.lisp slime/swank-lispworks.lisp slime/swank-sbcl.lisp slime/swank-allegro.lisp
Helmut Eller
heller at common-lisp.net
Wed Mar 10 08:24:49 UTC 2004
Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv32001
Modified Files:
swank-clisp.lisp swank-cmucl.lisp swank-lispworks.lisp
swank-sbcl.lisp swank-allegro.lisp
Log Message:
(find-definitions): Some tweaking.
Date: Wed Mar 10 03:24:46 2004
Author: heller
Index: slime/swank-clisp.lisp
diff -u slime/swank-clisp.lisp:1.25 slime/swank-clisp.lisp:1.26
--- slime/swank-clisp.lisp:1.25 Tue Mar 9 07:46:27 2004
+++ slime/swank-clisp.lisp Wed Mar 10 03:24:44 2004
@@ -116,49 +116,28 @@
(: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*)
Index: slime/swank-cmucl.lisp
diff -u slime/swank-cmucl.lisp:1.82 slime/swank-cmucl.lisp:1.83
--- slime/swank-cmucl.lisp:1.82 Tue Mar 9 15:07:58 2004
+++ slime/swank-cmucl.lisp Wed Mar 10 03:24:44 2004
@@ -579,6 +579,9 @@
(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 @@
(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 @@
;; 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.
Index: slime/swank-lispworks.lisp
diff -u slime/swank-lispworks.lisp:1.32 slime/swank-lispworks.lisp:1.33
--- slime/swank-lispworks.lisp:1.32 Tue Mar 9 15:07:58 2004
+++ slime/swank-lispworks.lisp Wed Mar 10 03:24:45 2004
@@ -157,6 +157,9 @@
(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 @@
(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 @@
;;; 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 @@
(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 @@
((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))
Index: slime/swank-sbcl.lisp
diff -u slime/swank-sbcl.lisp:1.74 slime/swank-sbcl.lisp:1.75
--- slime/swank-sbcl.lisp:1.74 Tue Mar 9 07:46:27 2004
+++ slime/swank-sbcl.lisp Wed Mar 10 03:24:45 2004
@@ -375,9 +375,7 @@
(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 @@
((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))))))))))
Index: slime/swank-allegro.lisp
diff -u slime/swank-allegro.lisp:1.22 slime/swank-allegro.lisp:1.23
--- slime/swank-allegro.lisp:1.22 Tue Mar 9 15:07:58 2004
+++ slime/swank-allegro.lisp Wed Mar 10 03:24:45 2004
@@ -207,7 +207,6 @@
;;;; Definition Finding
-
(defun find-fspec-location (fspec type)
(let ((file (excl::fspec-pathname fspec type)))
(etypecase file
More information about the slime-cvs
mailing list