[slime-cvs] CVS slime
heller
heller at common-lisp.net
Wed Jan 10 23:50:49 UTC 2007
Update of /project/slime/cvsroot/slime
In directory clnet:/tmp/cvs-serv27288
Modified Files:
slime.el
Log Message:
Some cleanups for the debugger code: add some outline
sections and docstrings.
(sldb-setup): Always display the beginning of the condition
text. Previously, we always showed the beginning of the backtrace.
(sldb-prune-initial-frames): Do what the docstring says. Reverted
to Luke's version.
(sldb-dispatch-extras): Fix typo.
(sldb-insert-restarts, sldb-insert-frames)
(sldb-insert-frame, sldb-fetch-more-frames)
(sldb-toggle-details, sldb-show-frame-details)
(sldb-insert-locals): Simplified.
(sldb-frame-details): New.
(slime-save-coordinates, slime-coordinates)
(slime-restore-coordinate, slime-count-lines): New macro and its
helpers.
(sldb-recenter-region): Renamed from slime-maybe-recenter-region.
(sldb-enable-styled-backtrace, sldb-show-catch-tags)
(sldb-highlight): Deleted. Seem to be obsolete.
(sldb-add-face): Removed, because it is now the same as
slime-add-face.
(sldb-help-summary): Deleted. The docstring for sldb-mode is
already pretty terse.
(define-sldb-face): Renamed from def-sldb-face.
--- /project/slime/cvsroot/slime/slime.el 2007/01/10 09:42:47 1.737
+++ /project/slime/cvsroot/slime/slime.el 2007/01/10 23:50:49 1.738
@@ -382,35 +382,23 @@
:prefix "sldb-"
:group 'slime)
-(defcustom sldb-enable-styled-backtrace t "Enable faces in slime backtrace"
- :type '(choice
- (const :tag "Enable" t)
- (const :tag "Disable" nil))
- :group 'slime-debugger)
-
-(defcustom sldb-show-catch-tags t "Show catch tags in frames"
- :type '(choice
- (const :tag "Show" t)
- (const :tag "Don't show" nil))
- :group 'slime-debugger)
-
-(defmacro def-sldb-faces (&rest faces)
+(defmacro define-sldb-faces (&rest faces)
"Define the set of SLDB faces.
Each face specifiation is (NAME DESCRIPTION &optional PROPERTIES).
NAME is a symbol; the face will be called sldb-NAME-face.
DESCRIPTION is a one-liner for the customization buffer.
PROPERTIES specifies any default face properties."
`(progn ,@(loop for face in faces
- collect `(def-sldb-face , at face))))
+ collect `(define-sldb-face , at face))))
-(defmacro def-sldb-face (name description &optional default)
+(defmacro define-sldb-face (name description &optional default)
(let ((facename (intern (format "sldb-%s-face" (symbol-name name)))))
`(defface ,facename
(list (list t ,default))
,(format "Face for %s." description)
:group 'slime-debugger)))
-(def-sldb-faces
+(define-sldb-faces
(topline "the top line describing the error")
(condition "the condition class")
(section "the labels of major sections in the debugger buffer")
@@ -996,7 +984,6 @@
[ "Next Frame" sldb-down t ]
[ "Previous Frame" sldb-up t ]
[ "Toggle Frame Details" sldb-toggle-details t ]
- [ "List Locals" sldb-list-locals ,C ]
[ "Next Frame (Details)" sldb-details-down t ]
[ "Previous Frame (Details)" sldb-details-up t ]
"--"
@@ -8034,46 +8021,46 @@
(defvar sldb-hook nil
"Hook run on entry to the debugger.")
-(defun slime-add-face (face string)
- (add-text-properties 0 (length string) (list 'face face) string)
- string)
-
-(defmacro in-sldb-face (name string)
- "Return STRING propertised with face sldb-NAME-face.
-If `sldb-enable-styled-backtrace' is nil, just return STRING."
- (let ((facename (intern (format "sldb-%s-face" (symbol-name name))))
- (var (gensym "string")))
- `(let ((,var ,string))
- (sldb-add-face ',facename ,var)
- ,var)))
-
;;;;; Local variables in the debugger buffer
-(make-variable-buffer-local
+(slime-make-variables-buffer-local
(defvar sldb-condition nil
- "List of (DESCRIPTION TYPE) strings describing the condition being debugged."))
+ "A list (DESCRIPTION TYPE) describing the condition being debugged.")
-(make-variable-buffer-local
(defvar sldb-saved-window-configuration nil
- "Window configuration before the debugger was initially entered."))
+ "Window configuration before the debugger was initially entered.")
-(make-variable-buffer-local
(defvar sldb-restarts nil
- "List of (NAME DESCRIPTION) for each available restart."))
+ "List of (NAME DESCRIPTION) for each available restart.")
-(make-variable-buffer-local
(defvar sldb-level nil
- "Current debug level (recursion depth) displayed in buffer."))
+ "Current debug level (recursion depth) displayed in buffer.")
-(make-variable-buffer-local
(defvar sldb-backtrace-start-marker nil
- "Marker placed at the beginning of the backtrace text."))
+ "Marker placed at the beginning of the backtrace text.")
-(make-variable-buffer-local
(defvar sldb-continuations nil
"List of ids for pending continuation."))
-
+
+;;;;; SLDB macros
+
+;; some macros that we need to define before the first use
+
+(defmacro in-sldb-face (name string)
+ "Return STRING propertised with face sldb-NAME-face."
+ (let ((facename (intern (format "sldb-%s-face" (symbol-name name))))
+ (var (gensym "string")))
+ `(let ((,var ,string))
+ (slime-add-face ',facename ,var)
+ ,var)))
+
+(put 'in-sldb-face 'lisp-indent-function 1)
+
+(defun slime-add-face (face string)
+ (add-text-properties 0 (length string) (list 'face face) string)
+ string)
+
;;;;; sldb-mode
@@ -8090,7 +8077,7 @@
table)
"Syntax table for SLDB mode.")
-(define-derived-mode sldb-mode fundamental-mode "sldb"
+(define-derived-mode sldb-mode fundamental-mode "sldb"
"Superior lisp debugger mode. In addition to ordinary SLIME commands,
the following are available:\\<sldb-mode-map>
@@ -8101,7 +8088,6 @@
\\[sldb-pprint-eval-in-frame] - eval in frame, pretty-print result
\\[sldb-disassemble] - disassemble
\\[sldb-inspect-in-frame] - inspect
- \\[sldb-list-locals] - list locals
Commands to invoke restarts:
\\[sldb-quit] - quit
@@ -8128,37 +8114,13 @@
(erase-buffer)
(set-syntax-table sldb-mode-syntax-table)
(slime-set-truncate-lines)
- (when slime-use-autodoc-mode
+ (when slime-use-autodoc-mode
(slime-autodoc-mode 1))
;; Make original slime-connection "sticky" for SLDB commands in this buffer
(setq slime-buffer-connection (slime-connection))
(add-local-hook 'kill-buffer-hook 'sldb-delete-overlays))
-(defun sldb-help-summary ()
- "Show summary of important sldb commands"
- (interactive)
- (message
- (mapconcat
- #'(lambda (list)
- (destructuring-bind (cmd letter name name-with-letter) list
- (let ((where-is (where-is-internal cmd sldb-mode-map)))
- (if (or (member (vector (intern letter)) where-is)
- (member (vector (string-to-char letter)) where-is))
- name-with-letter
- (substitute-command-keys
- (format "\\<sldb-mode-map>\\[%s] %s" cmd name))))))
- '((sldb-down "n" "next" "n-ext")
- (sldb-up "p" "prev" "p-rev")
- (sldb-toggle-details "t" "toggle details" "t-oggle details")
- (sldb-eval-in-frame "e" "eval" "e-val")
- (sldb-continue "c" "continue" "c-ontinue")
- (sldb-abort "a" "abort" "a-bort")
- (sldb-show-source "v" "view source" "v-iew source")
- (describe-mode "h" "help" "h-elp"))
- ", ")))
-
-(slime-define-keys sldb-mode-map
- ("?" 'sldb-help-summary)
+(slime-define-keys sldb-mode-map
("h" 'describe-mode)
("v" 'sldb-show-source)
((kbd "RET") 'sldb-default-action)
@@ -8212,7 +8174,7 @@
(defmacro define-sldb-invoke-restart-keys (from to)
`(progn
,@(loop for n from from to to
- collect `(define-sldb-invoke-restart-key ,n
+ collect `(define-sldb-invoke-restart-key ,n
,(number-to-string n)))))
(define-sldb-invoke-restart-keys 0 9)
@@ -8220,9 +8182,6 @@
;;;;; SLDB buffer creation & update
-(defvar sldb-overlays '()
- "List of overlays created in source code buffers to highlight expressions.")
-
(defun sldb-buffers ()
"Return a list of all sldb buffers."
(slime-filter-buffers (lambda () (eq major-mode 'sldb-mode))))
@@ -8236,7 +8195,7 @@
(sldb-buffers))))
(defun sldb-get-default-buffer ()
- "Get a sldb buffer.
+ "Get a sldb buffer.
The buffer is chosen more or less randomly."
(car (sldb-buffers)))
@@ -8246,7 +8205,7 @@
(or (sldb-find-buffer thread connection)
(let ((name (format "*sldb %s/%s*" (slime-connection-name) thread)))
(with-current-buffer (generate-new-buffer name)
- (setq slime-buffer-connection connection
+ (setq slime-buffer-connection connection
slime-current-thread thread)
(current-buffer))))))
@@ -8281,11 +8240,13 @@
(sldb-insert-condition condition)
(insert "\n\n" (in-sldb-face section "Restarts:") "\n")
(sldb-insert-restarts restarts)
- (insert "\n\n" (in-sldb-face section "Backtrace:") "\n")
+ (insert "\n" (in-sldb-face section "Backtrace:") "\n")
(setq sldb-backtrace-start-marker (point-marker))
- (sldb-insert-frames (sldb-prune-initial-frames frames) nil)
+ (save-excursion
+ (sldb-insert-frames (sldb-prune-initial-frames frames) t))
(run-hooks 'sldb-hook)
(pop-to-buffer (current-buffer))
+ (sldb-recenter-region (point-min) (point))
(setq buffer-read-only t)
(when (and slime-stack-eval-tags
;; (y-or-n-p "Enter recursive edit? ")
@@ -8294,6 +8255,8 @@
(recursive-edit)))))
(defun sldb-activate (thread level)
+ "Display the debugger buffer for THREAD.
+If LEVEL isn't the same as in the buffer, reinitialize the buffer."
(unless (let ((b (sldb-find-buffer thread)))
(and b (with-current-buffer b (equal sldb-level level))))
(slime-rex (thread level)
@@ -8303,6 +8266,7 @@
(apply #'sldb-setup thread level result)))))
(defun sldb-exit (thread level &optional stepping)
+ "Exit from the debug level LEVEL."
(when-let (sldb (sldb-find-buffer thread))
(with-current-buffer sldb
(unless stepping
@@ -8314,13 +8278,17 @@
(kill-buffer sldb))))
(defun sldb-insert-condition (condition)
+ "Insert the text for CONDITION.
+CONDITION should be a list (MESSAGE TYPE REFERENCES EXTRAS).
+REFERENCES a references to additional documentation.
+EXTRAS is currently used for the stepper."
(destructuring-bind (message type references extras) condition
(when (> (length message) 70)
(add-text-properties 0 (length message) (list 'help-echo message)
message))
(slime-insert-propertized '(sldb-default-action sldb-inspect-condition)
(in-sldb-face topline message)
- "\n"
+ "\n"
(in-sldb-face condition type))
(when references
(insert "See also:\n")
@@ -8329,188 +8297,90 @@
(insert "\n"))
(sldb-dispatch-extras extras)))
-(defun sldb-insert-references (references)
- "Insert documentation references from a condition.
-See SWANK-BACKEND:CONDITION-REFERENCES for the datatype."
- (loop for ref in references do
- (destructuring-bind (where type what) ref
- (insert (sldb-format-reference-source where) ", ")
- (slime-insert-propertized (sldb-reference-properties ref)
- (sldb-format-reference-node what))
- (insert (format " [%s]" (slime-cl-symbol-name type)) "\n"))))
-
-(defun sldb-reference-properties (reference)
- "Return the properties for a reference.
-Only add clickability to properties we actually know how to lookup."
- (destructuring-bind (where type what) reference
- (if (or (and (eq where :sbcl) (eq type :node))
- (and (eq where :ansi-cl)
- (symbolp type)
- (member (slime-cl-symbol-name type)
- '("function" "special-operator" "macro"
- "section" "glossary" "issue"))))
- `(sldb-default-action
- sldb-lookup-reference
- ;; FIXME: this is a hack! slime-compiler-notes and sldb are a
- ;; little too intimately entwined.
- slime-compiler-notes-default-action sldb-lookup-reference
- sldb-reference ,reference
- face sldb-reference-face
- mouse-face highlight))))
-
-(defun sldb-format-reference-source (where)
- (case where
- (:amop "The Art of the Metaobject Protocol")
- (:ansi-cl "Common Lisp Hyperspec")
- (:sbcl "SBCL Manual")
- (t (format "%S" where))))
-
-(defun sldb-format-reference-node (what)
- (if (symbolp what)
- (upcase (slime-cl-symbol-name what))
- (if (listp what)
- (mapconcat (lambda (x) (format "%S" x)) what ".")
- what)))
-
-(defun sldb-lookup-reference ()
- "Browse the documentation reference at point."
- (destructuring-bind (where type what)
- (get-text-property (point) 'sldb-reference)
- (case where
- (:ansi-cl
- (case type
- (:section
- (browse-url (funcall common-lisp-hyperspec-section-fun what)))
- (:glossary
- (browse-url (funcall common-lisp-glossary-fun what)))
- (:issue
- (browse-url (funcall 'common-lisp-issuex what)))
- (t
- (hyperspec-lookup (if (symbolp what)
- (slime-cl-symbol-name what)
- what)))))
- (t
- (let ((url (format "%s%s.html" slime-sbcl-manual-root
- (subst-char-in-string ?\ ?\- what))))
- (browse-url url))))))
-
(defun sldb-dispatch-extras (extras)
+ ;; this is (mis-)used for the stepper
(dolist (extra extras)
(destructure-case extra
- ((:short-frame-source n)
+ ((:show-frame-source n)
(sldb-show-frame-source n)))))
-
+
(defun sldb-insert-restarts (restarts)
+ "Insert RESTARTS and add the needed text props
+RESTARTS should be alist ((NAME DESCRIPTION) ...)."
(loop for (name string) in restarts
- for number from 0
- for first-time-p = t then nil
- do (progn
- (unless first-time-p
- (newline))
- (slime-insert-propertized
- `(restart-number ,number
- sldb-default-action sldb-invoke-restart
- mouse-face highlight)
- " "
- (in-sldb-face restart-number (number-to-string number))
- ": [" (in-sldb-face restart-type name) "] "
- (in-sldb-face restart string)))))
-
-(defun sldb-add-face (face string)
- (if sldb-enable-styled-backtrace
- (add-text-properties 0 (length string) (list 'face face) string)
- string))
+ for number from 0 do
+ (insert " ")
+ (slime-insert-propertized
+ `(, at nil restart-number ,number
+ sldb-default-action sldb-invoke-restart
+ mouse-face highlight)
+ (in-sldb-face restart-number (number-to-string number))
+ ": [" (in-sldb-face restart-type name) "] "
+ (in-sldb-face restart string))
+ (insert "\n")))
(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."
- (or (loop with winner = -1
- for frame in frames
- for idx from 0
- for (number string) = frame
- while (string-match "^\\((\\|LAMBDA \\|lambda \\)*\\(SWANK\\|swank\\)\\>" string)
- do (setf winner idx)
- finally (return (subseq frames (1+ winner))))
- frames))
+ (let* ((case-fold-search t)
+ (rx "^\\([() ]\\|lambda\\)*swank\\>"))
+ (or (loop for frame in frames
+ for (_ string) = frame
+ until (string-match rx string)
+ collect frame)
+ frames)))
-(defun sldb-insert-frame (frame &optional detailedp)
+(defun sldb-insert-frames (frames more)
[779 lines skipped]
More information about the slime-cvs
mailing list