From 3a2ea7b026e019f0daa77e6dfb8bd1e6def2b700 Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Mon, 23 Jul 2012 17:42:18 -0400
Subject: [PATCH] Make nested-vm and ground-vm able to take actions instead of
 transition, for stateless boot processes

---
 chat-os2-paper.rkt     | 19 +++++++++----------
 chat-os2.rkt           | 14 ++++++--------
 os2-nested-example.rkt | 11 +++++------
 os2.rkt                | 14 ++++++++++----
 4 files changed, 30 insertions(+), 28 deletions(-)

diff --git a/chat-os2-paper.rkt b/chat-os2-paper.rkt
index 9984c70..d66881f 100644
--- a/chat-os2-paper.rkt
+++ b/chat-os2-paper.rkt
@@ -12,13 +12,13 @@
 ;;---------------------------------------------------------------------------
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(define listener-proc
- (transition 'no-state
-  (at-meta-level
-   (role (tcp-listener 5999)
-    #:topic t
-    #:on-presence
-     (spawn (connection-handler t))))))
+(define listener
+  (nested-vm
+   (at-meta-level
+    (role (tcp-listener 5999)
+      #:topic t
+      #:on-presence
+      (spawn (connection-handler t))))))
 
 (define (connection-handler t)
   (define me (gensym 'user))
@@ -71,7 +71,6 @@
 	    `(,me says ,line)))])))
 
 (ground-vm
- (transition 'no-state
-   (spawn tcp-driver)
-   (spawn (nested-vm listener-proc))))
+ (spawn tcp-driver)
+ (spawn listener))
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
diff --git a/chat-os2.rkt b/chat-os2.rkt
index c04038b..a985ca3 100644
--- a/chat-os2.rkt
+++ b/chat-os2.rkt
@@ -7,14 +7,12 @@
 
 (define (main)
   (ground-vm
-   (transition 'no-state
-     (spawn tcp-driver)
-     (spawn (nested-vm #:debug-name 'chat-vm
-		       (transition 'no-state
-			 (at-meta-level
-			  (role (tcp-listener 5999)
-			    #:topic t
-			    #:on-presence (spawn (connection-handler t))))))))))
+   (spawn tcp-driver)
+   (spawn (nested-vm #:debug-name 'chat-vm
+		     (at-meta-level
+		      (role (tcp-listener 5999)
+			#:topic t
+			#:on-presence (spawn (connection-handler t))))))))
 
 (define (connection-handler t)
   (match-define (topic _ (tcp-channel connection-id _ _) _) t)
diff --git a/os2-nested-example.rkt b/os2-nested-example.rkt
index 23ada89..9c0a379 100644
--- a/os2-nested-example.rkt
+++ b/os2-nested-example.rkt
@@ -36,10 +36,9 @@
 	       (spawn (spy 'ground-spy))
 	       (when event-at-ground? (eventing-process 'ground-level-eventing-process))
 	       (spawn (nested-vm #:debug-name (debug-name 'nested-vm)
-				 (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))))
+				 (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)))))
diff --git a/os2.rkt b/os2.rkt
index ceb9ec1..3fffd5e 100644
--- a/os2.rkt
+++ b/os2.rkt
@@ -429,6 +429,12 @@
 ;;---------------------------------------------------------------------------
 ;; Core virtualizable virtual machine.
 
+(define (vm-boot-parameters->boot-specification params)
+  (match params
+    [(list (? transition? t)) t]
+    [(list (? procedure? p)) p]
+    [(? list? actions) (transition (void) actions)]))
+
 (define (make-vm name boot)
   (vm name
       (hash)
@@ -761,19 +767,19 @@
       [(_ (~or (~optional (~seq #:debug-name debug-name) #:name "#:debug-name of nested-vm")
 	       (~optional (~seq #:pid pid) #:name "#:pid variable name"))
 	  ...
-	  boot-expr)
+	  boot-param ...)
        #`(nested-vm-proc #,(if (attribute debug-name)
 			       #'debug-name
 			       #'(gensym 'nested-vm))
 			 (lambda (#,(if (attribute pid) #'pid #'dummy-pid))
-			   boot-expr))])))
+			   (vm-boot-parameters->boot-specification (list boot-param ...))))])))
 
 (define (nested-vm-proc name boot)
   (boot-specification (lambda (self-pid) (run-vm (make-vm name boot)))
 		      vm?))
 
-(define (ground-vm boot)
-  (let loop ((state (make-vm 'ground-vm boot)))
+(define (ground-vm . boot-params)
+  (let loop ((state (make-vm 'ground-vm (vm-boot-parameters->boot-specification boot-params))))
     (match (let ((t (run-vm state))) (set! current-ground-transition t) t)
       [(transition state actions)
        (define is-blocking?