syndicate-lang
/
racket-dns-2012
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Split example into beginnings of stdlib

This commit is contained in:
Tony Garnock-Jones 2012-01-11 17:07:13 -05:00
parent 9f3003fc40
commit e8e87e338d
3 changed files with 132 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

75
os-userland-example.rkt
View File

@ -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)

121
os-userland-stdlib.rkt Normal file
View File

@ -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)))))

16
os-userland.rkt
View File

@ -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)