[slime-cvs] CVS slime
CVS User heller
heller at common-lisp.net
Wed Dec 31 11:25:03 UTC 2008
Update of /project/slime/cvsroot/slime
In directory cl-net:/tmp/cvs-serv19299
Modified Files:
ChangeLog slime.el swank-backend.lisp swank-lispworks.lisp
swank.lisp
Log Message:
* slime.el ([test] find-definition.2): Also fails for Lispworks.
([test] interrupt-at-toplevel, [test] interrupt-in-debugger): Those
don't work well if there's no REPL thread.
* swank-backend.lisp (wait-for-input, wait-for-one-stream): Don't
use PEEK-CHAR because we can't interrupt that cleanly.
* swank.lisp (simple-serve-requests): Run the REPL inside
WITH-CONNECTION.
* swank-lispworks.lisp (emacs-connected): Don't install the signal
handler here ...
(install-sigint-handler): ... use this instead
--- /project/slime/cvsroot/slime/ChangeLog 2008/12/30 18:57:54 1.1610
+++ /project/slime/cvsroot/slime/ChangeLog 2008/12/31 11:25:02 1.1611
@@ -23,6 +23,20 @@
Changed accordingly.
+2008-12-31 Helmut Eller <heller at common-lisp.net>
+
+ * slime.el ([test] find-definition.2): Also fails for Lispworks.
+ ([test] interrupt-at-toplevel, [test] interrupt-in-debugger): Those
+ don't work well if there's no REPL thread.
+
+ * swank-backend.lisp (wait-for-input, wait-for-one-stream): Don't
+ use PEEK-CHAR because we can't interrupt that cleanly.
+ * swank.lisp (simple-serve-requests): Run the REPL inside
+ WITH-CONNECTION.
+ * swank-lispworks.lisp (emacs-connected): Don't install the signal
+ handler here ...
+ (install-sigint-handler): ... use this instead
+
2008-12-29 Helmut Eller <heller at common-lisp.net>
* swank-openmcl.lisp (find-definitions, source-locations): Use
--- /project/slime/cvsroot/slime/slime.el 2008/12/30 18:57:54 1.1084
+++ /project/slime/cvsroot/slime/slime.el 2008/12/31 11:25:03 1.1085
@@ -7413,7 +7413,7 @@
(= orig-pos (point)))))
(slime-check-top-level))
-(def-slime-test (find-definition.2 ("ccl" "allegro"))
+(def-slime-test (find-definition.2 ("ccl" "allegro" "lispworks"))
(buffer-content buffer-package snippet)
"Check that we're able to find definitions even when
confronted with nasty #.-fu."
@@ -7842,15 +7842,18 @@
"Let's see what happens if we send a user interrupt at toplevel."
'(())
(slime-check-top-level)
- (slime-interrupt)
- (slime-wait-condition "Debugger visible"
- (lambda ()
- (and (slime-sldb-level= 1)
- (get-buffer-window (sldb-get-default-buffer))))
- 5)
- (with-current-buffer (sldb-get-default-buffer)
- (sldb-quit))
- (slime-sync-to-top-level 5))
+ (unless (and (eq (slime-communication-style) :spawn)
+ (not (featurep 'slime-repl)))
+ (slime-interrupt)
+ (slime-wait-condition
+ "Debugger visible"
+ (lambda ()
+ (and (slime-sldb-level= 1)
+ (get-buffer-window (sldb-get-default-buffer))))
+ 5)
+ (with-current-buffer (sldb-get-default-buffer)
+ (sldb-quit))
+ (slime-sync-to-top-level 5)))
(def-slime-test interrupt-in-debugger (interrupts continues)
"Let's see what happens if we interrupt the debugger.
@@ -7858,6 +7861,11 @@
CONTINUES ... how often the continue restart should be invoked"
'((1 0) (2 1) (4 2))
(slime-check "No debugger" (not (sldb-get-default-buffer)))
+ (when (and (eq (slime-communication-style) :spawn)
+ (not (featurep 'slime-repl)))
+ (slime-eval-async '(swank::without-slime-interrupts
+ (swank::receive)))
+ (sit-for 0.2))
(dotimes (i interrupts)
(slime-interrupt)
(let ((level (1+ i)))
--- /project/slime/cvsroot/slime/swank-backend.lisp 2008/12/30 18:57:54 1.165
+++ /project/slime/cvsroot/slime/swank-backend.lisp 2008/12/31 11:25:03 1.166
@@ -1066,24 +1066,21 @@
Return :interrupt if an interrupt occurs while waiting."
(assert (member timeout '(nil t)))
- (cond ((null (cdr streams))
+ (cond #+(or)
+ ((null (cdr streams))
(wait-for-one-stream (car streams) timeout))
(t
(wait-for-streams streams timeout))))
(defun wait-for-streams (streams timeout)
- (flet ((readyp (s)
- (let ((c (read-char-no-hang s nil :eof)))
- (or (eq c :eof)
- (and c (progn (unread-char c s) t))
- c))))
- (loop
- (let ((ready (remove-if-not #'readyp streams)))
- (when ready (return ready)))
- (when timeout (return nil))
- (when (check-slime-interrupts) (return :interrupt))
- (sleep 0.1))))
+ (loop
+ (when (check-slime-interrupts) (return :interrupt))
+ (let ((ready (remove-if-not #'stream-readable-p streams)))
+ (when ready (return ready)))
+ (when timeout (return nil))
+ (sleep 0.1)))
+;; Note: Usually we can't interrupt PEEK-CHAR cleanly.
(defun wait-for-one-stream (stream timeout)
(ecase timeout
((nil)
@@ -1097,6 +1094,12 @@
(list stream))
(t '()))))))
+(defun stream-readable-p (stream)
+ (let ((c (read-char-no-hang stream nil :eof)))
+ (cond ((not c) nil)
+ ((eq c :eof) t)
+ (t (unread-char c stream) t))))
+
(definterface toggle-trace (spec)
"Toggle tracing of the function(s) given with SPEC.
SPEC can be:
--- /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/12/30 18:57:54 1.124
+++ /project/slime/cvsroot/slime/swank-lispworks.lisp 2008/12/31 11:25:03 1.125
@@ -102,12 +102,6 @@
(apply (read-from-string "FLEXI-STREAMS:MAKE-EXTERNAL-FORMAT")
external-format)))
-(defun set-sigint-handler ()
- ;; Set SIGINT handler on Swank request handler thread.
- #-win32
- (sys::set-signal-handler +sigint+
- (make-sigint-handler mp:*current-process*)))
-
;;; Coding Systems
(defun valid-external-format-p (external-format)
@@ -141,6 +135,20 @@
(declare (ignore args))
(mp:process-interrupt process #'sigint-handler)))
+(defun set-sigint-handler ()
+ ;; Set SIGINT handler on Swank request handler thread.
+ #-win32
+ (sys::set-signal-handler +sigint+
+ (make-sigint-handler mp:*current-process*)))
+
+#-win32
+(defimplementation install-sigint-handler (handler)
+ (sys::set-signal-handler +sigint+
+ (let ((self mp:*current-process*))
+ (lambda (&rest args)
+ (declare (ignore args))
+ (mp:process-interrupt self handler)))))
+
(defimplementation call-without-interrupts (fn)
(lw:without-interrupts (funcall fn)))
@@ -819,7 +827,7 @@
(return (car tail)))))
(when (eq timeout t) (return (values nil t)))
(mp:process-wait-with-timeout
- "receive-if" 0.2 (lambda () (some test (mailbox.queue mbox)))))))
+ "receive-if" 0.3 (lambda () (some test (mailbox.queue mbox)))))))
(defimplementation send (thread message)
(let ((mbox (mailbox thread)))
@@ -830,11 +838,6 @@
;;; Some intergration with the lispworks environment
(defun swank-sym (name) (find-symbol (string name) :swank))
-
-(defimplementation emacs-connected ()
- (when (eq (eval (swank-sym :*communication-style*))
- nil)
- (set-sigint-handler)))
;;;; Weak hashtables
--- /project/slime/cvsroot/slime/swank.lisp 2008/12/30 18:57:54 1.618
+++ /project/slime/cvsroot/slime/swank.lisp 2008/12/31 11:25:03 1.619
@@ -362,17 +362,19 @@
`(with-interrupts-enabled% nil ,body))
(defun invoke-or-queue-interrupt (function)
- (log-event "invoke-or-queue-interrupt: ~a" function)
+ (log-event "invoke-or-queue-interrupt: ~a~%" function)
(cond ((not (boundp '*slime-interrupts-enabled*))
(without-slime-interrupts
(funcall function)))
(*slime-interrupts-enabled*
+ (log-event "interrupts-enabled~%")
(funcall function))
(t
(setq *pending-slime-interrupts*
(nconc *pending-slime-interrupts*
(list function)))
(cond ((cdr *pending-slime-interrupts*)
+ (log-event "too many queued interrupts~%")
(check-slime-interrupts))
(t
(log-event "queue-interrupt: ~a" function)
@@ -1036,8 +1038,8 @@
(current-thread))
(t
(let ((thread (connection.repl-thread connection)))
- (assert thread)
- (cond ((thread-alive-p thread) thread)
+ (cond ((not thread) nil)
+ ((thread-alive-p thread) thread)
(t
(setf (connection.repl-thread connection)
(spawn-repl-thread connection "new-repl-thread"))))))))
@@ -1053,9 +1055,13 @@
(defun interrupt-worker-thread (id)
(let ((thread (or (find-worker-thread id)
- (find-repl-thread *emacs-connection*))))
+ (find-repl-thread *emacs-connection*)
+ ;; FIXME: to something better here
+ (spawn (lambda ()) :name "ephemeral"))))
+ (log-event "interrupt-worker-thread: ~a ~a~%" id thread)
+ (assert thread)
(signal-interrupt thread
- (lambda ()
+ (lambda ()
(invoke-or-queue-interrupt #'simple-break)))))
(defun thread-for-evaluation (id)
@@ -1134,8 +1140,8 @@
(send (connection.control-thread *emacs-connection*) event))
(t (dispatch-event event))))
-(defun signal-interrupt (thread interrupt)
- (log-event "signal-interrupt~%")
+(defun signal-interrupt (thread interrupt)
+ (log-event "signal-interrupt [~a]: ~a ~a~%" (use-threads-p) thread interrupt)
(cond ((use-threads-p) (interrupt-thread thread interrupt))
(t (funcall interrupt))))
@@ -1269,7 +1275,8 @@
(let* ((stdin (real-input-stream *standard-input*))
(*standard-input* (make-repl-input-stream connection
stdin)))
- (simple-repl)))))
+ (with-connection (connection)
+ (simple-repl))))))
(close-connection connection nil (safe-backtrace))))
(defun simple-repl ()
@@ -2416,7 +2423,8 @@
(defslimefun throw-to-toplevel ()
"Invoke the ABORT-REQUEST restart abort an RPC from Emacs.
If we are not evaluating an RPC then ABORT instead."
- (let ((restart (and *sldb-quit-restart*
+ (let ((restart (and (boundp '*sldb-quit-restart*)
+ (typep *sldb-quit-restart* 'restart)
(find-restart *sldb-quit-restart*))))
(cond (restart (invoke-restart restart))
(t "No toplevel restart active"))))
More information about the slime-cvs
mailing list