From 8bdfa5c8f81d4e46d57c367da23cd8ea676ad717 Mon Sep 17 00:00:00 2001 From: Christopher Allan Webber Date: Wed, 25 Jan 2017 11:42:20 -0600 Subject: [PATCH] actors: Switch over to using wrap-rmeta-slot for build-actions. * 8sync/rmeta-slot.scm (wrap-rmeta-slot): New variable. * 8sync/actors.scm (build-actions): Switch from using make-rmeta-slot to using wrap-rmeta-slot. * doc/8sync.texi (Writing our own actors): Update documentation to use #:init-thunk. * 8sync/actors.scm (, define-actor, ): * 8sync/systems/irc.scm (): * demos/actors/robotscanner.scm (, ): * tests/test-actors.scm (): * tests/test-rmeta-slot.scm (, ): Update to use #:init-thunk instead of #:init-value on actions slot. --- 8sync/actors.scm | 8 ++++---- 8sync/rmeta-slot.scm | 16 +++++++++++----- 8sync/systems/irc.scm | 2 +- demos/actors/robotscanner.scm | 4 ++-- doc/8sync.texi | 11 +++++++---- tests/test-actors.scm | 2 +- tests/test-rmeta-slot.scm | 8 ++++---- 7 files changed, 30 insertions(+), 21 deletions(-) diff --git a/8sync/actors.scm b/8sync/actors.scm index 204582d..d6dc148 100644 --- a/8sync/actors.scm +++ b/8sync/actors.scm @@ -311,7 +311,7 @@ raise an exception if an error." "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." - (make-rmeta-slot + (wrap-rmeta-slot (list (cons (quote symbol) (wrap-apply method)) ...))) @@ -339,7 +339,7 @@ to come after class definition." #: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. @@ -390,7 +390,7 @@ to come after class definition." (action ...) slots ...) (define-class class inherits - (actions #:init-value (build-actions action ...) + (actions #:init-thunk (build-actions action ...) #:allocation #:each-subclass) slots ...)) @@ -424,7 +424,7 @@ to come after class definition." (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 diff --git a/8sync/rmeta-slot.scm b/8sync/rmeta-slot.scm index 7a3fe32..6c4ef6d 100644 --- a/8sync/rmeta-slot.scm +++ b/8sync/rmeta-slot.scm @@ -21,7 +21,8 @@ #:use-module (srfi srfi-9) #:use-module (ice-9 match) - #:export (make-rmeta-slot + #:export (wrap-rmeta-slot + rmeta-slot-table rmeta-slot-cache maybe-build-rmeta-slot-cache! class-rmeta-ref)) @@ -40,8 +41,8 @@ ;;; ;; Define a class with a meta-slot ;;; (define-class () ;;; (entries #:allocation #:each-subclass -;;; #:init-value -;;; (make-rmeta-slot +;;; #:init-thunk +;;; (wrap-rmeta-slot ;;; `((foo . "bar") ;;; (baz . "basil"))))) ;;; @@ -52,8 +53,8 @@ ;;; ;; Define a subclass ;;; (define-class () ;;; (entries #:allocation #:each-subclass -;;; #:init-value -;;; (make-rmeta-slot +;;; #:init-thunk +;;; (wrap-rmeta-slot ;;; `((foo . "foo2") ;;; (peanut . "gallery"))))) ;;; @@ -71,6 +72,11 @@ (define (make-rmeta-slot table) (%make-rmeta-slot table #f)) +(define (wrap-rmeta-slot table) + "In general, using wrap-rmeta-slot in combination with " + (lambda () + (make-rmeta-slot table))) + ;; Immutable and unique (define %the-nothing (cons '*the* '*nothing*)) diff --git a/8sync/systems/irc.scm b/8sync/systems/irc.scm index 5d2b66b..fff3461 100755 --- a/8sync/systems/irc.scm +++ b/8sync/systems/irc.scm @@ -159,7 +159,7 @@ #:getter irc-bot-port) (socket #:accessor irc-bot-socket) (actions #:allocation #:each-subclass - #:init-value (build-actions + #:init-thunk (build-actions (*init* irc-bot-init) (*cleanup* irc-bot-cleanup) (main-loop irc-bot-main-loop) diff --git a/demos/actors/robotscanner.scm b/demos/actors/robotscanner.scm index 7ed6dd2..feb8f14 100644 --- a/demos/actors/robotscanner.scm +++ b/demos/actors/robotscanner.scm @@ -113,7 +113,7 @@ (actions #:allocation #:each-subclass - #:init-value + #:init-thunk (build-actions (set-next-room (lambda* (actor message #:key id) @@ -158,7 +158,7 @@ (actions #:allocation #:each-subclass - #:init-value + #:init-thunk (build-actions (register-with-room (lambda (actor message) diff --git a/doc/8sync.texi b/doc/8sync.texi index 1d9e4af..67eba86 100644 --- a/doc/8sync.texi +++ b/doc/8sync.texi @@ -440,7 +440,7 @@ How about an actor that start sleeping, and keeps sleeping? (define-class () (actions #:allocation #:each-subclass - #:init-value (build-actions + #:init-thunk (build-actions (*init* sleeper-loop)))) (define (sleeper-loop actor message) @@ -457,9 +457,12 @@ How about an actor that start sleeping, and keeps sleeping? We see some particular things in this example. One thing is that our @verb{~~} actor has an actions slot. This is used to look up what the "action handler" for a message is. -We have to set the #:allocation to either @verb{~#:each-subclass~} or -@verb{~#:class~}.@footnote{#:class should be fine, except there is @uref{https://debbugs.gnu.org/cgi/bugreport.cgi?bug=25211,a bug in Guile} which keeps -us from using it for now.} +We have to set the #:allocation to either @verb{~#:each-subclass~} +and use @verb{~#:init-thunk~}.@footnote{@verb{~build-subclass~} returns +a thunk to be called later so that each subclass may correctly build +its own instance. This is important because the structure returned +contains a cache, which may vary from subclass to subclass based on +its inheritance structure.} The only action handler we've added is for @verb{~*init*~}, which is called implicitly when the actor first starts up. diff --git a/tests/test-actors.scm b/tests/test-actors.scm index 0b9adb5..30f13d0 100644 --- a/tests/test-actors.scm +++ b/tests/test-actors.scm @@ -184,7 +184,7 @@ customer> Whaaaaat? I can't believe I got voice mail!\n" (create-friend #:init-value #f #:init-keyword #:create-friend) (actions #:allocation #:each-subclass - #:init-value (build-actions + #:init-thunk (build-actions (*init* hi-on-init-init)))) (define (hi-on-init-init actor message) diff --git a/tests/test-rmeta-slot.scm b/tests/test-rmeta-slot.scm index 0fd4b6f..46d30db 100644 --- a/tests/test-rmeta-slot.scm +++ b/tests/test-rmeta-slot.scm @@ -27,8 +27,8 @@ ;; Define a class (define-class () (entries #:allocation #:each-subclass - #:init-value - (make-rmeta-slot + #:init-thunk + (wrap-rmeta-slot `((foo . "bar") (baz . "basil"))))) @@ -41,8 +41,8 @@ (define-class () (entries #:allocation #:each-subclass - #:init-value - (make-rmeta-slot + #:init-thunk + (wrap-rmeta-slot `((foo . "foo2") (peanut . "gallery"))))) -- 2.31.1