#lang minimart
This commit is contained in:
parent
0ef6d92f09
commit
9f58657754
|
@ -0,0 +1,33 @@
|
||||||
|
#lang minimart
|
||||||
|
|
||||||
|
(require (only-in racket/port read-line-evt))
|
||||||
|
|
||||||
|
(define (r e s)
|
||||||
|
(match e
|
||||||
|
[(message body _ _) (transition s (send `(got ,body) #:meta-level 1))]
|
||||||
|
[_ #f]))
|
||||||
|
|
||||||
|
(define (b e n)
|
||||||
|
(match e
|
||||||
|
[#f (if (< n 10)
|
||||||
|
(transition (+ n 1) (send `(hello ,n)))
|
||||||
|
#f)]
|
||||||
|
[_ #f]))
|
||||||
|
|
||||||
|
(spawn-world (spawn r (void) (list (sub ?)))
|
||||||
|
(spawn b 0))
|
||||||
|
|
||||||
|
(define (spy e s)
|
||||||
|
(when e (log-info "SPY: ~v" e))
|
||||||
|
#f)
|
||||||
|
|
||||||
|
(spawn spy (void) (list (sub ? #:level 1000) (pub ? #:level 1000)))
|
||||||
|
|
||||||
|
(define (echoer e s)
|
||||||
|
(match e
|
||||||
|
[(message (event _ (list (? eof-object?))) _ _) (transition s (quit))]
|
||||||
|
[(message (event _ (list line)) _ _) (transition s (send `(got-line ,line)))]
|
||||||
|
[_ #f]))
|
||||||
|
|
||||||
|
(spawn echoer (void) (list (sub (event (read-line-evt (current-input-port) 'any) ?)
|
||||||
|
#:meta-level 1)))
|
|
@ -0,0 +1,63 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
|
(require (for-syntax racket/base))
|
||||||
|
|
||||||
|
(require racket/match)
|
||||||
|
(require "main.rkt")
|
||||||
|
|
||||||
|
(provide (rename-out [module-begin #%module-begin])
|
||||||
|
(except-out (all-from-out racket/base) #%module-begin)
|
||||||
|
(all-from-out racket/match)
|
||||||
|
(all-from-out "main.rkt")
|
||||||
|
(for-syntax (all-from-out racket/base)))
|
||||||
|
|
||||||
|
(define-syntax (module-begin stx)
|
||||||
|
(unless (eq? (syntax-local-context) 'module-begin)
|
||||||
|
(raise-syntax-error #f "allowed only around a module body" stx))
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_ forms ...)
|
||||||
|
(let ()
|
||||||
|
(define (accumulate-actions action-ids final-forms forms)
|
||||||
|
(if (null? forms)
|
||||||
|
(let ((final-stx
|
||||||
|
#`(#%module-begin #,@(reverse final-forms)
|
||||||
|
(run-ground #,@(reverse action-ids)))))
|
||||||
|
;;(pretty-print (syntax->datum final-stx))
|
||||||
|
final-stx)
|
||||||
|
(syntax-case (local-expand (car forms)
|
||||||
|
'module
|
||||||
|
(syntax->list #'(quote
|
||||||
|
quote-syntax #%top
|
||||||
|
lambda case-lambda
|
||||||
|
let-values letrec-values
|
||||||
|
begin begin0 set!
|
||||||
|
with-continuation-mark
|
||||||
|
if #%app #%expression
|
||||||
|
define-values define-syntaxes
|
||||||
|
begin-for-syntax
|
||||||
|
module module*
|
||||||
|
#%module-begin
|
||||||
|
#%require #%provide
|
||||||
|
#%variable-reference))) ()
|
||||||
|
[(head rest ...)
|
||||||
|
(if (free-identifier=? #'head #'begin)
|
||||||
|
(accumulate-actions action-ids
|
||||||
|
final-forms
|
||||||
|
(append (syntax->list #'(rest ...)) forms))
|
||||||
|
(if (ormap (lambda (i) (free-identifier=? #'head i))
|
||||||
|
(syntax->list #'(define-values define-syntaxes begin-for-syntax
|
||||||
|
module module*
|
||||||
|
#%module-begin
|
||||||
|
#%require #%provide)))
|
||||||
|
(accumulate-actions action-ids
|
||||||
|
(cons (car forms) final-forms)
|
||||||
|
(cdr forms))
|
||||||
|
(accumulate-action (car forms) action-ids final-forms (cdr forms))))]
|
||||||
|
[non-pair-syntax
|
||||||
|
(accumulate-action (car forms) action-ids final-forms (cdr forms))])))
|
||||||
|
(define (accumulate-action action action-ids final-forms remaining-forms)
|
||||||
|
(define temp (car (generate-temporaries (list action))))
|
||||||
|
(accumulate-actions (cons temp action-ids)
|
||||||
|
(cons #`(define #,temp #,action) final-forms)
|
||||||
|
remaining-forms))
|
||||||
|
(accumulate-actions '() '() (syntax->list #'(forms ...))))]))
|
|
@ -0,0 +1,2 @@
|
||||||
|
#lang s-exp syntax/module-reader
|
||||||
|
minimart/lang
|
Loading…
Reference in New Issue