X-Git-Url: https://jxself.org/git/?a=blobdiff_plain;ds=sidebyside;f=8sync%2Factors.scm;h=c805067b21def054ff2d3f6233e89824671a96e9;hb=4998e7a9fe3b303923d918cd6087633d5302274f;hp=8e1b504b9378e3f5ff5ab4e239018459cb2ced3f;hpb=2785c244a09fc008488385b10053ef854fb27c34;p=8sync.git

diff --git a/8sync/actors.scm b/8sync/actors.scm
index 8e1b504..c805067 100644
--- 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
@@ -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 ...))
 
 
 ;;; The Hive
@@ -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