From e8e87e338d69c7e7f9d1a37c679cc26c4e3cbe28 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 11 Jan 2012 17:07:13 -0500 Subject: [PATCH] Split example into beginnings of stdlib --- os-userland-example.rkt | 75 ++++--------------------- os-userland-stdlib.rkt | 121 ++++++++++++++++++++++++++++++++++++++++ os-userland.rkt | 16 ------ 3 files changed, 132 insertions(+), 80 deletions(-) create mode 100644 os-userland-stdlib.rkt diff --git a/os-userland-example.rkt b/os-userland-example.rkt index 1e1523c..8a59257 100644 --- a/os-userland-example.rkt +++ b/os-userland-example.rkt @@ -1,76 +1,23 @@ #lang racket/base -(require racket/port) -(require "os-userland.rkt") - -(define (rpc req) - (define reply-addr (gensym 'reply-addr)) ;;; !!! TODO: remove side-effect? - (send `(request ,reply-addr ,req)) - (wait (message-handlers - [`(reply ,(? (lambda (v) (eq? v reply-addr))) ,v) - v]))) - -(define-syntax rpc-service - (syntax-rules () - [(_ pattern body ...) - (let loop () - (wait (message-handlers - [`(request ,reply-addr ,pattern) - (spawn (lambda () - (define answer (let () body ...)) - (send `(reply ,reply-addr ,answer)))) - (loop)])))])) - -(define (display-driver) - (define message (wait (message-handlers [`(display ,message) message]))) - (meta-send (lambda () - (display message) - (flush-output))) - (display-driver)) - -(define (read-line-driver) - (rpc-service `read-line - (wait (message-handlers) - (meta-message-handlers - [((read-line-evt (current-input-port) 'any) => line) - line])))) - -(define (time-evt msecs) - (wrap-evt (alarm-evt msecs) (lambda (_) (current-inexact-milliseconds)))) - -(define (wait-until-time msecs) - (wait (message-handlers) - (meta-message-handlers - [((time-evt msecs) => current-time) - current-time]))) - -(define (current-time) - (wait-until-time 0)) - -(define (sleep-driver) - (rpc-service `(sleep ,msecs) - (send `(display (Sleeping ,msecs))) - (define now (wait-until-time (+ (current-time) msecs))) - (send `(display "\n")) - now)) +(require "os-userland-stdlib.rkt") (define (main) (spawn display-driver) (spawn read-line-driver) (spawn sleep-driver) (spawn (lambda () - (send `(display "HI\n")) - (rpc `(sleep 1000)) - (send `(display "THERE\n")))) + (display "HI\n") + (sleep 1000) + (display "THERE\n"))) (poll) ;; Wait for drivers to become ready (!) ;; The Right Way to do this is to have presence integrated with subscription - (send `(display "Hello! Enter your name:\n")) + (display "Hello! Enter your name:\n") (define name (rpc 'read-line)) - (send `(display "Hello, ")) - (send `(display ,name)) - (send `(display "!\n")) - (rpc `(sleep 1000)) - (send `(display "Goodbye\n"))) + (display "Hello, ") + (display name) + (display "!\n") + (sleep 1000) + (display "Goodbye\n")) -(ground-vm/userland (lambda (p m) (p m)) ;; pattern-predicate - main) +(ground-vm/userland/stdlib main) diff --git a/os-userland-stdlib.rkt b/os-userland-stdlib.rkt new file mode 100644 index 0000000..f26b071 --- /dev/null +++ b/os-userland-stdlib.rkt @@ -0,0 +1,121 @@ +#lang racket/base + +(require racket/match) +(require racket/port) +(require "os-userland.rkt") + +(require (prefix-in base: racket/base)) + +(provide (all-from-out "os-userland.rkt") + + ground-vm/userland/stdlib + + message-handlers + meta-message-handlers + + rpc + rpc-service + + display-driver + display + + read-line-driver + read-line + + current-time + sleep-driver + sleep + + receive + receive/timeout) + +(define (ground-vm/userland/stdlib boot) + (ground-vm/userland (lambda (p m) (p m)) boot)) + +(define-syntax message-handlers + (syntax-rules () + ((_ (pattern body ...) ...) + (list (wait-clause (match-lambda (pattern #t) (_ #f)) + (match-lambda (pattern body ...))) + ...)))) + +(define-syntax meta-message-handlers + (syntax-rules (=>) + ((_ [(raw-pattern => pattern) body ...] ...) + (list (wait-clause raw-pattern + (match-lambda (pattern body ...))) + ...)))) + +(define (rpc req) + (define reply-addr (gensym 'reply-addr)) ;;; !!! TODO: remove side-effect? + (send `(request ,reply-addr ,req)) + (wait (message-handlers + [`(reply ,(? (lambda (v) (eq? v reply-addr))) ,v) + v]))) + +(define-syntax rpc-service + (syntax-rules () + [(_ pattern body ...) + (let loop () + (wait (message-handlers + [`(request ,reply-addr ,pattern) + (spawn (lambda () + (define answer (let () body ...)) + (send `(reply ,reply-addr ,answer)))) + (loop)])))])) + +(define (display-driver) + (define message (wait (message-handlers [`(display ,message) message]))) + (meta-send (lambda () + (base:display message) + (flush-output))) + (display-driver)) + +(define (display x) + (send `(display ,x))) + +(define (read-line-driver) + (rpc-service `read-line + (wait (message-handlers) + (meta-message-handlers + [((read-line-evt (current-input-port) 'any) => line) + line])))) + +(define (read-line) + (rpc 'read-line)) + +(define (time-evt msecs) + (wrap-evt (alarm-evt msecs) (lambda (_) (current-inexact-milliseconds)))) + +(define (wait-mmh msecs) + (meta-message-handlers + [((time-evt msecs) => current-time) + current-time])) + +(define (wait-until-time msecs) + (wait (message-handlers) + (wait-mmh msecs))) + +(define (current-time) + (wait-until-time 0)) + +(define (sleep-driver) + (rpc-service `(sleep ,msecs) + (send `(display (Sleeping ,msecs))) + (define now (wait-until-time (+ (current-time) msecs))) + (send `(display "\n")) + now)) + +(define (sleep msecs) + (rpc `(sleep ,msecs))) + +(define-syntax receive + (syntax-rules () + ((_ mh-clause ...) + (wait (message-handlers mh-clause ...))))) + +(define-syntax receive/timeout + (syntax-rules () + ((_ timeout-msecs mh-clause ...) + (wait (message-handlers mh-clause ...) + (wait-mmh timeout-msecs))))) diff --git a/os-userland.rkt b/os-userland.rkt index e54bfc3..be45b2b 100644 --- a/os-userland.rkt +++ b/os-userland.rkt @@ -7,8 +7,6 @@ (require "os.rkt") (provide (struct-out wait-clause) - message-handlers - meta-message-handlers userland ground-vm/userland @@ -24,20 +22,6 @@ (struct wait-clause (pattern handler-proc) #:transparent) -(define-syntax message-handlers - (syntax-rules () - ((_ (pattern body ...) ...) - (list (wait-clause (match-lambda (pattern #t) (_ #f)) - (match-lambda (pattern body ...))) - ...)))) - -(define-syntax meta-message-handlers - (syntax-rules (=>) - ((_ [(raw-pattern => pattern) body ...] ...) - (list (wait-clause raw-pattern - (match-lambda (pattern body ...))) - ...)))) - (define prompt (make-continuation-prompt-tag 'os-userland)) (define (userland main)