#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:use-module (8sync agenda)
+ #:use-module (8sync rmeta-slot)
#:export (;; utilities... ought to go in their own module
big-random-number
big-random-number-string
(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)))
+ (define method
+ (class-rmeta-ref (class-of actor) 'actions action
+ #:equals? eq? #:cache-set! hashq-set!
+ #:cache-ref hashq-ref))
+ (unless method
(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-syntax-rule (build-actions (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)) ...))
+ (build-rmeta-slot
+ (list (cons (quote symbol)
+ (wrap-apply method)) ...)))
(define-class <actor> ()
;; An address object
#:allocation #:each-subclass)
;; This is the default, "simple" way to inherit and process messages.
- (actions #:init-value (build-actions
+ (actions #:init-thunk (build-actions
;; Default init method is to do nothing.
(*init* (const #f))
;; Default cleanup method is to do nothing.
(action ...)
slots ...)
(define-class class inherits
- (actions #:init-value (build-actions action ...)
+ (actions #:init-thunk (build-actions action ...)
#:allocation #:each-subclass)
slots ...))
(prompt #:init-thunk make-prompt-tag
#:getter hive-prompt)
(actions #:allocation #:each-subclass
- #:init-value
+ #:init-thunk
(build-actions
;; This is in the case of an ambassador failing to forward a
;; message... it reports it back to the hive
message))
actor))
- (define (call-catching-coroutine thunk)
+ ;; TODO: I'm pretty sure we're building up another stack of prompts here
+ ;; with the way we're doing this. That's a real problem.
+ (define* (call-catching-coroutine thunk #:optional (catch-errors #t))
(define queued-error-handling-thunk #f)
(define (call-catching-errors)
;; TODO: maybe parameterize (or attach to hive) and use
(if queued-error-handling-thunk
(8sync (queued-error-handling-thunk))))
(call-with-prompt (hive-prompt hive)
- call-catching-errors
+ (if catch-errors
+ call-catching-errors
+ thunk)
(lambda (kont actor message send-options)
;; Register the coroutine
(hash-set! (hive-waiting-coroutines hive)
result))
(#f (throw 'no-waiting-coroutine
"message in-reply-to tries to resume nonexistent coroutine"
- message))))))
+ message))))
+ ;; no need to catch errors here, there's already an error handler
+ #f))
;; Unhandled action for a reply!
(else
(throw 'hive-unresumable-coroutine