Update copyrights.

[8sync.git] / 8sync / actors.scm

diff --git a/8sync/actors.scm b/8sync/actors.scm
index 1f5bd3c1cb38c6a3c834e8a0e5ef1b04ffd2e04a..c805067b21def054ff2d3f6233e89824671a96e9 100644 (file)
--- a/8sync/actors.scm
+++ b/8sync/actors.scm
@@ -1,5 +1,5 @@
 ;;; 8sync --- Asynchronous programming for Guile
-;;; Copyright (C) 2016 Christopher Allan Webber <cwebber@dustycloud.org>
+;;; Copyright © 2016, 2017 Christopher Allan Webber <cwebber@dustycloud.org>
 ;;;
 ;;; This file is part of 8sync.
 ;;;
@@ -51,7 +51,7 @@
 
             build-actions
 
-            define-simple-actor
+            define-actor
 
             <hive>
             make-hive
@@ -73,7 +73,7 @@
 
             <- <-* <-wait <-wait* <-reply <-reply* <-reply-wait <-reply-wait*
 
-            call-with-message msg-receive msg-val
+            call-with-message mbody-receive mbody-val
 
             run-hive
             bootstrap-message
@@ -342,22 +342,9 @@ to come after class definition."
                          (*cleanup* (const #f)))
            #:allocation #:each-subclass))
 
-;;; So these are the nicer representations of addresses.
-;;; However, they don't serialize so easily with scheme read/write, so we're
-;;; using the simpler cons cell version below for now.
-
-;; (define-record-type <address>
-;;   (make-address actor-id hive-id)  ; @@: Do we want the trailing -id?
-;;   address?
-;;   (actor-id address-actor-id)
-;;   (hive-id address-hive-id))
-;;
-;; (set-record-type-printer!
-;;  <address>
-;;  (lambda (record port)
-;;    (format port "<address: ~s@~s>"
-;;            (address-actor-id record) (address-hive-id record))))
-;;
+;;; Addresses are vectors where the first part is the actor-id and
+;;; the second part is the hive-id.  This works well enough... they
+;;; look decent being pretty-printed.
 
 (define (make-address actor-id hive-id)
   (vector actor-id hive-id))
@@ -395,10 +382,13 @@ to come after class definition."
 ;;; Actor utilities
 ;;; ===============
 
-(define-syntax-rule (define-simple-actor class action ...)
-  (define-class class (<actor>)
+(define-syntax-rule (define-actor class inherits
+                      (action ...)
+                      slots ...)
+  (define-class class inherits
     (actions #:init-value (build-actions action ...)
-             #:allocation #:each-subclass)))
+             #:allocation #:each-subclass)
+    slots ...))
 
 \f
 ;;; The Hive
@@ -715,21 +705,21 @@ for debugging"
 argument.  Similar to call-with-values in concept."
   (apply proc message (message-body message)))
 
-;; (msg-receive (<- bar baz)
+;; (mbody-receive (<- bar baz)
 ;;     (baz)
 ;;   basil)
 
-;; Emacs: (put 'msg-receive 'scheme-indent-function 2)
+;; Emacs: (put 'mbody-receive 'scheme-indent-function 2)
 
 ;; @@: Or receive-msg or receieve-message or??
-(define-syntax-rule (msg-receive arglist message body ...)
+(define-syntax-rule (mbody-receive arglist message body ...)
   "Call body with arglist (which can accept arguments like lambda*)
 applied from the message-body of message."
   (call-with-message message
                      (lambda* arglist
                        body ...)))
 
-(define (msg-val message)
+(define (mbody-val message)
   "Retrieve the first value from the message-body of message.
 Like single value return from a procedure call.  Probably the most
 common case when waiting on a reply from some action invocation."
@@ -776,17 +766,32 @@ its '*cleanup* action handler."
 ;;; =========================
 
 (define* (run-hive hive initial-tasks
-                   #:key (cleanup #t))
-  "Start up an agenda and run HIVE in it with INITIAL-TASKS."
+                   #:key (cleanup #t)
+                   (handle-signals (list SIGINT SIGTERM)))
+  "Start up an agenda and run HIVE in it with INITIAL-TASKS.
+
+Keyword arguments:
+ - #:cleanup: Whether to run *cleanup* on all actors.
+ - #:handle-sigactions: a list of signals to set up interrupt
+   handlers for, so cleanup sill still happen as expected.
+   Defaults to a list of SIGINT and SIGTERM."
   (dynamic-wind
     (const #f)
     (lambda ()
-      (let* ((queue (list->q
-                     (cons (bootstrap-message hive (actor-id hive) '*init-all*)
-                           initial-tasks)))
-             (agenda (make-agenda #:pre-unwind-handler print-error-and-continue
-                                  #:queue queue)))
-        (run-agenda agenda)))
+      (define (run-it escape)
+        (define (handle-signal signum)
+          (restore-signals)
+          (escape signum))
+        (for-each (lambda (signum)
+                    (sigaction signum handle-signal))
+                  handle-signals)
+        (let* ((queue (list->q
+                       (cons (bootstrap-message hive (actor-id hive) '*init-all*)
+                             initial-tasks)))
+               (agenda (make-agenda #:pre-unwind-handler print-error-and-continue
+                                    #:queue queue)))
+          (run-agenda agenda)))
+      (call/ec run-it))
     ;; Run cleanup
     (lambda ()
       (when cleanup