[slime-cvs] CVS update: slime/swank-sbcl.lisp
Luke Gorrie
lgorrie at common-lisp.net
Sat Mar 12 01:50:19 UTC 2005
Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv4985
Modified Files:
swank-sbcl.lisp
Log Message:
Use swank-source-file-cache to find snippets of definitions. M-. is
now much more robust to modifications in the source file.
NOTE: To be effective requires a patch to sb-introspect that I have
posted to sbcl-devel.
Date: Sat Mar 12 02:50:17 2005
Author: lgorrie
Index: slime/swank-sbcl.lisp
diff -u slime/swank-sbcl.lisp:1.121 slime/swank-sbcl.lisp:1.122
--- slime/swank-sbcl.lisp:1.121 Thu Mar 3 01:11:58 2005
+++ slime/swank-sbcl.lisp Sat Mar 12 02:50:15 2005
@@ -293,8 +293,11 @@
(handler-case
(let ((output-file (with-compilation-hooks ()
(compile-file filename))))
- (when (and load-p output-file)
- (load output-file)))
+ (when output-file
+ ;; Cache the latest source file for definition-finding.
+ (source-cache-get filename (file-write-date filename))
+ (when load-p
+ (load output-file))))
(sb-c:fatal-compiler-error () nil)))
(defimplementation swank-compile-string (string &key buffer position directory)
@@ -317,6 +320,37 @@
"When true don't handle errors while looking for definitions.
This is useful when debugging the definition-finding code.")
+(defimplementation find-definitions (name)
+ (append (function-definitions name)
+ (compiler-definitions name)))
+
+;;;;; Function definitions
+
+(defun function-definitions (name)
+ (flet ((loc (fn name) (safe-function-source-location fn name)))
+ (append
+ (cond ((and (symbolp name) (macro-function name))
+ (list (list `(defmacro ,name)
+ (loc (macro-function name) name))))
+ ((fboundp name)
+ (let ((fn (fdefinition name)))
+ (typecase fn
+ (generic-function
+ (cons (list `(defgeneric ,name) (loc fn name))
+ (method-definitions fn)))
+ (t
+ (list (list `(function ,name) (loc fn name))))))))
+ (when (compiler-macro-function name)
+ (list (list `(define-compiler-macro ,name)
+ (loc (compiler-macro-function name) name)))))))
+
+(defun safe-function-source-location (fun name)
+ (if *debug-definition-finding*
+ (function-source-location fun name)
+ (handler-case (function-source-location fun name)
+ (error (e)
+ (list (list :error (format nil "Error: ~A" e)))))))
+
;;; FIXME we don't handle the compiled-interactively case yet. That
;;; should have NIL :filename & :position, and non-NIL :source-form
(defun function-source-location (function &optional name)
@@ -324,7 +358,12 @@
(let* ((def (sb-introspect:find-definition-source function))
(pathname (sb-introspect:definition-source-pathname def))
(path (sb-introspect:definition-source-form-path def))
- (position (sb-introspect:definition-source-character-offset def)))
+ (position (sb-introspect:definition-source-character-offset def))
+ (stamp
+ ;; FIXME: Symbol doesn't exist in released SBCL yet.
+ (let ((sym (find-symbol "DEFINITION-SOURCE-CREATED"
+ (find-package "SB-INTROSPECT"))))
+ (when sym (funcall sym def)))))
(unless pathname
(return-from function-source-location
(list :error (format nil "No filename for: ~S" function))))
@@ -341,14 +380,12 @@
(cond (path (list :source-path path position))
(t (list :function-name
(or (and name (string name))
- (string (sb-kernel:%fun-name function))))))))))
-
-(defun safe-function-source-location (fun name)
- (if *debug-definition-finding*
- (function-source-location fun name)
- (handler-case (function-source-location fun name)
- (error (e)
- (list (list :error (format nil "Error: ~A" e)))))))
+ (string (sb-kernel:%fun-name function))))))
+ (let ((source (get-source-code pathname stamp)))
+ (if source
+ (with-input-from-string (stream source)
+ (file-position stream position)
+ (list :snippet (read-snippet stream)))))))))
(defun method-definitions (gf)
(let ((methods (sb-mop:generic-function-methods gf))
@@ -357,23 +394,13 @@
collect (list `(method ,name ,(sb-pcl::unparse-specializers method))
(safe-function-source-location method name)))))
-(defun function-definitions (name)
- (flet ((loc (fn name) (safe-function-source-location fn name)))
- (append
- (cond ((and (symbolp name) (macro-function name))
- (list (list `(defmacro ,name)
- (loc (macro-function name) name))))
- ((fboundp name)
- (let ((fn (fdefinition name)))
- (typecase fn
- (generic-function
- (cons (list `(defgeneric ,name) (loc fn name))
- (method-definitions fn)))
- (t
- (list (list `(function ,name) (loc fn name))))))))
- (when (compiler-macro-function name)
- (list (list `(define-compiler-macro ,name)
- (loc (compiler-macro-function name) name)))))))
+;;;;; Compiler definitions
+
+(defun compiler-definitions (name)
+ (let ((fun-info (sb-int:info :function :info name)))
+ (when fun-info
+ (append (transform-definitions fun-info name)
+ (optimizer-definitions fun-info name)))))
(defun transform-definitions (fun-info name)
(loop for xform in (sb-c::fun-info-transforms fun-info)
@@ -396,16 +423,6 @@
when fn collect `((sb-c:defoptimizer ,name)
,(safe-function-source-location fn fun-name)))))
-(defun compiler-definitions (name)
- (let ((fun-info (sb-int:info :function :info name)))
- (when fun-info
- (append (transform-definitions fun-info name)
- (optimizer-definitions fun-info name)))))
-
-(defimplementation find-definitions (name)
- (append (function-definitions name)
- (compiler-definitions name)))
-
(defimplementation describe-symbol-for-emacs (symbol)
"Return a plist describing SYMBOL.
Return NIL if the symbol is unbound."
@@ -447,12 +464,6 @@
(:type
(describe (sb-kernel:values-specifier-type symbol)))))
-(defun function-dspec (fn)
- "Describe where the function FN was defined.
-Return a list of the form (NAME LOCATION)."
- (let ((name (sb-kernel:%fun-name fn)))
- (list name (safe-function-source-location fn name))))
-
(defimplementation list-callers (symbol)
(let ((fn (fdefinition symbol)))
(mapcar #'function-dspec (sb-introspect:find-function-callers fn))))
@@ -461,6 +472,12 @@
(let ((fn (fdefinition symbol)))
(mapcar #'function-dspec (sb-introspect:find-function-callees fn))))
+(defun function-dspec (fn)
+ "Describe where the function FN was defined.
+Return a list of the form (NAME LOCATION)."
+ (let ((name (sb-kernel:%fun-name fn)))
+ (list name (safe-function-source-location fn name))))
+
;;; macroexpansion
(defimplementation macroexpand-all (form)
@@ -573,7 +590,8 @@
(defun source-location-for-emacs (code-location)
(let* ((debug-source (sb-di:code-location-debug-source code-location))
(from (sb-di:debug-source-from debug-source))
- (name (sb-di:debug-source-name debug-source)))
+ (name (sb-di:debug-source-name debug-source))
+ (created (sb-di:debug-source-created debug-source)))
(ecase from
(:file
(let ((source-path (ignore-errors
@@ -583,7 +601,12 @@
(let ((position (code-location-file-position code-location)))
(make-location
(list :file (namestring (truename name)))
- (list :source-path source-path position))))
+ (list :source-path source-path position)
+ (let ((source (get-source-code name created)))
+ (if source
+ (with-input-from-string (stream source)
+ (file-position stream position)
+ (list :snippet (read-snippet stream))))))))
(t
(let* ((dfn (sb-di:code-location-debug-fun code-location))
(fn (sb-di:debug-fun-fun dfn)))
More information about the slime-cvs
mailing list