fix actor, async: correctly handle interactive interrupt

core/actor.lisp

@@ -35,10 +35,6 @@
 
 ;;;; actor loop (listener)
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (when (not (boundp '+quit-message+)) 
-    (defconstant +quit-message+ (gensym "QUIT"))))
-
 (defun start (tsk bhv &key foreground)
   (setf (async:behavior tsk) bhv)
   (if foreground
@@ -46,28 +42,24 @@
     (async:submit-task tsk #'ac-loop tsk bhv)))
 
 (defun stop (mb)
-  (send mb +quit-message+))
+  (send mb async:+quit-message+))
 
 (defvar *self* nil)
 
 (defgeneric ac-loop (tsk bhv)
   (:method ((tsk async:task) bhv)
     (let ((msg (async:rcv tsk)))
-      (unless (eq (ac-step tsk bhv msg) +quit-message+)
+      (unless (eq (content msg) async:+quit-message+)
+        (ac-step tsk bhv msg)
         (ac-loop tsk (async:behavior tsk))))))
 
 (defun ac-step (tsk bhv msg)
-  (when (eq (content msg) +quit-message+)
-    (return-from ac-step +quit-message+))
   (let ((*self* tsk))
     (handler-case (funcall bhv msg)
-      (condition (err)
-             (util:lg :error "behavior" msg err)
-             +quit-message+)
       (error (err) 
-             (invoke-debugger err)
-             ;(util:lg :error "behavior" msg err)
-             ))))
+             (util:lg :error "behavior" msg err))
+             ;(invoke-debugger err))
+      )))
 
 ;;;; the core (classical, i.e. Hewitt) actor API
 

util/async.lisp

@@ -3,13 +3,16 @@
 (defpackage :scopes/util/async
   (:use :common-lisp)
   (:local-nicknames (:lp :lparallel)
-                    (:lpq :lparallel.queue))
-  (:export #:init #:finish #:make-mb #:make-task #:rcv #:try-rcv #:snd 
+                    (:lpq :lparallel.queue)
+                    (:util :scopes/util))
+  (:export #:+quit-message+ #:init #:finish #:make-mb #:make-task #:rcv #:try-rcv #:snd 
            #:mailbox #:task #:restartable-task #:behavior #:get-status #:set-status
            #:submit-task #:receive-result #:try-receive-result))
 
 (in-package :scopes/util/async)
 
+(defconstant +quit-message+ :quit)
+
 ;;;; general definitions (lparallel wrappers)
 
 (defun init ()
@@ -31,7 +34,11 @@
   (make-instance 'mailbox))
 
 (defun rcv (mb)
-  (lpq:pop-queue (queue mb)))
+  (handler-case 
+        (lpq:pop-queue (queue mb))
+    (condition (cnd)
+      (util:lg :info "condition on pop-queue" cnd)
+      +quit-message+)))
 
 (defun try-rcv (mb)
   (lpq:try-pop-queue (queue mb)))