(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)
(map 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 (map 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-type ENV
[EmptyEnv]
[FrameEnv (frame frame?) (rest ENV?)])
(define-type VAL
[BogusV] [ScmV (x any?)]
[FunV (names unique-names?) (body (list-of TOY?)) (env ENV?)]
[RFunV (names unique-names?) (body (list-of TOY?)) (env ENV?)]
[PrimV (prim procedure?)])
(define bogus (BogusV))
(define frame?
(list-of (lambda (x)
(and (list? x)
(= 2 (length x))
(symbol? (first x))
((box-of VAL?) (second x))))))
(define (extend-boxes names boxes env)
(if (= (length names) (length boxes))
(FrameEnv (map list names boxes) env)
(error 'extend "arity mismatch for names: ~s" names)))
(define (extend names values env)
(extend-boxes names (map box values) env))
(define (extend-rec names exprs env)
(if (= (length names) (length exprs))
(let* ([new-cells (map (lambda (x) (box bogus)) exprs)]
[new-env (FrameEnv (map list names new-cells) env)]
[values (map (lambda (e) (eval e new-env)) exprs)])
(for-each (lambda (cell val) (set-box! cell val))
new-cells values)
new-env)
(error 'extend-rec "arity mismatch for names: ~s" names)))
(define (lookup name env)
(cases env
[(EmptyEnv) (error 'lookup "no binding for ~s" name)]
[(FrameEnv frame rest)
(let ([cell (assq name frame)])
(if cell
(second cell)
(lookup name rest)))]))
(define (scheme-func->prim-val scheme-func)
(box (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-environment
(FrameEnv (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))))
(EmptyEnv)))
(define (eval-body exprs env)
(if (null? exprs)
(error 'eval-body "got an empty body")
(let ([1st-value (eval (first exprs) env)]
[other-exprs (rest exprs)])
(if (null? other-exprs)
1st-value
(eval-body other-exprs env)))))
(define (eval expr env)
(cases expr
[(Num n) (ScmV n)]
[(Id v) (unbox (lookup v env))]
[(Bind names exprs bound-body)
(eval-body bound-body
(extend names
(map (lambda (e) (eval e env)) exprs)
env))]
[(BindRec names exprs bound-body)
(eval-body bound-body (extend-rec names exprs env))]
[(Fun names bound-body)
(FunV names bound-body env)]
[(RFun names bound-body)
(RFunV names bound-body env)]
[(Call fun-expr arg-exprs)
(let ([fval (eval fun-expr env)]
[arg-vals (lambda ()
(map (lambda (e) (eval e env)) arg-exprs))])
(cases fval
[(PrimV proc) (proc (arg-vals))]
[(FunV names body fun-env)
(eval-body body (extend names (arg-vals) fun-env))]
[(RFunV names body fun-env)
(if (andmap Id? arg-exprs)
(let ([boxes (map (lambda (id) (lookup (Id-name id) env))
arg-exprs)])
(eval-body body (extend-boxes names boxes fun-env)))
(error 'eval "ref-functions expect only identifiers"))]
[else (error 'eval "function call with a non-function: ~s"
fval)]))]
[(If cond-expr then-expr else-expr)
(eval (if (cases (eval cond-expr env)
[(ScmV v) v] [else #t]) then-expr
else-expr)
env)]
[(Set id expr)
(set-box! (lookup id env) (eval expr env))
bogus]))
(define (run str)
(let ([result (eval (parse str) global-environment)])
(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)
(test (run "{bind 1 2}") =error> "bad `bind' syntax")
(test (run "{fun 1 2}") =error> "bad `fun' syntax")
(test (run "{if 1 2}") =error> "bad `if' syntax")
(test (run "{set! 1 2}") =error> "bad `set!' syntax")
(test (run "{}") =error> "bad syntax")
(test (run "x") =error> "no binding for x")
(test (run "{bind {}}") =error> "got an empty body")
(test (run "{1 2}") =error> "function call with a non-function")
(test (run "{+ {fun {x} x} 1}") =error> "bad input")
(test (run "{fun {x} x}") =error> "evaluation returned a bad value")
(test (run "{{rfun {x} x} 1}") =error> "ref-functions expect only")
(test (run "{bind {{x 1}} {{rfun {y} y}}}") =error> "arity mismatch")
(test (run "{if {fun {x} x} 1 2}") => 1)
(test (extend-rec '(x) '() (EmptyEnv)) =error> "arity mismatch for")