79 lines
2.0 KiB
Racket
79 lines
2.0 KiB
Racket
|
#lang racket/base
|
||
|
|
|
||
|
|
(require racket/port)
|
||
|
|
(require "os.rkt")
|
||
|
|
(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 (begin 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)))
|
||
|
|
(wait (message-handlers)
|
||
|
|
(meta-message-handlers
|
||
|
|
[((time-evt (+ (current-time) msecs)) => now)
|
||
|
|
(send `(display "\n"))
|
||
|
|
now]))))
|
||
|
|
|
||
|
|
(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"))))
|
||
|
|
(poll)
|
||
|
|
(send `(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")))
|
||
|
|
|
||
|
|
(ground-vm (lambda (p m) (p m)) ;; pattern-predicate
|
||
|
|
(lambda () (userland main)))
|