diff --git a/13-bang/main.rkt b/13-bang/main.rkt index 9813f22..362b74b 100644 --- a/13-bang/main.rkt +++ b/13-bang/main.rkt @@ -10,6 +10,7 @@ | { bind {{ } ... } ... } | { bindrec {{ } ... } ... } | { fun { ... } ... } + | { rfun { ... } ... } | { ... } | { if } | { set! } @@ -22,6 +23,7 @@ [Bind (Listof Symbol) (Listof TOY) (Listof TOY)] [Bindrec (Listof Symbol) (Listof TOY) (Listof TOY)] [Fun (Listof Symbol) (Listof TOY)] + [Rfun (Listof Symbol) (Listof TOY)] [Call TOY (Listof TOY)] [If TOY TOY TOY] [Set Symbol TOY]) @@ -49,24 +51,26 @@ (match sexpr [(list b (list (list (symbol: names) (sexpr: nameds)) ...) body ...) (if (not (null? body)) - (if (unique-list? names) - ((if (symbol=? b 'bind) Bind Bindrec) - names - (map parse-sexpr nameds) - (last (map parse-sexpr body))) - (error 'parse-sexpr "duplicate `~s' names: ~s" binder names)) - (error 'parse-sexpr "bind expression missing body: ~s" sexpr))] + (if (unique-list? names) + ((if (symbol=? b 'bind) Bind Bindrec) + names + (map parse-sexpr nameds) + (map parse-sexpr body)) + (error 'parse-sexpr "duplicate `~s' names: ~s" binder names)) + (error 'parse-sexpr "bind expression missing body: ~s" sexpr))] [else (error 'parse-sexpr "bad `~s' syntax in ~s" binder sexpr)])] - ; Function definition. - [(cons 'fun more) + ; Reference function definition. + [(cons (and funer (or 'fun 'rfun)) more) (match sexpr - [(list 'fun (list (symbol: names) ...) body) - (if (unique-list? names) - (Fun names (parse-sexpr body)) - (error 'parse-sexpr "duplicate `fun' names: ~s" names))] - [else (error 'parse-sexpr "bad `fun' syntax in ~s" sexpr)])] - + [(list f (list (symbol: parameters) ...) body ...) + (if (not (null? body)) + (if (unique-list? parameters) + ((if (symbol=? f 'fun) Fun Rfun) parameters (map parse-sexpr body)) + (error 'parse-sexpr "bad parameters defined for function in ~s" sexpr)) + (error 'parse-sexpr "disemobodied function in ~s" sexpr))] + [else (error 'parse-sexpr "bad function syntax in ~s" sexpr)])] + ; Conditional. [(cons 'if more) (match sexpr @@ -107,7 +111,8 @@ (define-type VAL [RktV Any] - [FunV (Listof Symbol) TOY ENV] + ; Parameters, body expressions, whether it's an Rfun, environment. + [FunV (Listof Symbol) (Listof TOY) Boolean ENV] [PrimV ((Listof VAL) -> VAL)] [VoidV]) @@ -133,8 +138,6 @@ names vals) newenv) - - (: lookup : Symbol ENV -> (Boxof VAL)) ;; lookup a symbol in an environment, frame by frame, ;; return its value or throw an error if it isn't bound @@ -164,7 +167,7 @@ (define (racket-func->prim-val racket-func) (define list-func (make-untyped-list-function racket-func)) (box (PrimV (lambda (args) - (RktV (list-func (map unwrap-rktv args))))))) + (RktV (list-func (map unwrap-rktv args))))))) ;; The global environment has a few primitives: (: global-environment : ENV) @@ -195,18 +198,20 @@ [(Num n) (RktV n)] [(Id name) (unbox (lookup name env))] [(Bind names exprs bound-body) - (eval bound-body (extend names (map eval* exprs) env))] + (eval-body bound-body (extend names (map eval* exprs) env))] [(Bindrec names exprs bound-body) - (eval bound-body (extend-rec names exprs env))] + (eval-body bound-body (extend-rec names exprs env))] [(Fun names bound-body) - (FunV names bound-body env)] + (FunV names bound-body #f env)] + [(Rfun names bound-body) + (FunV names bound-body #t env)] [(Call fun-expr arg-exprs) (let ([fval (eval* fun-expr)] [arg-vals (map eval* arg-exprs)]) (cases fval [(PrimV proc) (proc arg-vals)] - [(FunV names body fun-env) - (eval body (extend names arg-vals fun-env))] + [(FunV names body ref? fun-env) + (if ref? (eval-rfun names arg-exprs body fun-env) (eval-body body (extend names arg-vals fun-env)))] [else (error 'eval "function call with a non-function: ~s" fval)]))] [(If cond-expr then-expr else-expr) @@ -219,6 +224,25 @@ (set-box! (lookup thing env) (eval* as)) ; We are not a lazy language. (VoidV)])) +(: eval-rfun : (Listof Symbol) (Listof TOY) (Listof TOY) ENV -> VAL) +(define (eval-rfun params args body env) + (eval-body body (raw-extend params (get-boxes args env) env))) + +(: get-boxes : (Listof TOY) ENV -> (Listof (Boxof VAL))) +(define (get-boxes ids env) + (: boxes (Listof (Boxof VAL))) + (define boxes '()) + (for-each (lambda ([id : TOY]) + (cases id + [(Id name) (set! boxes (cons (lookup name env) boxes))] + [else (error 'get-boxes "non-identifier")])) ids) + boxes) + +(: eval-body : (Listof TOY) ENV -> VAL) +; Evaluates a body of expressions, returning the result of the last. +(define (eval-body exprs env) + (list-ref (map (lambda ([expr : TOY]) (eval expr env)) exprs) (sub1 (length exprs)))) + (: run : String -> Any) ;; evaluate a TOY program contained in a string (define (run str) @@ -230,6 +254,46 @@ ;;; ---------------------------------------------------------------- ;;; Tests +(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 {{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 "{bindrec {{fact {fun {n} {if {= 0 n} @@ -237,7 +301,7 @@ {* n {fact {- n 1}}}}}}} {fact 5}}") -=> 120) + => 120) (test (run " {bind {{x 10}}