(define-type TOY
[Num (n number?)]
[Id (name symbol?)]
[Bind (names unique-names?)
(exprs (list-of TOY?))
(body (list-of TOY?))]
[BindRec (names unique-names?)
(exprs (list-of TOY?))
(body (list-of TOY?))]
[Fun (names unique-names?) (body (list-of TOY?))]
[RFun (names unique-names?) (body (list-of TOY?))]
[Call (fun-expr TOY?) (arg-exprs (list-of TOY?))]
[If (cond-expr TOY?) (then-expr TOY?) (else-expr TOY?)]
[Set (id symbol?) (expr TOY?)])
(define (unique-list? xs)
(or (null? xs)
(and (not (member (first xs) (rest xs)))
(unique-list? (rest xs)))))
(define unique-names?
(intersection-of (list-of symbol?) unique-list?))
(define (parse-sexpr sexpr)
(match sexpr
[(number: n) (Num n)]
[(symbol: name) (Id name)]
[(cons (or 'bind 'bindrec) more)
(match sexpr
[(list binder (list (list (symbol: names) nameds) ...) body)
(let ([binder (if (eq? 'bind binder) Bind BindRec)])
(binder names (map parse-sexpr nameds) (parse-sexpr body)))]
[(cons binder more)
(error 'parse-sexpr "bad `~s' syntax in ~s" binder sexpr)])]
[(cons (or 'fun 'rfun) more)
(match sexpr
[(list funer (list (symbol: names) ...) body)
(let ([funer (if (eq? 'fun funer) Fun RFun)])
(funer names (parse-sexpr body)))]
[(cons funer more)
(error 'parse-sexpr "bad `~s' syntax in ~s" funer sexpr)])]
[(cons 'if more)
(match sexpr
[(list 'if cond then else)
(If (parse-sexpr cond) (parse-sexpr then) (parse-sexpr else))]
[else (error 'parse-sexpr "bad `if' syntax in ~s" sexpr)])]
[(cons 'set! more)
(match sexpr
[(list 'set! (symbol: name) value)
(Set name (parse-sexpr value))]
[else (error 'parse-sexpr "bad `set!' syntax in ~s" sexpr)])]
[(list fun args ...) (Call (parse-sexpr fun)
(map parse-sexpr args))]
[else (error 'parse-sexpr "bad syntax in ~s" sexpr)]))
(define (parse str)
(parse-sexpr (string->sexpr str)))
(define ENV? (list-of vector?))
(define-type VAL
[BogusV] [ScmV (x any?)]
[FunV (arity integer?) (body procedure?) (env ENV?)]
[RFunV (arity integer?) (body procedure?) (env ENV?)]
[PrimV (prim procedure?)])
(define bogus (BogusV))
(define (extend-boxes boxes env)
(cons (list->vector boxes) env))
(define (extend values env)
(extend-boxes (map box values) env))
(define (extend-rec compiled-exprs env)
(let* ([new-cells (map (lambda (x) (box bogus)) compiled-exprs)]
[new-env (cons (list->vector new-cells) env)]
[values (map (lambda (c) (c new-env)) compiled-exprs)])
(for-each (lambda (cell val) (set-box! cell val))
new-cells values)
new-env))
(define (find-variable-index name bindings)
(define (find-in-frame frame n)
(cond [(null? frame) #f]
[(eq? name (car frame)) n]
[else (find-in-frame (cdr frame) (+ n 1))]))
(define (find-in-env env n)
(if (null? env)
#f
(let ([m (find-in-frame (car env) 0)])
(if m
(list n m)
(find-in-env (cdr env) (+ n 1))))))
(find-in-env bindings 0))
(test (find-variable-index 'x '((a b c) (a b x c) (x)))
=> '(1 2))
(test (find-variable-index 'y '((a b c) (a b x c) (x)))
=> #f)
(define (lookup/idx idx env)
(vector-ref (list-ref env (first idx)) (second idx)))
(define (scheme-func->prim-val scheme-func)
(PrimV (lambda (args)
(let ([args (map (lambda (a)
(cases a
[(ScmV v) v]
[else (error 'scheme-func
"bad input: ~s" a)]))
args)])
(ScmV (apply scheme-func args))))))
(define global-mapping
(list (list '+ (scheme-func->prim-val +))
(list '- (scheme-func->prim-val -))
(list '* (scheme-func->prim-val *))
(list '/ (scheme-func->prim-val /))
(list '< (scheme-func->prim-val <))
(list '> (scheme-func->prim-val >))
(list '= (scheme-func->prim-val =))
(list 'list (scheme-func->prim-val list))
(list 'true (box (ScmV #t)))
(list 'false (box (ScmV #f)))))
(define compiler-enabled? (box #f))
(define (compile-body exprs bindings)
(unless (unbox compiler-enabled?)
(error 'compile "compiler disabled"))
(if (null? exprs)
(error 'compile-body "got an empty body")
(let ([compiled-first (compile (first exprs) bindings)]
[other-exprs (rest exprs)])
(if (null? other-exprs)
compiled-first
(let ([compiled-rest (compile-body other-exprs bindings)])
(lambda (env)
(compiled-first env)
(compiled-rest env)))))))
(define (compile-fun make-closure names body bindings)
(let ([compiled-body (compile-body body (cons names bindings))]
[arity (if (unique-names? names)
(length names)
(error 'compile-fun "expects unique names"))])
(lambda (env)
(make-closure arity compiled-body env))))
(define (compile expr bindings)
(define (compile* expr) (compile expr bindings)) (unless (unbox compiler-enabled?)
(error 'compile "compiler disabled"))
(cases expr
[(Num n)
(let ([v (ScmV n)])
(lambda (env) v))]
[(Id v)
(let ([idx (find-variable-index v bindings)])
(if idx
(lambda (env) (unbox (lookup/idx idx env)))
(let ([cell (assq v global-mapping)])
(if cell
(let ([val (second cell)])
(lambda (env) val))
(error 'compile "free variable name: ~s" name)))))]
[(Set id expr)
(let ([compiled-expr (compile* expr)]
[idx (find-variable-index id bindings)])
(if idx
(lambda (env)
(set-box! (lookup/idx idx env) (compiled-expr env))
bogus)
(error 'compile
"cannot mutate global or inexistent: ~s" id)))]
[(Bind names exprs bound-body)
(let ([compiled-exprs (map compile* exprs)] [compiled-body (compile-body bound-body
(cons names bindings))])
(lambda (env)
(compiled-body
(extend (map (lambda (c) (c env)) compiled-exprs) env))))]
[(BindRec names exprs bound-body)
(let* ([bindings (cons names bindings)]
[compile* (lambda (e) (compile e bindings))]
[compiled-exprs (map compile* exprs)]
[compiled-body (compile-body bound-body bindings)])
(lambda (env)
(compiled-body (extend-rec compiled-exprs env))))]
[(Fun names bound-body)
(compile-fun FunV names bound-body bindings)]
[(RFun names bound-body)
(compile-fun RFunV names bound-body bindings)]
[(Call fun-expr arg-exprs)
(let ([compiled-fun-expr (compile* fun-expr)]
[args-num (length arg-exprs)]
[compiled-args (map compile* arg-exprs)]
[id-arg-idxs
(and (andmap Id? arg-exprs)
(map (lambda (e)
(find-variable-index (Id-name e) bindings))
arg-exprs))])
(lambda (env)
(let ([fval (compiled-fun-expr env)]
[arg-vals (lambda ()
(map (lambda (c) (c env)) compiled-args))])
(cases fval
[(PrimV proc) (proc (arg-vals))]
[(FunV arity compiled-body fun-env)
(if (= arity args-num)
(compiled-body (extend (arg-vals) fun-env))
(error 'call "arity mismatch in function call"))]
[(RFunV arity compiled-body fun-env)
(cond
[(not (= arity args-num))
(error 'call "arity mismatch in rfunction call")]
[id-arg-idxs
(let ([boxes (map (lambda (idx) (lookup/idx idx env))
id-arg-idxs)])
(compiled-body (extend-boxes boxes fun-env)))]
[else
(error 'eval
"ref-functions expect only identifiers")])]
[else (error 'compile
"function call with a non-function: ~s"
fval)]))))]
[(If cond-expr then-expr else-expr)
(let ([compiled-cond-expr (compile* cond-expr)]
[compiled-then-expr (compile* then-expr)]
[compiled-else-expr (compile* else-expr)])
(lambda (env)
((if (cases (compiled-cond-expr env)
[(ScmV v) v] [else #t]) compiled-then-expr
compiled-else-expr)
env)))]))
(define (run str)
(set-box! compiler-enabled? #t)
(let ([compiled (compile (parse str) '())])
(set-box! compiler-enabled? #f)
(let ([result (compiled '())])
(cases result
[(ScmV v) v]
[else (error 'run
"evaluation returned a bad value: ~s"
result)]))))
(test (run "{{fun {x} {+ x 1}} 4}")
=> 5)
(test (run "{bind {{add3 {fun {x} {+ x 3}}}} {add3 1}}")
=> 4)
(test (run "{bind {{add3 {fun {x} {+ x 3}}}
{add1 {fun {x} {+ x 1}}}}
{bind {{x 3}} {add1 {add3 x}}}}")
=> 7)
(test (run "{bind {{identity {fun {x} x}}
{foo {fun {x} {+ x 1}}}}
{{identity foo} 123}}")
=> 124)
(test (run "{bind {{x 3}}
{bind {{f {fun {y} {+ x y}}}}
{bind {{x 5}}
{f 4}}}}")
=> 7)
(test (run "{{{fun {x} {x 1}}
{fun {x} {fun {y} {+ x y}}}}
123}")
=> 124)
(test (run "{bind {{x 123}}
{bind {{y {set! x {+ x 1}}}}
x}}")
=> 124)
(test (run "{bindrec {{fact {fun {n}
{if {= 0 n}
1
{* n {fact {- n 1}}}}}}}
{fact 5}}")
=> 120)
(test (run "{bind {{make-counter
{fun {}
{bind {{c 0}}
{fun {}
{set! c {+ 1 c}}
c}}}}}
{bind {{c1 {make-counter}}
{c2 {make-counter}}}
{* {c1} {c1} {c2} {c1}}}}")
=> 6)
(test (run "{bindrec {{foo {fun {}
{set! foo {fun {} 2}}
1}}}
{+ {foo} {* 10 {foo}}}}")
=> 21)
(test (run "{bind {{swap! {rfun {x y}
{bind {{tmp x}}
{set! x y}
{set! y tmp}}}}
{a 1}
{b 2}}
{swap! a b}
{+ a {* 10 b}}}")
=> 12)