X-Git-Url: https://jxself.org/git/?a=blobdiff_plain;ds=sidebyside;f=8sync%2Fsystems%2Factors.scm;h=ce23bfab2acdc16daecfded2456cb66ee47f3bb2;hb=47dbaac681252f3d71e78a712cab0c829b913a63;hp=ea638c0e180eb5b290f88ef6bde90d36eae2669f;hpb=e268e79621f23cb7d3d9efc78093f0d85b356cdf;p=8sync.git

diff --git a/8sync/systems/actors.scm b/8sync/systems/actors.scm
index ea638c0..ce23bfa 100644
--- a/8sync/systems/actors.scm
+++ b/8sync/systems/actors.scm
@@ -22,6 +22,7 @@
   #:use-module (oop goops)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
+  #:use-module (ice-9 control)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:use-module (ice-9 pretty-print)
@@ -36,6 +37,8 @@
             actor-id
             actor-message-handler
 
+            %current-actor
+
             ;;; Commenting out the <address> type for now;
             ;;; it may be back when we have better serializers
             ;; <address>
@@ -50,6 +53,8 @@
             simple-dispatcher build-actions make-action-dispatch
             define-simple-actor
 
+            mhandlers
+
             <hive>
             make-hive
             ;; There are more methods for the hive, but there's
@@ -70,7 +75,7 @@
 
             <- <-wait <-reply <-reply-wait
 
-            call-with-message msg-receive
+            call-with-message msg-receive msg-val
 
             ez-run-hive
             bootstrap-message
@@ -110,6 +115,11 @@
 ;;; ========
 
 
+;; @@: We may want to add a deferred-reply to the below, similar to
+;;   what we had in XUDD, for actors which do their own response
+;;   queueing.... ie, that might receive messages but need to shelve
+;;   them to be acted upon after something else is taken care of.
+
 (define-record-type <message>
   (make-message-intern id to from action
                        body in-reply-to wants-reply
@@ -220,6 +230,29 @@
 ;;; Main actor implementation
 ;;; =========================
 
+(define (actor-inheritable-message-handler actor message)
+  (define action (message-action message))
+  (define (find-message-handler return)
+    (for-each (lambda (this-class)
+                (define actions
+                  (or (and (class-slot-definition this-class 'actions)
+                           (class-slot-ref this-class 'actions))
+                      '()))
+                (for-each (match-lambda
+                            ((action-name . method)
+                             (when (eq? action-name action)
+                               (return method))))
+                          actions))
+              (class-precedence-list (class-of actor)))
+    (throw 'action-not-found
+           "No appropriate action handler found for actor"
+           #:action action
+           #:actor actor
+           #:message message))
+  (define method
+    (call/ec find-message-handler))
+  (apply method actor message (message-body message)))
+
 (define-class <actor> ()
   ;; An address object
   (id #:init-keyword #:id
@@ -229,7 +262,15 @@
   (hive #:init-keyword #:hive
         #:accessor actor-hive)
   ;; How we receive and process new messages
-  (message-handler #:allocation #:each-subclass))
+  (message-handler #:init-value actor-inheritable-message-handler
+                   ;; @@: There's no reason not to use #:class instead of
+                   ;;   #:each-subclass anywhere in this file, except for
+                   ;;   Guile bug #25211 (#:class is broken in Guile 2.2)
+                   #:allocation #:each-subclass)
+
+  ;; This is the default, "simple" way to inherit and process messages.
+  (actions #:init-value '()
+           #:allocation #:each-subclass))
 
 (define-method (actor-message-handler (actor <actor>))
   (slot-ref actor 'message-handler))
@@ -276,11 +317,16 @@
   "Render the full actor id as a human-readable string"
   (address->string (actor-id actor)))
 
+(define %current-actor
+  (make-parameter #f))
+
 
 
 ;;; Actor utilities
 ;;; ===============
 
+;;;;;;;;;;; Deprecated abstractions start here ;;;;;;;;;;;
+
 (define (simple-dispatcher action-map)
   (lambda (actor message)
     (let* ((action (message-action message))
@@ -333,11 +379,21 @@ more compact following syntax:
     ((make-action-dispatch action-item ...)
      (simple-dispatcher (build-actions action-item ...)))))
 
-(define-syntax-rule (define-simple-actor class actions ...)
+;;;;;;;;;;; Deprecated abstractions end here ;;;;;;;;;;;
+
+
+(define-syntax-rule (mhandlers (symbol method) ...)
+  "Construct an alist of (symbol . method), where the method is wrapped
+with wrap-apply to facilitate live hacking and allow the method definition
+to come after class definition."
+  (list
+   (cons (quote symbol)
+         (wrap-apply method)) ...))
+
+(define-syntax-rule (define-simple-actor class action ...)
   (define-class class (<actor>)
-    (message-handler
-     #:init-value (make-action-dispatch actions ...)
-     #:allocation #:each-subclass)))
+    (actions #:init-value (mhandlers action ...)
+             #:allocation #:each-subclass)))
 
 
 ;;; The Hive
@@ -505,13 +561,14 @@ more compact following syntax:
        (lambda ()
          (define message-handler (actor-message-handler actor))
          ;; @@: Should a more general error handling happen here?
-         (let ((result
-                (message-handler actor message)))
-           (maybe-autoreply actor)
-           ;; Returning result allows actors to possibly make a run-request
-           ;; at the end of handling a message.
-           ;; ... We do want that, right?
-           result)))))
+         (parameterize ((%current-actor actor))
+           (let ((result
+                  (message-handler actor message)))
+             (maybe-autoreply actor)
+             ;; Returning result allows actors to possibly make a run-request
+             ;; at the end of handling a message.
+             ;; ... We do want that, right?
+             result))))))
 
   (define (resume-waiting-coroutine)
     (cond
@@ -617,11 +674,20 @@ argument.  Similar to call-with-values in concept."
 ;; Emacs: (put 'msg-receive 'scheme-indent-function 2)
 
 ;; @@: Or receive-msg or receieve-message or??
-(define-syntax-rule (msg-receive arglist the-message body ...)
-  (call-with-message the-message
+(define-syntax-rule (msg-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)
+  "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."
+  (call-with-message message
+                     (lambda (_ val) val)))
+
 
 ;;; Various API methods for actors to interact with the system
 ;;; ==========================================================