[slime-cvs] CVS slime
CVS User trittweiler
trittweiler at common-lisp.net
Thu Dec 10 22:21:09 UTC 2009
Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv26127
Modified Files:
swank-sbcl.lisp swank-backend.lisp ChangeLog
Log Message:
* swank-backend.lisp (*debug-swank-backend*): New variable. If
true, backends should not catch internal errors (e.g. during
definition finding), and should not perform backtrace magic.
(make-error-location): New helper.
(find-definitions [interface]): Default to error location.
* swank-sbcl.lisp (converting-errors-to-location): New helper
macro. Regards new *DEBUG-SWANK-BACKEND*.
(find-definitions [implementation]): Use it.
(find-source-location [implementation]): Ditto.
(functiond-spec): Ditto.
(frame-source-location [implementation]): Ditto.
(*debug-definition-finding*): Removed.
(make-source-location-specification): Removed.
(safe-function-source-location): Removed.
(safe-source-location-for-emacs): Removed. Not needed anymore.
(call-with-debugging-environment): Do not perform stack hinting
depending on *DEBUG-SWANK-BACKEND*.
--- /project/slime/cvsroot/slime/swank-sbcl.lisp 2009/12/10 20:51:33 1.257
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2009/12/10 22:21:09 1.258
@@ -642,9 +642,17 @@
;;;; Definitions
-(defvar *debug-definition-finding* nil
- "When true don't handle errors while looking for definitions.
-This is useful when debugging the definition-finding code.")
+(defmacro converting-errors-to-location (&body body)
+ "Catches error and converts them to an error location."
+ (let ((gblock (gensym "CONVERTING-ERRORS+")))
+ `(block ,gblock
+ (handler-bind ((error
+ #'(lambda (e)
+ (if *debug-swank-backend*
+ nil ;decline
+ (return-from ,gblock
+ (make-error-location e))))))
+ , at body))))
(defparameter *definition-types*
'(:variable defvar
@@ -676,14 +684,21 @@
:def-ir1-translator
(getf *definition-types* type)))
+(defun make-dspec (type name source-location)
+ (list* (definition-specifier type name)
+ name
+ (sb-introspect::definition-source-description source-location)))
(defimplementation find-definitions (name)
(loop for type in *definition-types* by #'cddr
for locations = (sb-introspect:find-definition-sources-by-name
name type)
append (loop for source-location in locations collect
- (make-source-location-specification type name
- source-location))))
+ (list (make-dspec type name source-location)
+ (converting-errors-to-location
+ (make-definition-source-location source-location
+ type
+ name))))))
(defimplementation find-source-location (obj)
(flet ((general-type-of (obj)
@@ -706,26 +721,11 @@
(with-output-to-string (s)
(print-unreadable-object (obj s :type t :identity t))))
(t (princ-to-string obj)))))
- (handler-case
- (make-definition-source-location
- (sb-introspect:find-definition-source obj) (general-type-of obj) (to-string obj))
- (error (e)
- (list :error (format nil "Error: ~A" e))))))
-
-
-(defun make-source-location-specification (type name source-location)
- (list (make-dspec type name source-location)
- (if *debug-definition-finding*
- (make-definition-source-location source-location type name)
- (handler-case
- (make-definition-source-location source-location type name)
- (error (e)
- (list :error (format nil "Error: ~A" e)))))))
+ (converting-errors-to-location
+ (make-definition-source-location (sb-introspect:find-definition-source obj)
+ (general-type-of obj)
+ (to-string obj)))))
-(defun make-dspec (type name source-location)
- (list* (definition-specifier type name)
- name
- (sb-introspect::definition-source-description source-location)))
(defun make-definition-source-location (definition-source type name)
(with-struct (sb-introspect::definition-source-
@@ -779,13 +779,6 @@
(let ((location (sb-introspect:find-definition-source function)))
(make-definition-source-location location :function 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 :error (format nil "Error: ~A" e))))))
-
(defimplementation describe-symbol-for-emacs (symbol)
"Return a plist describing SYMBOL.
Return NIL if the symbol is unbound."
@@ -854,12 +847,9 @@
(defun source-location-for-xref-data (xref-data)
(let ((name (car xref-data))
(source-location (cdr xref-data)))
- (list name
- (handler-case (make-definition-source-location source-location
- 'function
- name)
- (error (e)
- (list :error (format nil "Error: ~A" e)))))))
+ (list name (make-definition-source-location source-location
+ 'function
+ name))))
(defimplementation list-callers (symbol)
(let ((fn (fdefinition symbol)))
@@ -900,7 +890,8 @@
"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))))
+ (list name (converting-errors-to-location
+ (function-source-location fn name)))))
;;; macroexpansion
@@ -959,7 +950,9 @@
(defimplementation call-with-debugging-environment (debugger-loop-fn)
(declare (type function debugger-loop-fn))
- (let* ((*sldb-stack-top* (or sb-debug:*stack-top-hint* (sb-di:top-frame)))
+ (let* ((*sldb-stack-top* (if *debug-swank-backend*
+ (sb-di:top-frame)
+ (or sb-debug:*stack-top-hint* (sb-di:top-frame))))
(sb-debug:*stack-top-hint* nil))
(handler-bind ((sb-di:debug-condition
(lambda (condition)
@@ -1128,15 +1121,10 @@
;;; source-path-file-position and friends are in swank-source-path-parser
-(defun safe-source-location-for-emacs (code-location)
- (if *debug-definition-finding*
- (code-location-source-location code-location)
- (handler-case (code-location-source-location code-location)
- (error (c) (list :error (format nil "~A" c))))))
-
(defimplementation frame-source-location (index)
- (safe-source-location-for-emacs
- (sb-di:frame-code-location (nth-frame index))))
+ (converting-errors-to-location
+ (code-location-source-location
+ (sb-di:frame-code-location (nth-frame index)))))
(defun frame-debug-vars (frame)
"Return a vector of debug-variables in frame."
--- /project/slime/cvsroot/slime/swank-backend.lisp 2009/11/21 21:32:28 1.185
+++ /project/slime/cvsroot/slime/swank-backend.lisp 2009/12/10 22:21:09 1.186
@@ -12,7 +12,8 @@
(defpackage :swank-backend
(:use :common-lisp)
- (:export #:sldb-condition
+ (:export #:*debug-swank-backend*
+ #:sldb-condition
#:compiler-condition
#:original-condition
#:message
@@ -32,6 +33,7 @@
#:unbound-slot-filler
#:declaration-arglist
#:type-specifier-arglist
+ #:with-struct
;; interrupt macro for the backend
#:*pending-slime-interrupts*
#:check-slime-interrupts
@@ -40,8 +42,6 @@
#:emacs-inspect
#:label-value-line
#:label-value-line*
-
- #:with-struct
))
(defpackage :swank-mop
@@ -102,6 +102,11 @@
;;;; Metacode
+(defparameter *debug-swank-backend* nil
+ "If this is true, backends should not catch errors but enter the
+debugger where appropriate. Also, they should not perform backtrace
+magic but really show every frame including SWANK related ones.")
+
(defparameter *interface-functions* '()
"The names of all interface functions.")
@@ -790,6 +795,15 @@
(defstruct (:buffer (:type list) :named (:constructor)) name)
(defstruct (:position (:type list) :named (:constructor)) pos)
+(defun make-error-location (datum &rest args)
+ (cond ((typep datum 'condition)
+ `(:error ,(format nil "Error: ~A" datum)))
+ ((symbolp datum)
+ `(:error ,(format nil "Error: ~A" (apply #'make-condition datum args))))
+ (t
+ (assert (stringp datum))
+ `(:error ,(apply #'format nil datum args)))))
+
(definterface find-definitions (name)
"Return a list ((DSPEC LOCATION) ...) for NAME's definitions.
@@ -811,7 +825,9 @@
;; This returns one source location and not a list of locations. It's
;; supposed to return the location of the DEFGENERIC definition on
;; #'SOME-GENERIC-FUNCTION.
- )
+ (declare (ignore object))
+ (make-error-location "FIND-DEFINITIONS is not yet implemented on ~
+ this implementation."))
(definterface buffer-first-change (filename)
--- /project/slime/cvsroot/slime/ChangeLog 2009/12/10 20:51:33 1.1929
+++ /project/slime/cvsroot/slime/ChangeLog 2009/12/10 22:21:09 1.1930
@@ -1,5 +1,27 @@
2009-12-10 Tobias C. Rittweiler <tcr at freebits.de>
+ * swank-backend.lisp (*debug-swank-backend*): New variable. If
+ true, backends should not catch internal errors (e.g. during
+ definition finding), and should not perform backtrace magic.
+ (make-error-location): New helper.
+ (find-definitions [interface]): Default to error location.
+
+ * swank-sbcl.lisp (converting-errors-to-location): New helper
+ macro. Regards new *DEBUG-SWANK-BACKEND*.
+ (find-definitions [implementation]): Use it.
+ (find-source-location [implementation]): Ditto.
+ (functiond-spec): Ditto.
+ (frame-source-location [implementation]): Ditto.
+ (*debug-definition-finding*): Removed.
+ (make-source-location-specification): Removed.
+ (safe-function-source-location): Removed.
+ (safe-source-location-for-emacs): Removed. Not needed anymore.
+
+ (call-with-debugging-environment): Do not perform stack hinting
+ depending on *DEBUG-SWANK-BACKEND*.
+
+2009-12-10 Tobias C. Rittweiler <tcr at freebits.de>
+
* swank-sbcl.lisp (set-break-hook): New.
(call-with-break-hook): New, too. Both extracted from elsewhere.
(install-debugger-globally, call-with-debugger-hook): Use them.
More information about the slime-cvs
mailing list