[slime-cvs] CVS update: slime/slime.el
Luke Gorrie
lgorrie at common-lisp.net
Sun Jan 25 20:51:28 UTC 2004
Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv28793
Modified Files:
Tag: stateless-emacs
slime.el
Log Message:
Major restructuring.
Deleted the Emacs state machine. Emacs is now essentially stateless
and just does what Lisp tells it to.
Date: Sun Jan 25 15:51:28 2004
Author: lgorrie
Index: slime/slime.el
diff -u slime/slime.el:1.197 slime/slime.el:1.197.2.1
--- slime/slime.el:1.197 Fri Jan 23 09:17:57 2004
+++ slime/slime.el Sun Jan 25 15:51:28 2004
@@ -572,14 +572,14 @@
(add-hook 'slime-mode-hook 'slime-setup-command-hooks)
(add-hook 'slime-mode-hook 'slime-buffer-package)
-(add-hook 'inferior-lisp-mode-hook
- (lambda ()
- (add-to-list
- (make-local-variable 'comint-output-filter-functions)
- (lambda (string)
- (unless (get-buffer-window (current-buffer) t)
- (display-buffer (current-buffer) t))
- (comint-postoutput-scroll-to-bottom string)))))
+;; (add-hook 'inferior-lisp-mode-hook
+;; (lambda ()
+;; (add-to-list
+;; (make-local-variable 'comint-output-filter-functions)
+;; (lambda (string)
+;; (unless (get-buffer-window (current-buffer) t)
+;; (display-buffer (current-buffer) t))
+;; (comint-postoutput-scroll-to-bottom string)))))
;;; Common utility functions and macros
@@ -1036,15 +1036,6 @@
(error "Protocol mismatch: Lisp: %s ELisp: %s"
lisp-version (slime-changelog-date))))
-(defun slime-aux-connect (host port)
- "Open an auxiliary connection to HOST:PORT.
-
-Auxiliary connections are temporary connections to specific
-threads for the purposes of e.g. debugging."
- (message "Opening auxiliary connection to %S:%S.." host port)
- (slime-init-connection (slime-net-connect "localhost" port) t)
- (message "Opening auxiliary connection to %S:%S.. done" host port))
-
(defun slime-disconnect ()
"Disconnect all connections."
(interactive)
@@ -1142,7 +1133,7 @@
(while (slime-net-have-input-p)
(let ((event (condition-case error
(slime-net-read)
- (error (slime-state/event-panic error proc)))))
+ (error "PANIC!"))))
(save-current-buffer (slime-dispatch-event event proc))))))
(when (some (lambda (p)
(with-current-buffer (process-buffer p)
@@ -1310,154 +1301,57 @@
(slime-def-connection-var slime-lisp-implementation-type nil
"The implementation type of the Lisp process.")
-(slime-def-connection-var sldb-level 0
- "Lisp's recursion depth in the SLDB loop.")
-
(put 'slime-def-connection-var 'lisp-indent-function 2)
-;;; Evaluation mechanics
-
-;; The SLIME protocol is implemented with a small state machine. That
-;; means the program uses "state" data structures to remember where
-;; it's up to -- whether it's idle, or waiting for an evaluation
-;; request from Lisp, whether it's debugging, and so on.
-;;
-;; The state machine has a stack for putting states that are only
-;; partially complete, i.e. it is a "push-down automaton" like they
-;; use in parsers. This design works well because the SLIME protocol
-;; can be described as a context-free grammar, loosely:
-;;
-;; CONVERSATION ::= <EXCHANGE>*
-;; EXCHANGE ::= request reply
-;; or request <DEBUG> reply
-;; DEBUG ::= enter-debugger <CONVERSATION> debug-return
-;;
-;; Or, in plain english, in the simplest case Emacs asks Lisp to
-;; evaluate something and Lisp sends the result. But it's also
-;; possible that Lisp signals a condition and enters the debugger
-;; while computing the reply. In that case both sides enter a
-;; debugging state, and can have arbitrary nested conversations until
-;; a restart makes the debugger return.
-;;
-;; The state machine's stack represents the interesting parts of the
-;; remote Lisp stack. Each Emacs state on the stack corresponds to a
-;; particular Lisp stack frame. When that frame returns it sends a
-;; message to Emacs delivering a result, which Emacs delivers to the
-;; state and pops its stack. So the stacks are kept synchronized.
-;;
-;; The format of events is lists whose CAR is a symbol identifying the
-;; type of event and whose CDR contains any extra arguments. We treat
-;; events created by Emacs the same as events sent by Lisp, but by
-;; convention use "emacs-" as a prefix on the names of events
-;; originating locally in Emacs.
-;;
-;; There are also certain "out of band" messages which are handled by
-;; a special function instead of reaching the state machine.
-
-
-;;;;; Basic state machine framework
-
-(make-variable-buffer-local
- (defvar slime-state-stack '()
- "Stack of machine states. The state at the top is the current state."))
-
-(defun slime-push-state (state)
- "Push into a new state, saving the current state on the stack.
-This may be called by a state machine to cause a state change."
- (slime-with-connection-buffer ()
- (push state slime-state-stack))
- (slime-activate-state))
-(defun slime-pop-state ()
- "Pop back to the previous state from the stack.
-This may be called by a state machine to finish its current state."
- (slime-with-connection-buffer ()
- (pop slime-state-stack))
- (slime-activate-state))
+;;; ***NEW!***
-(defun slime-current-state ()
- "The current state of the current connection."
- (slime-with-connection-buffer ()
- (car slime-state-stack)))
-
-(defun slime-state-stack ()
- "Return the state stack for the current connection."
- (slime-with-connection-buffer ()
- slime-state-stack))
+(defvar slime-rex-continuations '()
+ "List of (ID . FUNCTION) continuations waiting for RPC results.")
-(defun slime-init-connection (proc &optional auxp)
- "Initialize the stack machine."
- (let ((slime-dispatching-connection proc))
- (slime-init-connection-state proc auxp)
- (unless auxp (slime-select-connection proc))
- (sldb-cleanup)
- proc))
-
-(defun slime-init-connection-state (proc auxp)
- ;; To make life simpler for the user: if this is the only open
- ;; connection then reset the connection counter.
- (when (equal slime-net-processes (list proc))
- (setq slime-connection-counter 0))
- (slime-with-connection-buffer ()
- (setq slime-state-stack (list (slime-idle-state)))
- (setq slime-connection-number (incf slime-connection-counter)))
- (unless auxp
- (setf (slime-pid) (slime-eval '(swank:getpid)))
- (setf (slime-lisp-implementation-type)
- (slime-eval '(cl:lisp-implementation-type)))
- (when-let (repl-buffer (slime-repl-buffer))
- ;; REPL buffer already exists - update its local
- ;; `slime-connection' binding.
- (with-current-buffer repl-buffer
- (setq slime-buffer-connection proc)))
- (when slime-global-debugger-hook
- (slime-eval '(swank:install-global-debugger-hook) "COMMON-LISP-USER")))
- (setf (sldb-level) 0))
-
-(defun slime-activate-state ()
- "Activate the current state.
-This delivers an (activate) event to the state function, and updates
-the state name for the modeline."
- (let ((state (slime-current-state)))
- (when (eq (slime-connection) slime-default-connection)
- (slime-update-state-name state))
- (slime-dispatch-event '(activate))))
-
-(defun slime-update-state-name (state)
- (slime-with-connection-buffer (slime-default-connection)
- (setq slime-state-name
- (ecase (slime-state-name state)
- (slime-idle-state "")
- (slime-evaluating-state "[eval...]")
- (slime-debugging-state "[debug]")
- (slime-read-string-state "[read]")))
- (force-mode-line-update)))
-
-;; state datastructure
-(defun slime-make-state (name function)
- "Make a state object called NAME that handles events with FUNCTION."
- (list 'slime-state name function))
-
-(defun slime-state-name (state)
- "Return the name of STATE."
- (second state))
-
-(defun slime-state-function (state)
- "Return STATE's event-handler function."
- (third state))
+(defvar slime-continuation-counter 0)
-
-;;;;;;; Event dispatching.
+(defvar slime-read-string-tag nil) ; FIXME: move into repl
(defun slime-dispatch-event (event &optional process)
- "Dispatch an event to the current state.
-Certain \"out of band\" events are handled specially instead of going
-into the state machine."
(let ((slime-dispatching-connection (or process (slime-connection))))
(slime-log-event event)
(unless (slime-handle-oob event)
- (funcall (slime-state-function (slime-current-state)) event))))
+ (destructure-case event
+ ((:emacs-rex form-string package continuation)
+ (let ((id (incf slime-continuation-counter)))
+ (push (cons id continuation) slime-rex-continuations)
+ ;; (slime-send `(:rex ,form-string ,package)))
+ (slime-send `(swank:eval-string ,form-string ,package ,id))))
+ ((:return value id)
+ (when-let (rec (find id slime-rex-continuations :key #'car))
+ (setq slime-rex-continuations (remove rec slime-rex-continuations))
+ (let ((continuation (cdr rec)))
+ (funcall continuation value))))
+ ((:emacs-interrupt)
+ (slime-send-sigint))
+ ((:read-string tag)
+ (setq slime-read-string-tag tag))
+ ((:read-aborted)
+ (setq slime-read-string-tag nil))
+ ((:emacs-return-string string)
+ (slime-send `(swank:take-input ,slime-read-string-tag ,string))
+ (setq slime-read-string-tag nil))
+ ((:debug level condition restarts frames)
+ (sldb-setup level condition restarts frames))
+ ((:debug-return level)
+ (sldb-exit level))))))
+
+(defun sldb-exit (level)
+ (when-let (sldb (get-sldb-buffer))
+ (with-current-buffer sldb
+ (set-window-configuration sldb-saved-window-configuration)
+ (let ((inhibit-read-only t))
+ (erase-buffer))
+ (setq sldb-level nil))
+ (when (= level 1)
+ (kill-buffer sldb))))
(defun slime-handle-oob (event)
"Handle out-of-band events.
@@ -1475,9 +1369,6 @@
((:open-dedicated-output-stream port)
(slime-open-stream-to-lisp port)
t)
- ((:open-aux-connection port)
- (slime-aux-connect "localhost" port)
- t)
((:check-protocol-version version)
(slime-check-protocol-version version)
t)
@@ -1494,72 +1385,50 @@
(message "%s" message))
(t nil)))
-(defun slime-call/error->message (fun &rest args)
- "Call FUN with ARGS. Trap and `message' errors."
- (condition-case err
- (apply fun args)
- (error (message "Error: %s" (cadr err)))))
+(defun slime-nyi ()
+ (error "Not yet implemented!"))
+
+;;;; Connection initialization
+
+(defun slime-init-connection (proc)
+ "Initialize the stack machine."
+ (setq slime-rex-continuations '())
+ (let ((slime-dispatching-connection proc))
+ (slime-init-connection-state proc)
+ (slime-select-connection proc)
+ proc))
-(defun slime-state/event-panic (event process)
- "Signal the error that we received EVENT in a state that can't handle it.
-When this happens it is due to a bug in SLIME.
-
-The connection to Lisp is dropped, the user is presented with some
-debugging information, and an error is signaled."
- (with-output-to-temp-buffer "*SLIME bug*"
- (princ (format "\
-You have encountered a bug in SLIME.
-
-The communication state machine received an event that was illegal for
-its current state, which means that the communication between Emacs
-and Lisp has lost synchronization. The connection to Lisp has
-therefore been closed.
-
-You can open a fresh connection with `M-x slime'.
-
-Please report this problem to your friendly neighbourhood SLIME
-hacker, or the mailing list at slime-devel at common-lisp.net. Please
-include in your report:
-
- A description of what you were doing when the problem occured,
- the version of SLIME, Emacs, and Lisp that you are using,
- the Lisp backtrace, if one was printed,
- and the information printed below:
-
-The event was:
-%s
-
-The state stack was:
-%s
-
-The content of the *slime-events* buffer:
-%s
-
-The content of the *cl-connection* buffer:
-%s
-
-"
- (pp-to-string event)
- (pp-to-string (mapcar 'slime-state-name (slime-state-stack)))
- (cond ((get-buffer "*slime-events*")
- (with-current-buffer "*slime-events*"
- (buffer-string)))
- (t "<no *slime-event* buffer>"))
- (cond ((process-buffer process)
- (with-current-buffer
- (process-buffer process)
- (buffer-string)))
- (t "<no *cl-connection*>"))
- )))
- (slime-net-close process)
- (display-buffer "*SLIME bug*")
- (delete-other-windows (get-buffer-window "*SLIME bug*"))
- (error "The SLIME protocol reached an inconsistent state."))
+(defun slime-init-connection-state (proc)
+ ;; To make life simpler for the user: if this is the only open
+ ;; connection then reset the connection counter.
+ (when (equal slime-net-processes (list proc))
+ (setq slime-connection-counter 0))
+ (slime-with-connection-buffer ()
+ (setq slime-connection-number (incf slime-connection-counter)))
+ (setf (slime-pid) (slime-eval '(swank:getpid)))
+ (setf (slime-lisp-implementation-type)
+ (slime-eval '(cl:lisp-implementation-type)))
+ (when-let (repl-buffer (slime-repl-buffer))
+ ;; REPL buffer already exists - update its local
+ ;; `slime-connection' binding.
+ (with-current-buffer repl-buffer
+ (setq slime-buffer-connection proc)))
+ (when slime-global-debugger-hook
+ (slime-eval '(swank:install-global-debugger-hook) "COMMON-LISP-USER")))
+(defun slime-busy-p ()
+ nil)
+
+(defun slime-idle-p ()
+ t)
+
+(defun slime-reading-p ()
+ nil)
+
+
(defvar slime-log-events t
"*Log protocol events to the *slime-events* buffer.")
-
;;;;;;; Event logging to *slime-events*
(defun slime-log-event (event)
(when slime-log-events
@@ -1571,10 +1440,7 @@
(delete-region (point-min) (point)))
(goto-char (point-max))
(save-excursion
- (pp event (current-buffer))
- (when (equal event '(activate))
- (backward-char 1)
- (insert (format " ; %s" (slime-state-name (slime-current-state))))))
+ (pp event (current-buffer)))
(hs-hide-block-at-point)
(goto-char (point-max)))))
@@ -1589,125 +1455,6 @@
(current-buffer)))))
-;;;;; Upper layer macros for defining states
-
-(eval-when (compile eval)
- (defun slime-make-state-function (arglist clauses)
- "Build the function that implements a state.
-The state's variables are moved into lexical bindings."
- (let ((event-var (gensym "event-")))
- `(lexical-let ,(mapcar* #'list arglist arglist)
- (lambda (,event-var)
- (destructure-case ,event-var
- , at clauses
- ;; Every state can handle the event (activate). By default
- ;; it does nothing.
- ,@(if (member* '(activate) clauses :key #'car :test #'equal)
- '()
- '( ((activate) nil)) )
- (t
- ;; Illegal event for current state. This is a BUG!
- (slime-state/event-panic ,event-var
- (slime-connection)))))))))
-
-(defmacro slime-defstate (name variables doc &rest events)
- "Define a state called NAME and comprised of VARIABLES.
-DOC is a documentation string.
-EVENTS is a set of event-handler patterns for matching events with
-their actions. The pattern syntax is the same as `destructure-case'."
- `(defun ,name ,variables
- ,doc
- (slime-make-state ',name ,(slime-make-state-function variables events))))
-
-(put 'slime-defstate 'lisp-indent-function 2)
-
-
-;;;;; The SLIME state machine definition
-
-(slime-defstate slime-idle-state ()
- "Idle state. The user may make a request, or Lisp may invoke the debugger."
- ((activate)
- (assert (= (sldb-level) 0)))
- ((:debug level condition restarts frames)
- (slime-push-state
- (slime-debugging-state level condition restarts frames
- (current-window-configuration))))
- ((:emacs-rex form-string package-name continuation)
- (slime-push-evaluating-state form-string package-name continuation))
- ((:emacs-evaluate-oneway form-string package-name)
- (slime-output-oneway-evaluate-request form-string package-name)))
-
-(defvar slime-evaluating-state-activation-hook nil
- "Hook called when the evaluating state is actived.")
-
-(slime-defstate slime-evaluating-state (saved-id continuation)
- "Evaluting state.
-We have asked Lisp to evaluate a form, and when the result arrives we
-will pass it to CONTINUATION."
- ((activate)
- (run-hooks 'slime-evaluating-state-activation-hook))
- ((:return result id)
- (assert (= id saved-id) nil "Continuation mismatch: %s %s" id saved-id)
- (slime-pop-state)
- (funcall continuation result))
- ((:debug level condition restarts frames)
- (slime-push-state
- (slime-debugging-state level condition restarts frames
- (current-window-configuration))))
- ((:emacs-interrupt)
- (slime-send-sigint))
- ((:emacs-quit)
- ;; To discard the state would break our synchronization.
- ;; Instead, just cancel the continuation.
- (setq continuation (lambda (value) t)))
- ((:read-string tag)
- (slime-push-state (slime-read-string-state
- tag (if (eq (window-buffer) (slime-output-buffer))
- nil
- (current-window-configuration))))
- (slime-repl-read-string)))
-
-(slime-defstate slime-debugging-state (level condition restarts frames
- saved-window-configuration)
- "Debugging state.
-Lisp entered the debugger while handling one of our requests. This
-state interacts with it until it is coaxed into returning."
- ((activate)
- (let ((sldb-buffer (get-sldb-buffer)))
- (when (or (not sldb-buffer)
- (/= (sldb-level) level)
- (with-current-buffer sldb-buffer
- (/= level sldb-level-in-buffer)))
- (setf (sldb-level) level)
- (sldb-setup condition restarts frames))))
- ((:debug-return level)
- (assert (= level (sldb-level)))
- (sldb-cleanup)
- (decf (sldb-level))
- (set-window-configuration saved-window-configuration)
- (slime-pop-state))
- ((:emacs-rex form-string package-name continuation)
- (slime-push-evaluating-state form-string package-name continuation))
- ((:emacs-evaluate-oneway form-string package-name)
- (slime-output-oneway-evaluate-request form-string package-name)))
-
-(slime-defstate slime-read-string-state (tag window-configuration)
- "Reading state.
-Lisp waits for input from Emacs."
- ((:emacs-return-string code)
- (slime-net-send `(swank:take-input ,tag ,code) (slime-connection))
- (when window-configuration
- (set-window-configuration window-configuration))
- (slime-pop-state))
- ((:emacs-rex form-string package-name continuation)
- (slime-push-evaluating-state form-string package-name continuation))
- ((:emacs-evaluate-oneway form-string package-name)
- (slime-output-oneway-evaluate-request form-string package-name))
- ((:read-aborted)
- (slime-repl-abort-read)
- (slime-pop-state)))
-
-
;;;;; Utilities
(defun slime-output-oneway-evaluate-request (form-string package-name)
@@ -1730,15 +1477,6 @@
;;;;; Emacs Lisp programming interface
-(defvar slime-continuation-counter 0)
-
-(defun slime-push-evaluating-state (form-string package-name continuation)
- "Send a request for LISP to read and evaluate FORM-STRING in PACKAGE-NAME."
- (slime-push-state (slime-evaluating-state (incf slime-continuation-counter)
- continuation))
- (slime-send `(swank:eval-string ,form-string ,package-name
- ,slime-continuation-counter)))
-
(defmacro* slime-rex ((&rest saved-vars)
(sexp &optional (package 'slime-buffer-package))
&rest continuations)
@@ -1782,11 +1520,13 @@
"Evaluate EXPR on the superior Lisp and return the result."
(let* ((tag (gensym "slime-result-"))
(slime-stack-eval-tags (cons tag slime-stack-eval-tags)))
- (catch tag
- (slime-rex (tag)
+ (unwind-protect
+ (catch tag
+ (slime-rex (tag sexp)
(sexp package)
((:ok value)
- (assert (member tag slime-stack-eval-tags))
+ (unless (member tag slime-stack-eval-tags)
+ (error "tag = %S eval-tags = %S sexp = %S" tag slime-stack-eval-tags sexp))
(throw tag value))
((:abort)
(error "Lisp Evaluation aborted.")))
@@ -1794,11 +1534,12 @@
(inhibit-quit nil))
(while t
(accept-process-output nil 0 10000)
- (when (slime-debugging-p)
+ ;;(debug)
+ (when nil ;; (and (slime-debugging-p) nil) ;; FIXME
(recursive-edit)
;; If we get here, the user completed the recursive edit without
;; coaxing the debugger into returning. We abort.
- (error "Evaluation aborted.")))))))
+ (error "Evaluation aborted."))))))))
(defun slime-eval-async (sexp package cont)
"Evaluate EXPR on the superior Lisp and call CONT with the result."
@@ -1821,29 +1562,11 @@
(slime-net-send sexp (slime-connection)))
(defun slime-sync ()
- "Block until any asynchronous command has completed."
- (while (slime-busy-p)
- (accept-process-output (slime-connection))))
-
-(defun slime-busy-p ()
- "Return true if Lisp is busy processing a request."
- (eq (slime-state-name (slime-current-state)) 'slime-evaluating-state))
-
-(defun slime-evaluating-p ()
- "Return true if Lisp is evaluating a request for Emacs."
- (slime-busy-p))
-
-(defun slime-idle-p ()
- "Return true if Lisp is idle."
- (eq (slime-state-name (slime-current-state)) 'slime-idle-state))
-
-(defun slime-reading-p ()
- "Return true if Lisp waits for input from Emacs."
- (eq (slime-state-name (slime-current-state)) 'slime-read-string-state))
-
-(defun slime-debugging-p ()
- "Return true if Lisp is in the debugger."
- (eq (slime-state-name (slime-current-state)) 'slime-debugging-state))
+ "Block until the most recent request has finished."
+ (when slime-rex-continuations
+ (let ((tag (caar slime-rex-continuations)))
+ (loop while (find tag slime-rex-continuations :key #'car)
+ do (accept-process-output nil 0 100000)))))
(defun slime-ping ()
"Check that communication works."
@@ -2139,9 +1862,9 @@
(defun slime-repl-send-string (string)
(slime-repl-add-to-input-history string)
- (ecase (slime-state-name (slime-current-state))
- (slime-idle-state (slime-repl-eval-string string))
- (slime-read-string-state (slime-repl-return-string string))))
+ (if (null slime-read-string-tag)
+ (slime-repl-eval-string string)
+ (slime-repl-return-string string)))
(defun slime-repl-show-abort ()
(with-current-buffer (slime-output-buffer)
@@ -2268,7 +1991,7 @@
'(face slime-repl-input-face rear-nonsticky (face)))
(slime-mark-output-start)
(slime-mark-input-start)
- (slime-repl-send-string input)))
+ (slime-repl-send-string (concat input "\n"))))
(defun slime-repl-closing-return ()
"Evaluate the current input string after closing all open lists."
@@ -4018,9 +3741,7 @@
(defun slime-interrupt ()
(interactive)
- (if (slime-evaluating-p)
- (slime-dispatch-event '(:emacs-interrupt))
- (error "Not evaluating - nothing to interrupt.")))
+ (slime-dispatch-event '(:emacs-interrupt)))
(defun slime-quit ()
(interactive)
@@ -4094,10 +3815,14 @@
"List of (NAME DESCRIPTION) for each available restart."))
(make-variable-buffer-local
- (defvar sldb-level-in-buffer nil
+ (defvar sldb-level nil
"Current debug level (recursion depth) displayed in buffer."))
(make-variable-buffer-local
+ (defvar sldb-saved-window-configuration nil
+ "Window configuration before the debugger was initially entered."))
+
+(make-variable-buffer-local
(defvar sldb-backtrace-start-marker nil
"Marker placed at the beginning of the backtrace text."))
@@ -4110,8 +3835,6 @@
\\{sldb-mode-map}"
(erase-buffer)
(set-syntax-table lisp-mode-syntax-table)
- (setq sldb-level-in-buffer (sldb-level))
- (setq mode-name (format "sldb[%d]" (sldb-level)))
(slime-set-truncate-lines)
;; Make original slime-connection "sticky" for SLDB commands in this buffer
(setq slime-buffer-connection (slime-connection))
@@ -4183,26 +3906,31 @@
(in-sldb-face condition type)
"\n\n")))
-(defun sldb-setup (condition restarts frames)
+(defun sldb-setup (level condition restarts frames)
"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
portion of the backtrace. Frames are numbered from 0."
(with-current-buffer (get-sldb-buffer t)
- (setq buffer-read-only nil)
- (sldb-mode)
- (setq sldb-condition condition)
- (setq sldb-restarts restarts)
- (sldb-insert-condition condition)
- (insert (in-sldb-face section "Restarts:") "\n")
- (sldb-insert-restarts restarts)
- (insert "\n" (in-sldb-face section "Backtrace:") "\n")
- (setq sldb-backtrace-start-marker (point-marker))
- (sldb-insert-frames (sldb-prune-initial-frames frames) nil)
- (setq buffer-read-only t)
- (pop-to-buffer (current-buffer))
- (run-hooks 'sldb-hook)))
+ (unless (equal sldb-level level)
+ (setq buffer-read-only nil)
+ (sldb-mode)
+ (unless sldb-saved-window-configuration
+ (setq sldb-saved-window-configuration (current-window-configuration)))
+ (setq sldb-level level)
+ (setq mode-name (format "sldb[%d]" sldb-level))
+ (setq sldb-condition condition)
+ (setq sldb-restarts restarts)
+ (sldb-insert-condition condition)
+ (insert (in-sldb-face section "Restarts:") "\n")
+ (sldb-insert-restarts restarts)
+ (insert "\n" (in-sldb-face section "Backtrace:") "\n")
+ (setq sldb-backtrace-start-marker (point-marker))
+ (sldb-insert-frames (sldb-prune-initial-frames frames) nil)
+ (setq buffer-read-only t)
+ (pop-to-buffer (current-buffer))
+ (run-hooks 'sldb-hook))))
(defun sldb-insert-restarts (restarts)
(loop for (name string) in restarts
@@ -4498,14 +4226,6 @@
(interactive)
(slime-message "%S" (sldb-catch-tags (sldb-frame-number-at-point))))
-(defun sldb-cleanup ()
- (when-let (sldb-buffer (get-sldb-buffer))
- (if (> (sldb-level) 1)
- (with-current-buffer sldb-buffer
- (let ((inhibit-read-only t))
- (erase-buffer)))
- (kill-buffer sldb-buffer))))
-
(defun sldb-quit ()
(interactive)
@@ -4528,7 +4248,7 @@
(interactive)
(let ((restart (or number (sldb-restart-at-point))))
(slime-rex ()
- ((list 'swank:invoke-nth-restart-for-emacs (sldb-level) restart))
+ ((list 'swank:invoke-nth-restart-for-emacs sldb-level restart))
((:ok value) (message "Restart returned: %s" value))
((:abort)))))
@@ -5136,11 +4856,35 @@
(time-less-p end (current-time)))
do (accept-process-output nil 0 100000))))
-(defun slime-check-idle-state (&optional test-name)
- (slime-check ((or test-name "Automaton in idle state."))
- (slime-test-state-stack '(slime-idle-state))))
+(defun slime-check-top-level (&optional test-name)
+ (slime-check "At the top level (no debugging or pending RPCs)"
+ (slime-at-top-level-p)))
+
+(defun slime-at-top-level-p ()
+ (and (null (get-sldb-buffer))
+ (null slime-rex-continuations)))
+
+(defun slime-wait-condition (name predicate timeout)
+ (let ((end (time-add (current-time) (seconds-to-time timeout))))
+ (while (not (funcall predicate))
+ (cond ((time-less-p end (current-time))
+ (error "Timeout waiting for condition: %S" name))
+ (t
+ (accept-process-output nil 0 100000))))))
+
+(defun slime-sync-to-top-level (timeout)
+ (slime-wait-condition "top-level" #'slime-at-top-level-p timeout))
+
+(defun slime-check-sldb-level (expected)
+ (let ((sldb-level (when-let (sldb (get-sldb-buffer))
+ (with-current-buffer sldb
+ sldb-level))))
+ (slime-check ("SLDB level (%S) is %S" expected sldb-level)
+ (equal expected sldb-level))))
(defun slime-test-expect (name expected actual &optional test)
+ (when (stringp expected) (setq expected (substring-no-properties expected)))
+ (when (stringp actual) (setq actual (substring-no-properties actual)))
(slime-check ("%s:\nexpected: [%S]\n actual: [%S]" name expected actual)
(funcall (or test #'equal) expected actual)))
@@ -5200,8 +4944,10 @@
"(swank::compile-string-for-emacs string &key buffer position)")
("swank::connection.owner-id"
"(swank::connection.owner-id structure)")
- ("cl:class-name"
- "(cl:class-name class)"))
+ )
+;; Different arglists found in the wild.
+;; ("cl:class-name"
+;; "(cl:class-name structure)"))
(let ((arglist (slime-get-arglist function-name))) ;
(slime-test-expect "Argument list is as expected"
expected-arglist arglist)))
@@ -5231,6 +4977,7 @@
(insert program)
(slime-compile-defun)
(slime-sync)
+ (goto-char (point-max))
(slime-previous-note)
(slime-check error-location-correct
(equal (read (current-buffer))
@@ -5239,121 +4986,100 @@
(def-slime-test async-eval-debugging (depth)
"Test recursive debugging of asynchronous evaluation requests."
'((1) (2) (3))
- (slime-check-idle-state "Automaton initially in idle state.")
(lexical-let ((depth depth)
(debug-hook-max-depth 0))
(let ((debug-hook
(lambda ()
- (when (> (sldb-level) debug-hook-max-depth)
- (setq debug-hook-max-depth (sldb-level))
- (slime-check
- ("Automaton stack reflects debug level %S." (sldb-level))
- ;; Inspect the stack to ensure we are debugging at the
- ;; expected recursion depth.
- (let ((expected-stack '(slime-idle-state)))
- (dotimes (i (sldb-level))
- (push 'slime-evaluating-state expected-stack)
- (push 'slime-debugging-state expected-stack))
- (slime-test-state-stack expected-stack)))
- (if (= (sldb-level) depth)
+ (when (> sldb-level debug-hook-max-depth)
+ (setq debug-hook-max-depth sldb-level)
+ (if (= sldb-level depth)
;; We're at maximum recursion - time to unwind
(sldb-quit)
;; Going down - enter another recursive debug
;; Recursively debug.
- (slime-eval-async 'no-such-variable nil (lambda (_) nil))
- (slime-sync))))))
+ (slime-eval-async 'no-such-variable nil (lambda (_) nil)))))))
(let ((sldb-hook (cons debug-hook sldb-hook)))
(slime-eval-async 'no-such-variable nil (lambda (_) nil))
- (slime-sync)
- ;; Now the hook should have run once for each ,
+ (slime-sync-to-top-level 5)
+ (slime-check-top-level)
(slime-check ("Maximum depth reached (%S) is %S."
debug-hook-max-depth depth)
- (= debug-hook-max-depth depth))
- (slime-sync-state-stack '(slime-idle-state) 5)
- (slime-check-idle-state "Automaton is back in idle state.")))))
+ (= debug-hook-max-depth depth))))))
(def-slime-test loop-interrupt-quit
()
"Test interrupting a loop."
'(())
- (slime-check-idle-state "Automaton initially in idle state.")
+ (slime-check-top-level)
(slime-eval-async '(cl:loop) "CL-USER" (lambda (_) ))
(let ((sldb-hook
(lambda ()
(slime-check "First interrupt."
- (and (slime-test-state-stack '(slime-debugging-state
- slime-evaluating-state
- slime-idle-state))
- (get-sldb-buffer)))
+ (when-let (sldb (get-sldb-buffer))
+ (with-current-buffer sldb
+ (equal sldb-level 1))))
(sldb-quit))))
(accept-process-output nil 1)
(slime-check "In eval state."
- (slime-test-state-stack '(slime-evaluating-state slime-idle-state)))
+ (not (null slime-rex-continuations)))
(slime-interrupt)
- (slime-sync-state-stack '(slime-idle-state) 5)
- (slime-check-idle-state "Automaton is back in idle state.")))
+ (slime-sync-to-top-level 5)
+ (slime-check-top-level)))
+(defun sldb-level ()
+ (when-let (sldb (get-sldb-buffer))
+ (with-current-buffer sldb
+ sldb-level)))
+
(def-slime-test loop-interrupt-continue-interrupt-quit
()
"Test interrupting a previously interrupted but continued loop."
'(())
- (slime-check-idle-state "Automaton initially in idle state.")
+ (error "NYI")
+ (slime-check-top-level)
(slime-eval-async '(cl:loop) "CL-USER" (lambda (_) ))
- (let ((sldb-hook
+ (let ((done nil)
+ (sldb-hook
(lambda ()
- (slime-check "First interrupt."
- (and (slime-test-state-stack '(slime-debugging-state
- slime-evaluating-state
- slime-idle-state))
- (get-sldb-buffer)))
- (let ((slime-evaluating-state-activation-hook
- (lambda ()
- (when (slime-test-state-stack '(slime-evaluating-state
- slime-idle-state))
- (setq slime-evaluating-state-activation-hook nil)
- (slime-check "No sldb buffer."
- (not (get-sldb-buffer)))
- (let ((sldb-hook
- (lambda ()
- (slime-check "Second interrupt."
- (and (slime-test-state-stack
- '(slime-debugging-state
- slime-evaluating-state
- slime-idle-state))
- (get-sldb-buffer)))
- (sldb-quit))))
- (accept-process-output nil 1)
- (slime-check "In eval state."
- (slime-test-state-stack
- '(slime-evaluating-state slime-idle-state)))
- (slime-interrupt)
- (slime-sync-state-stack '(slime-idle-state) 5))))))
- (sldb-continue)
- (slime-sync-state-stack '(slime-idle-state) 5)))))
- (accept-process-output nil 1)
- (slime-check "In eval state."
- (slime-test-state-stack '(slime-evaluating-state slime-idle-state)))
+ (slime-check-sldb-level 1)
+ (setq sldb-hook
+ (lambda ()
+ (slime-check-sldb-level 1)
+ (setq done t)
+ (sldb-quit))))))
(slime-interrupt)
- (slime-sync-state-stack '(slime-idle-state) 5)
- (slime-check-idle-state "Automaton is back in idle state.")))
+ (debug nil 'interrupted)
+ (slime-wait-condition "debugging" (lambda () (integerp (sldb-level))) 5)
+ (debug nil 'debugging)
+ (sldb-continue)
+ (debug nil 'continued)
+ (slime-wait-condition "running" (lambda () (null (sldb-level))) 5)
+ (debug nil 'running)
+ (slime-interrupt)
+ (slime-sync-to-top-level 5)
+ (slime-check-top-level)
+ (slime-check "Debug hooks ran" done)))
(def-slime-test interactive-eval
()
"Test interactive eval and continuing from the debugger."
'(())
- (let ((sldb-hook (lambda () (sldb-continue))))
- (slime-interactive-eval
- "(progn(cerror \"foo\" \"restart\")(cerror \"bar\" \"restart\")(+ 1 2))")
- (slime-sync-state-stack '(slime-idle-state) 5)
- (slime-check-idle-state "Automaton is back in idle state.")
- (let ((message (current-message)))
- (slime-check "Minibuffer contains: \"=> 3\""
- (equal "=> 3" message)))))
+ (lexical-let ((done nil))
+ (let ((sldb-hook (lambda () (sldb-continue) (setq done t))))
+ (slime-interactive-eval
+ "(progn(cerror \"foo\" \"restart\")(cerror \"bar\" \"restart\")(+ 1 2))")
+ (while (not done) (accept-process-output))
+ (slime-sync-to-top-level 5)
+ (slime-check-top-level)
+ (let ((message (current-message)))
+ (slime-check "Minibuffer contains: \"=> 3\""
+ (equal "=> 3" message))))))
(def-slime-test interrupt-bubbling-idiot
()
"Test interrupting a loop that sends a lot of output to Emacs."
'(())
+ (error "NYI")
(slime-check-idle-state "Automaton initially in idle state.")
(slime-eval-async '(cl:loop :for i :from 0 :do (cl:progn (cl:print i)
(cl:force-output)))
@@ -5433,7 +5159,7 @@
(concat "SWANK> " input)
(buffer-string))
(call-interactively 'slime-repl-return)
- (slime-sync-state-stack '(slime-idle-state) 5)
+ (slime-sync-to-top-level 5)
(slime-test-expect "Buffer contains result"
result-contents (buffer-string))))
@@ -5450,9 +5176,9 @@
SWANK> ")
("(read)" "(+ 2 3
4)" "SWANK> (values (read))
-(+ 2 3
+\(+ 2 3
4)
-(+ 2 3 4)
+\(+ 2 3 4)
SWANK> ")
)
(with-current-buffer (slime-output-buffer)
@@ -5461,14 +5187,12 @@
(with-current-buffer (slime-output-buffer)
(insert (format "(values %s)" prompt))
(call-interactively 'slime-repl-return)
- (slime-sync-state-stack '(slime-read-string-state
- slime-evaluating-state
- slime-idle-state)
- 5)
+ (slime-wait-condition "reading" (lambda () slime-read-string-tag) 5)
(insert input)
(call-interactively 'slime-repl-return)
- (slime-sync-state-stack '(slime-idle-state) 5)
- (slime-check"Buffer contains result" result-contents (buffer-string))))
+ (slime-sync-to-top-level 5)
+ (slime-check "Buffer contains result"
+ (equal result-contents (buffer-string)))))
(def-slime-test interactive-eval-output
(input result-contents visiblep)
@@ -5483,7 +5207,7 @@
(kill-buffer (slime-output-buffer))
(with-current-buffer (slime-output-buffer)
(slime-interactive-eval input)
- (slime-sync-state-stack '(slime-idle-state) 5)
+ (slime-sync-to-top-level 5)
(slime-test-expect "Buffer contains result"
result-contents (buffer-string))
(slime-test-expect "Buffer visible?"
More information about the slime-cvs
mailing list