135 lines
2.9 KiB
Racket
135 lines
2.9 KiB
Racket
#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/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/stdlib boot)
|
|
(ground-vm boot #:pattern-predicate (lambda (p m) (p m))))
|
|
|
|
(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 (=>)
|
|
((_ [(tag-expr evt-expr => pattern) body ...] ...)
|
|
(list (wait-clause (ground-event-pattern tag-expr evt-expr)
|
|
(match-lambda ((ground-event-value _ pattern) body ...)))
|
|
...))))
|
|
|
|
(define (rpc req)
|
|
(define reply-addr (gensym 'reply-addr)) ;;; !!! TODO: remove side-effect?
|
|
(send `(request ,reply-addr ,req))
|
|
(wait (message-handlers
|
|
[`(reply ,(== reply-addr) ,v)
|
|
v])))
|
|
|
|
(define-syntax rpc-service
|
|
(syntax-rules ()
|
|
[(_ [pattern body ...] ...)
|
|
(let loop ()
|
|
(wait (message-handlers
|
|
[`(request ,reply-addr ,pattern)
|
|
(spawn (userland (lambda ()
|
|
(define answer (let () body ...))
|
|
(send `(reply ,reply-addr ,answer)))))]
|
|
...))
|
|
(loop))]))
|
|
|
|
(define display-driver
|
|
(userland
|
|
(lambda ()
|
|
(let loop ()
|
|
(define message (wait (message-handlers [`(display ,message) message])))
|
|
(meta-send (lambda ()
|
|
(base:display message)
|
|
(flush-output)))
|
|
(loop)))))
|
|
|
|
(define (display x)
|
|
(send `(display ,x)))
|
|
|
|
(define read-line-driver
|
|
(userland
|
|
(lambda ()
|
|
(rpc-service
|
|
[`read-line (wait (message-handlers)
|
|
(meta-message-handlers
|
|
[('read-line
|
|
(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
|
|
[((list 'time-evt msecs)
|
|
(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
|
|
(userland
|
|
(lambda ()
|
|
(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)))))
|