45 lines
1.5 KiB
Racket
45 lines
1.5 KiB
Racket
#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) transition)
|
|
(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 (topic-subscriber (cons always-evt (wild)))
|
|
#:name 'waiter
|
|
#: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 (debug-name 'nested-vm)
|
|
(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)))))
|