Update copyrights.

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

diff --git a/8sync/actors.scm b/8sync/actors.scm
index 1d8e6023aa3b19bcb8350e4ee35d759cc3f59021..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.
 ;;;
@@ -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))
@@ -779,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