[mcclim-cvs] CVS mcclim/Apps/Listener
thenriksen
thenriksen at common-lisp.net
Tue May 27 15:30:33 UTC 2008
Update of /project/mcclim/cvsroot/mcclim/Apps/Listener
In directory clnet:/tmp/cvs-serv21697/Apps/Listener
Modified Files:
dev-commands.lisp
Log Message:
In the Listener, handle abort gesture properly even if the eval-thread
is in the debugger.
--- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/05/20 16:16:02 1.57
+++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/05/27 15:30:32 1.58
@@ -1540,21 +1540,25 @@
(if clim-sys:*multiprocessing-p*
(catch 'done
(let* ((orig-process (clim-sys:current-process))
+ (evaluating t)
(eval-process
(clim-sys:make-process
#'(lambda ()
(let ((result (evaluate)))
- (clim-sys:process-interrupt orig-process
- #'(lambda ()
- (throw 'done result))))))))
- (handler-case (loop for gesture = (read-gesture)
- when (and (typep gesture 'keyboard-event)
- (eq (keyboard-event-key-name gesture) :pause))
- do (clim-sys:process-interrupt eval-process #'break))
- (abort-gesture ()
- (clim-sys:destroy-process eval-process)
- (cons :abort (/ (- (get-internal-real-time) start-time)
- internal-time-units-per-second))))))
+ (when evaluating
+ (clim-sys:process-interrupt orig-process
+ #'(lambda ()
+ (throw 'done result)))))))))
+ (unwind-protect
+ (handler-case (loop for gesture = (read-gesture)
+ when (and (typep gesture 'keyboard-event)
+ (eq (keyboard-event-key-name gesture) :pause))
+ do (clim-sys:process-interrupt eval-process #'break))
+ (abort-gesture ()
+ (clim-sys:destroy-process eval-process)
+ (cons :abort (/ (- (get-internal-real-time) start-time)
+ internal-time-units-per-second))))
+ (setf evaluating nil))))
(evaluate))
(ecase result
(:values
More information about the Mcclim-cvs
mailing list