[mcclim-cvs] CVS mcclim/Apps/Listener

[thenriksen]

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener
In directory clnet:/tmp/cvs-serv13866/Apps/Listener

Modified Files:
	dev-commands.lisp 
Log Message:
Added the ability to cancel a computation in the CLIM Listener by
pressing the abort gesture.


--- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp	2008/04/14 16:55:05	1.54
+++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp	2008/05/20 15:33:14	1.55
@@ -1519,14 +1519,36 @@
 
 (define-command (com-eval :menu t :command-table lisp-commands)
     ((form 'clim:form :prompt "form"))
-  (let* ((- form)
-         (values (multiple-value-list (eval form))))
-    (fresh-line)
-    (shuffle-specials form values)
-    (display-evalues values)
-    (fresh-line)))
-
-
+  (flet ((evaluate ()
+           (let ((- form))
+             (multiple-value-list (eval form)))))
+    ;; If possible, use a thread for evaluation, permitting us to
+    ;; interrupt it.
+    (let* ((start-time (get-internal-real-time))
+           (values
+            (if clim-sys:*multiprocessing-p*
+                (catch 'done
+                  (let* ((orig-process (clim-sys:current-process))
+                         (eval-process
+                          (clim-sys:make-process
+                           #'(lambda ()
+                               (let ((values (evaluate)))
+                                 (clim-sys:process-interrupt orig-process
+                                                             #'(lambda ()
+                                                                 (throw 'done values))))))))
+                    (handler-case (loop (read-gesture))
+                      (abort-gesture ()
+                        (clim-sys:destroy-process eval-process)
+                        (with-text-style (t (make-text-style nil :italic nil))
+                          (format t "Aborted by user after ~F seconds."
+                                  (/ (- (get-internal-real-time) start-time)
+                                     internal-time-units-per-second)))
+                        (return-from com-eval)))))
+                (evaluate))))
+      (fresh-line)
+      (shuffle-specials form values)
+      (display-evalues values)
+      (fresh-line))))
 
 ;;; Some CLIM developer commands