[slime-cvs] CVS slime
trittweiler
trittweiler at common-lisp.net
Fri Sep 12 12:27:47 UTC 2008
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv21121
Modified Files:
swank.lisp swank-scl.lisp swank-sbcl.lisp swank-openmcl.lisp
swank-lispworks.lisp swank-corman.lisp swank-cmucl.lisp
swank-clisp.lisp swank-backend.lisp swank-allegro.lisp
swank-abcl.lisp slime.el ChangeLog
Log Message:
New faces: `sldb-restartable-frame-line-face',
`sldb-non-restartable-frame-line-face'.
The former is the face for frames that are surely restartable, the
latter for frames that are surely not restartable. If
restartability of a frame cannot be reliably determined, the face
`sldb-frame-line-face' is used.
At the moment, determination of frame restartability is supported
by the SBCL backend only.
* slime.el (sldb-frame.string): New.
(sldb-frame.number): New.
(sldb-frame.plist): New.
(sldb-prune-initial-frames): Use them.
(sldb-insert-frames): Ditto.
(sldb-compute-frame-face): New.
(sldb-insert-frame): Use `sldb-compute-frame-face' to insert
frames with one of the faces described above.
* swank.lisp (defslimefun backtrace): Changed return value; each
frame is now accompanied with a PLIST which at the moment can
contain :RESTARTABLE NIL/T/:UNKNOWN depending on whether the frame
is restartable, or not.
* swank-backend.lisp (defstruct swank-frame): New structure.
(compute-backtrace): Is now supposed to return a list of SWANK-FRAMEs.
(print-frame): Renamed to PRINT-SWANK-FRAME.
* swank-sbcl.lisp, swank-cmucl.lisp, swank-lispworks.lisp,
* swank-allegro.lisp, swank-scl.lisp, swank-openmcl.lisp,
* swank-abcl.lisp, swank-clisp.lisp: Adapted to swank-backend changes.
--- /project/slime/cvsroot/slime/swank.lisp 2008/09/10 23:10:45 1.585
+++ /project/slime/cvsroot/slime/swank.lisp 2008/09/12 12:27:37 1.586
@@ -2245,19 +2245,26 @@
(list :debug-activate (current-thread-id) *sldb-level* t)))
(defslimefun backtrace (start end)
- "Return a list ((I FRAME) ...) of frames from START to END.
-I is an integer describing and FRAME a string."
- (loop for frame in (compute-backtrace start end)
- for i from start collect
- (list i
- (call/truncated-output-to-string
- 100
- (lambda (stream)
- (handler-case
- (with-bindings *backtrace-printer-bindings*
- (print-frame frame stream))
- (t ()
- (format stream "[error printing frame]"))))))))
+ "Return a list ((I FRAME PLIST) ...) of frames from START to END.
+
+I is an integer, and can be used to reference the corresponding frame
+from Emacs; FRAME is a string representation of an implementation's
+frame."
+ (flet ((print-swank-frame-to-string (frame)
+ (call/truncated-output-to-string
+ 100
+ (lambda (stream)
+ (handler-case
+ (with-bindings *backtrace-printer-bindings*
+ (print-swank-frame frame stream))
+ (t ()
+ (format stream "[error printing frame]")))))))
+ (loop for frame in (compute-backtrace start end)
+ for i from start collect
+ (list i (print-swank-frame-to-string frame)
+ (list :restartable (let ((r (swank-frame.restartable frame)))
+ (check-type r (member nil t :unknown))
+ r))))))
(defslimefun debugger-info-for-emacs (start end)
"Return debugger state, with stack frames from START to END.
@@ -2266,9 +2273,11 @@
where
condition ::= (description type [extra])
restart ::= (name description)
- stack-frame ::= (number description)
+ stack-frame ::= (number description [plist])
extra ::= (:references and other random things)
cont ::= continutation
+ plist ::= (:restartable {nil | t | :unknown})
+
condition---a pair of strings: message, and type. If show-source is
not nil it is a frame number for which the source should be displayed.
@@ -2288,7 +2297,7 @@
\"[Condition of type DIVISION-BY-ZERO]\")
((\"ABORT\" \"Return to Slime toplevel.\")
(\"ABORT\" \"Return to Top-Level.\"))
- ((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\"))
+ ((0 \"(KERNEL::INTEGER-/-INTEGER 1 0)\" (:restartable nil)))
(4))"
(list (debugger-condition-for-emacs)
(format-restarts-for-emacs)
--- /project/slime/cvsroot/slime/swank-scl.lisp 2008/08/31 11:58:01 1.23
+++ /project/slime/cvsroot/slime/swank-scl.lisp 2008/09/12 12:27:38 1.24
@@ -1372,11 +1372,11 @@
(let ((end (or end most-positive-fixnum)))
(loop for f = (nth-frame start) then (frame-down f)
for i from start below end
- while f
- collect f)))
+ while f collect (make-swank-frame :%frame f :restartable :unknown))))
-(defimplementation print-frame (frame stream)
- (let ((*standard-output* stream))
+(defimplementation print-swank-frame (swank-frame stream)
+ (let ((frame (swank-frame.%frame swank-frame))
+ (*standard-output* stream))
(handler-case
(debug::print-frame-call frame :verbosity 1 :number nil)
(error (e)
--- /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/08/30 15:33:56 1.217
+++ /project/slime/cvsroot/slime/swank-sbcl.lisp 2008/09/12 12:27:38 1.218
@@ -262,7 +262,7 @@
(defun sbcl-source-file-p (filename)
(when filename
- (loop for (_ pattern) in (logical-pathname-translations "SYS")
+ (loop for (nil pattern) in (logical-pathname-translations "SYS")
thereis (pathname-match-p filename pattern))))
(defun guess-readtable-for-filename (filename)
@@ -849,11 +849,16 @@
(let ((end (or end most-positive-fixnum)))
(loop for f = (nth-frame start) then (sb-di:frame-down f)
for i from start below end
- while f
- collect f)))
-
-(defimplementation print-frame (frame stream)
- (sb-debug::print-frame-call frame stream))
+ while f collect (make-swank-frame
+ :%frame f
+ :restartable (frame-restartable-p f)))))
+
+(defimplementation print-swank-frame (swank-frame stream)
+ (sb-debug::print-frame-call (swank-frame.%frame swank-frame) stream))
+
+(defun frame-restartable-p (frame)
+ #+#.(swank-backend::sbcl-with-restart-frame)
+ (sb-debug:frame-has-debug-tag-p frame))
;;;; Code-location -> source-location translation
--- /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/08/11 07:40:23 1.132
+++ /project/slime/cvsroot/slime/swank-openmcl.lisp 2008/09/12 12:27:38 1.133
@@ -538,25 +538,25 @@
(format nil "~{ ~A~}" (nreverse result)))))
-;; XXX should return something less stringy
-;; alanr May 13, 2004: put #<> around anonymous functions in the backtrace.
-
(defimplementation compute-backtrace (start-frame-number end-frame-number)
(let (result)
- (map-backtrace (lambda (frame-number p context lfun pc)
- (declare (ignore frame-number))
- (push (with-output-to-string (s)
- (format s "(~A~A)"
- (if (ccl::function-name lfun)
- (ccl::%lfun-name-string lfun)
- lfun)
- (frame-arguments p context lfun pc)))
+ (map-backtrace (lambda (frame-number p context lfun pc)
+ (declare (ignore frame-number))
+ (push (make-swank-frame :%frame (list :openmcl-frame p context lfun pc)
+ :restartable :unknown)
result))
start-frame-number end-frame-number)
(nreverse result)))
-(defimplementation print-frame (frame stream)
- (princ frame stream))
+(defimplementation print-swank-frame (swank-frame stream)
+ (let ((frame (swank-frame.%frame swank-frame)))
+ (assert (eq (first frame) :openmcl-frame))
+ (destructuring-bind (p context lfun pc) (rest frame)
+ (format stream "(~A~A)"
+ (if (ccl::function-name lfun)
+ (ccl::%lfun-name-string lfun)
+ lfun)
+ (frame-arguments p context lfun pc)))))
(defimplementation frame-locals (index)
(block frame-locals
--- /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/08/11 07:39:15 1.113
+++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/09/12 12:27:38 1.114
@@ -291,7 +291,8 @@
((or (not frame) (= i end)) (nreverse backtrace))
(when (interesting-frame-p frame)
(incf i)
- (push frame backtrace)))))
+ (push (make-swank-frame :%frame frame :restartable :unknown)
+ backtrace)))))
(defun frame-actual-args (frame)
(let ((*break-on-signals* nil))
@@ -303,12 +304,13 @@
(error (e) (format nil "<~A>" arg))))))
(dbg::call-frame-arglist frame))))
-(defimplementation print-frame (frame stream)
- (cond ((dbg::call-frame-p frame)
- (format stream "~S ~S"
- (dbg::call-frame-function-name frame)
- (frame-actual-args frame)))
- (t (princ frame stream))))
+(defimplementation print-swank-frame (swank-frame stream)
+ (let ((frame (swank-frame.%frame swank-frame)))
+ (cond ((dbg::call-frame-p frame)
+ (format stream "~S ~S"
+ (dbg::call-frame-function-name frame)
+ (frame-actual-args frame)))
+ (t (princ frame stream)))))
(defun frame-vars (frame)
(first (dbg::frame-locals-format-list frame #'list 75 0)))
--- /project/slime/cvsroot/slime/swank-corman.lisp 2008/04/17 14:56:43 1.16
+++ /project/slime/cvsroot/slime/swank-corman.lisp 2008/09/12 12:27:38 1.17
@@ -176,10 +176,11 @@
(funcall fn)))
(defimplementation compute-backtrace (start end)
- (subseq *stack-trace* start (min end (length *stack-trace*))))
+ (loop for f in (subseq *stack-trace* start (min end (length *stack-trace*)))
+ collect (make-swank-frame :%frame f :restartable :unknown)))
-(defimplementation print-frame (frame stream)
- (format stream "~S" frame))
+(defimplementation print-swank-frame (frame stream)
+ (format stream "~S" (swank-frame.%frame frame)))
(defun get-frame-debug-info (frame)
(or (frame-debug-info frame)
--- /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/09/11 10:31:35 1.192
+++ /project/slime/cvsroot/slime/swank-cmucl.lisp 2008/09/12 12:27:38 1.193
@@ -1503,11 +1503,11 @@
(let ((end (or end most-positive-fixnum)))
(loop for f = (nth-frame start) then (frame-down f)
for i from start below end
- while f
- collect f)))
+ while f collect (make-swank-frame :%frame f :restartable :unknown))))
-(defimplementation print-frame (frame stream)
- (let ((*standard-output* stream))
+(defimplementation print-swank-frame (swank-frame stream)
+ (let ((frame (swank-frame.%frame swank-frame))
+ (*standard-output* stream))
(handler-case
(debug::print-frame-call frame :verbosity 1 :number nil)
(error (e)
--- /project/slime/cvsroot/slime/swank-clisp.lisp 2008/08/12 17:54:43 1.74
+++ /project/slime/cvsroot/slime/swank-clisp.lisp 2008/09/12 12:27:38 1.75
@@ -330,7 +330,8 @@
(defimplementation compute-backtrace (start end)
(let* ((bt *sldb-backtrace*)
(len (length bt)))
- (subseq bt start (min (or end len) len))))
+ (loop for f in (subseq bt start (min (or end len) len))
+ collect (make-swank-frame :%frame f :restartable :unknown))))
;;; CLISP's REPL sets up an ABORT restart that kills SWANK. Here we
;;; can omit that restart so that users don't select it by mistake.
@@ -339,9 +340,9 @@
;; list, hopefully that's our unwanted ABORT restart.
(butlast (compute-restarts condition)))
-(defimplementation print-frame (frame stream)
- (let ((str (frame-to-string frame)))
- ;; (format stream "~A " (frame-string-type str))
+(defimplementation print-swank-frame (swank-frame stream)
+ (let* ((frame (swank-frame.%frame swank-frame))
+ (str (frame-to-string frame)))
(write-string (extract-frame-line str)
stream)))
--- /project/slime/cvsroot/slime/swank-backend.lisp 2008/09/09 23:29:44 1.150
+++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/09/12 12:27:38 1.151
@@ -20,6 +20,9 @@
#:condition
#:severity
#:with-compilation-hooks
+ #:swank-frame
+ #:swank-frame-p
+ #:swank-frame.restartable
#:location
#:location-p
#:location-buffer
@@ -641,21 +644,22 @@
;;; The following functions in this section are supposed to be called
;;; within the dynamic contour of CALL-WITH-DEBUGGING-ENVIRONMENT only.
+(defstruct (swank-frame (:conc-name swank-frame.))
+ %frame
+ restartable)
+
(definterface compute-backtrace (start end)
"Returns a backtrace of the condition currently being debugged,
-that is an ordered list consisting of frames. (What constitutes a
-frame is implementation dependent, but PRINT-FRAME must be defined on
-it.)
-
-``Ordered list'' means that the i-th. frame is associated to the
-frame-number i.
+that is an ordered list consisting of swank-frames. ``Ordered list''
+means that an integer I can be mapped back to the i-th frame of this
+backtrace.
START and END are zero-based indices constraining the number of frames
-returned. Frame zero is defined as the frame which invoked the
-debugger. If END is nil, return the frames from START to the end of
+returned. Frame zero is defined as the frame which invoked the
+debugger. If END is nil, return the frames from START to the end of
the stack.")
-(definterface print-frame (frame stream)
+(definterface print-swank-frame (frame stream)
"Print frame to stream.")
(definterface frame-source-location-for-emacs (frame-number)
--- /project/slime/cvsroot/slime/swank-allegro.lisp 2008/09/11 12:27:38 1.112
+++ /project/slime/cvsroot/slime/swank-allegro.lisp 2008/09/12 12:27:38 1.113
@@ -163,11 +163,10 @@
(let ((end (or end most-positive-fixnum)))
(loop for f = (nth-frame start) then (next-frame f)
for i from start below end
- while f
- collect f)))
+ while f collect (make-swank-frame :%frame f :restartable :unknown))))
-(defimplementation print-frame (frame stream)
- (debugger:output-frame stream frame :moderate))
+(defimplementation print-swank-frame (frame stream)
+ (debugger:output-frame stream (swank-frame.%frame frame) :moderate))
(defimplementation frame-locals (index)
(let ((frame (nth-frame index)))
--- /project/slime/cvsroot/slime/swank-abcl.lisp 2008/08/31 11:58:01 1.53
+++ /project/slime/cvsroot/slime/swank-abcl.lisp 2008/09/12 12:27:38 1.54
@@ -252,11 +252,12 @@
(defimplementation compute-backtrace (start end)
(let ((end (or end most-positive-fixnum)))
- (subseq (backtrace-as-list-ignoring-swank-calls) start end)))
+ (loop for f in (subseq (backtrace-as-list-ignoring-swank-calls) start end)
+ collect (make-swank-frame :%frame f :restartable :unknown))))
-(defimplementation print-frame (frame stream)
+(defimplementation print-swank-frame (frame stream)
(write-string (string-trim '(#\space #\newline)
- (prin1-to-string frame))
+ (prin1-to-string (swank-frame.%frame frame)))
stream))
(defimplementation frame-locals (index)
--- /project/slime/cvsroot/slime/slime.el 2008/09/10 23:18:35 1.1011
+++ /project/slime/cvsroot/slime/slime.el 2008/09/12 12:27:38 1.1012
@@ -323,6 +323,10 @@
(restart-number "restart numbers (correspond to keystrokes to invoke)"
'(:bold t))
(frame-line "function names and arguments in the backtrace")
+ (restartable-frame-line
+ "frames which are surely restartable")
+ (non-restartable-frame-line
+ "frames which are surely not restartable")
(detailed-frame-line
"function names and arguments in a detailed (expanded) frame")
(local-name "local variable names")
@@ -6750,7 +6754,7 @@
"Setup a new SLDB buffer.
CONDITION is a string describing the condition to debug.
RESTARTS is a list of strings (NAME DESCRIPTION) for each available restart.
-FRAMES is a list (NUMBER DESCRIPTION) describing the initial
+FRAMES is a list (NUMBER DESCRIPTION &optional PLIST) describing the initial
portion of the backtrace. Frames are numbered from 0.
CONTS is a list of pending Emacs continuations."
(with-current-buffer (sldb-get-buffer thread)
@@ -6856,14 +6860,22 @@
(in-sldb-face restart string))
(insert "\n")))
+(defun sldb-frame.string (frame)
+ (destructuring-bind (_ str &optional _) frame str))
+
+(defun sldb-frame.number (frame)
+ (destructuring-bind (n _ &optional _) frame n))
+
+(defun sldb-frame.plist (frame)
+ (destructuring-bind (_ _ &optional plist) frame plist))
+
(defun sldb-prune-initial-frames (frames)
"Return the prefix of FRAMES to initially present to the user.
Regexp heuristics are used to avoid showing SWANK-internal frames."
(let* ((case-fold-search t)
(rx "^\\([() ]\\|lambda\\)*swank\\>"))
(or (loop for frame in frames
- for (_ string) = frame
- until (string-match rx string)
+ until (string-match rx (sldb-frame.string frame))
collect frame)
frames)))
@@ -6872,29 +6884,39 @@
If MORE is non-nil, more frames are on the Lisp stack."
(mapc #'sldb-insert-frame frames)
(when more
- (destructuring-bind ((num _)) (last frames)
- (slime-insert-propertized
- `(, at nil sldb-default-action sldb-fetch-more-frames
- sldb-previous-frame-number ,num
- point-entered sldb-fetch-more-frames
- start-open t
- face sldb-section-face
- mouse-face highlight)
- " --more--")
- (insert "\n"))))
+ (slime-insert-propertized
+ `(, at nil sldb-default-action sldb-fetch-more-frames
+ sldb-previous-frame-number ,(sldb-frame.number (first (last frames)))
+ point-entered sldb-fetch-more-frames
+ start-open t
+ face sldb-section-face
+ mouse-face highlight)
+ " --more--")
+ (insert "\n")))
+
+(defun sldb-compute-frame-face (frame)
+ (let ((restartable (getf (sldb-frame.plist frame) :restartable)))
+ (cond ((eq restartable 't)
+ 'sldb-restartable-frame-line-face)
+ ((eq restartable :unknown)
+ 'sldb-frame-line-face)
+ ((eq restartable 'nil)
+ 'sldb-non-restartable-frame-line-face)
+ (t (error "fall through")))))
(defun sldb-insert-frame (frame &optional face)
"Insert FRAME with FACE at point.
-If FACE is nil use `sldb-frame-line-face'."
- (destructuring-bind (number string) frame
- (let ((props `(frame ,frame sldb-default-action sldb-toggle-details)))
- (slime-propertize-region props
- (slime-propertize-region '(mouse-face highlight)
- (insert " " (in-sldb-face frame-label (format "%2d:" number)) " ")
- (slime-insert-indented
- (slime-add-face (or face 'sldb-frame-line-face)
- string)))
- (insert "\n")))))
+If FACE is nil, `sldb-compute-frame-face' is used to determine the face."
+ (setq face (or face (sldb-compute-frame-face frame)))
+ (let ((number (sldb-frame.number frame))
+ (string (sldb-frame.string frame))
+ (props `(frame ,frame sldb-default-action sldb-toggle-details)))
+ (slime-propertize-region props
+ (slime-propertize-region '(mouse-face highlight)
+ (insert " " (in-sldb-face frame-label (format "%2d:" number)) " ")
+ (slime-insert-indented
+ (slime-add-face face string)))
+ (insert "\n"))))
(defun sldb-fetch-more-frames (&rest ignore)
"Fetch more backtrace frames.
@@ -7174,9 +7196,9 @@
(let* ((frame (get-text-property (point) 'frame))
(num (car frame))
(catches (sldb-catch-tags num))
- (locals (sldb-frame-locals num)))
+ (locals (sldb-frame-locals num))
(destructuring-bind (start end) (sldb-frame-region)
- (list start end frame locals catches))))
+ (list start end frame locals catches)))))
(defvar sldb-insert-frame-variable-value-function 'sldb-insert-frame-variable-value)
--- /project/slime/cvsroot/slime/ChangeLog 2008/09/11 12:32:01 1.1501
+++ /project/slime/cvsroot/slime/ChangeLog 2008/09/12 12:27:38 1.1502
@@ -1,3 +1,38 @@
+2008-09-12 Tobias C. Rittweiler <tcr at freebits.de>
+
+ New faces: `sldb-restartable-frame-line-face',
+ `sldb-non-restartable-frame-line-face'.
+
+ The former is the face for frames that are surely restartable, the
+ latter for frames that are surely not restartable. If
+ restartability of a frame cannot be reliably determined, the face
+ `sldb-frame-line-face' is used.
+
+ At the moment, determination of frame restartability is supported
+ by the SBCL backend only.
+
+ * slime.el (sldb-frame.string): New.
+ (sldb-frame.number): New.
+ (sldb-frame.plist): New.
+ (sldb-prune-initial-frames): Use them.
+ (sldb-insert-frames): Ditto.
+ (sldb-compute-frame-face): New.
+ (sldb-insert-frame): Use `sldb-compute-frame-face' to insert
+ frames with one of the faces described above.
+
+ * swank.lisp (defslimefun backtrace): Changed return value; each
+ frame is now accompanied with a PLIST which at the moment can
+ contain :RESTARTABLE NIL/T/:UNKNOWN depending on whether the frame
+ is restartable, or not.
+
+ * swank-backend.lisp (defstruct swank-frame): New structure.
+ (compute-backtrace): Is now supposed to return a list of SWANK-FRAMEs.
+ (print-frame): Renamed to PRINT-SWANK-FRAME.
+
+ * swank-sbcl.lisp, swank-cmucl.lisp, swank-lispworks.lisp,
+ * swank-allegro.lisp, swank-scl.lisp, swank-openmcl.lisp,
+ * swank-abcl.lisp, swank-clisp.lisp: Adapted to swank-backend changes.
+
2008-09-11 Helmut Eller <heller at common-lisp.net>
* doc/slime-refcard.tex: Fix typos.
More information about the slime-cvs
mailing list