Event relaying plus an example program
This commit is contained in:
parent
47468b2b37
commit
3fdd1ae746
|
@ -0,0 +1,28 @@
|
||||||
|
#lang racket/base
|
||||||
|
;; Ground-event relay for os2.
|
||||||
|
|
||||||
|
(provide event-relay)
|
||||||
|
(require "os2.rkt")
|
||||||
|
|
||||||
|
(define event-relay
|
||||||
|
(transition 'no-state
|
||||||
|
(role 'relay-down (topic-publisher (cons (wild) (wild)) #:monitor? #t)
|
||||||
|
#:state state
|
||||||
|
#:topic t
|
||||||
|
#:on-presence (match t
|
||||||
|
[(topic 'subscriber (cons (? evt? e) _) #f)
|
||||||
|
(printf "SUBSCRIBED ~v~n" e) (flush-output)
|
||||||
|
(transition state
|
||||||
|
(at-meta-level
|
||||||
|
(role t (topic-subscriber (cons e (wild)))
|
||||||
|
#:state state
|
||||||
|
[msg
|
||||||
|
(printf "FIRED ~v -> ~v~n" e msg) (flush-output)
|
||||||
|
(transition state
|
||||||
|
(send-message msg))])))]
|
||||||
|
[_ state])
|
||||||
|
#:on-absence (match t
|
||||||
|
[(topic 'subscriber (cons (? evt?) e) #f)
|
||||||
|
(printf "UNSUBSCRIBED ~v~n" e) (flush-output)
|
||||||
|
(transition state
|
||||||
|
(at-meta-level (delete-role t)))]))))
|
|
@ -0,0 +1,45 @@
|
||||||
|
#lang racket/base
|
||||||
|
;; Trivial demonstration of nested os2.rkt virtual machines.
|
||||||
|
|
||||||
|
(require "os2.rkt")
|
||||||
|
(require "os2-event-relay.rkt")
|
||||||
|
|
||||||
|
(define (spy spy-label)
|
||||||
|
(lambda (spy-pid)
|
||||||
|
(define (hs label)
|
||||||
|
(define ((w kind) . args) (write `(,spy-label ,label ,kind ,@args)) (newline) values)
|
||||||
|
(handlers (w 'presence)
|
||||||
|
(w 'absence)
|
||||||
|
(w 'message)))
|
||||||
|
(transition 'spy-state
|
||||||
|
(add-role 's->p (topic-publisher (wild) #:monitor? 'everything)
|
||||||
|
(hs 'subscriber->publisher))
|
||||||
|
(add-role 'p->s (topic-subscriber (wild) #:monitor? 'everything)
|
||||||
|
(hs 'publisher->subscriber)))))
|
||||||
|
|
||||||
|
(define (eventing-process label)
|
||||||
|
(spawn (lambda (self-pid)
|
||||||
|
(transition 'no-state
|
||||||
|
(role 'waiter (topic-subscriber (cons always-evt (wild)))
|
||||||
|
#:state state
|
||||||
|
[msg
|
||||||
|
(write `(event ,label ,msg)) (newline) (flush-output)
|
||||||
|
(transition state
|
||||||
|
(delete-role 'waiter))])))
|
||||||
|
#:debug-name (debug-name label)))
|
||||||
|
|
||||||
|
(ground-vm (lambda (boot-pid)
|
||||||
|
(define event-at-ground? #f)
|
||||||
|
(define install-relay? #t)
|
||||||
|
(transition 'no-state
|
||||||
|
(spawn (spy 'ground-spy))
|
||||||
|
(when event-at-ground? (eventing-process 'ground-level-eventing-process))
|
||||||
|
(spawn (nested-vm (debug-name 'nested-vm)
|
||||||
|
(lambda (boot-pid)
|
||||||
|
(transition 'no-state
|
||||||
|
(spawn (spy 'nested-spy))
|
||||||
|
(when install-relay? (spawn event-relay
|
||||||
|
#:debug-name 'event-relay))
|
||||||
|
(when (not event-at-ground?)
|
||||||
|
(eventing-process 'nested-eventing-process)))))
|
||||||
|
#:debug-name (debug-name 'nested-vm)))))
|
Loading…
Reference in New Issue