| #| |
| <expr> ::= <num> |
| | {+ <expr> <expr>} |
| | {- <expr> <expr>} |
| | {if0 <expr> <expr> <expr>} |
| | {with {<sym> <expr>} <expr>} --> syntactic sugar |
| | <id> |
| | {<expr> <expr>} |
| | {fun {<sym>} <expr>} |
| | {rec {<sym> <expr>} <expr>} |
| |# |
| (deftype Expr |
| (num n) |
| (add l r) |
| (sub l r) |
| (if0 c t f) |
| (id s) |
| (app fun-expr arg-expr) |
| (fun id body) |
| (rec id named-expr body)) |
| |
| ;; parse :: s-expr -> Expr |
| #| where |
| <s-expr> ::= <num> |
| | <sym> |
| | (list '+ <s-expr> <s-expr>) |
| | (list '- <s-expr> <s-expr>) |
| | (list 'if0 <s-expr> <s-expr> <s-expr>) |
| | (list 'with (list <sym> <s-expr>) <s-expr>) |
| | (list 'fun (list <sym>) <s-expr>) |
| | (list 'rec (list <sym> <s-expr>) <s-expr>) |
| | (list <s-expr> <s-expr>) |
| |# |
| (define (parse s-expr) |
| (match s-expr |
| [(? number?) (num s-expr)] |
| [(? symbol?) (id s-expr)] |
| [(list '+ l r) (add (parse l) (parse r))] |
| [(list '- l r) (sub (parse l) (parse r))] |
| [(list 'if0 c t f) (if0 (parse c) |
| (parse t) |
| (parse f))] |
| [(list 'with (list x e) b) |
| (app (fun x (parse b)) (parse e))] |
| [(list 'rec (list x e) b) |
| (rec x (parse e) (parse b))] |
| [(list 'fun (list x) b) (fun x (parse b))] |
| [(list f a) (app (parse f) (parse a))])) |
| |
| ;; values |
| (deftype Val |
| (numV n) |
| (closureV id body env)) |
| |
| |
| #|----------------------------- |
| Environment abstract data type |
| (updated with recursive case) |
| |
| empty-env :: Env |
| env-lookup :: Sym Env -> Val |
| extend-env :: Sym Val Env -> Env |
| rec-extend-env :: Sym Box(Val) Env -> Env |
| |
| |# |
| (deftype Env |
| (mtEnv) |
| (aEnv id val env) |
| (aRecEnv id bval env)) |
| |
| (def empty-env (mtEnv)) |
| (def extend-env aEnv) |
| (def rec-extend-env aRecEnv) |
| |
| (define (env-lookup x env) |
| (match env |
| [(mtEnv) (error 'env-lookup "free identifier: ~a" x)] |
| [(aEnv id val rest) |
| (if (symbol=? id x) |
| val |
| (env-lookup x rest))] |
| [(aRecEnv id val rest) |
| (if (symbol=? id x) |
| (unbox val) |
| (env-lookup x rest))])) |
| ;;;;;;; |
| |
| |
| ;; interp :: Expr Env -> Val |
| (define (interp expr env) |
| (match expr |
| [(num n) (numV n)] |
| [(fun id body) (closureV id body env)] |
| [(add l r) (num+ (interp l env) (interp r env))] |
| [(sub l r) (num- (interp l env) (interp r env))] |
| [(if0 c t f) |
| (if (num-zero? (interp c env)) |
| (interp t env) |
| (interp f env))] |
| [(id x) (env-lookup x env)] |
| [(app fun-expr arg-expr) |
| (def (closureV id body fenv) (interp fun-expr env)) |
| (interp body |
| (extend-env id |
| (interp arg-expr env) |
| fenv))] |
| [(rec id named-expr body) |
| (interp body |
| (cyclic-env id named-expr env))])) |
| |
| ;; cyclic-env:: id expr env -> env (assumption: expr is a fun) |
| (define (cyclic-env id expr env) |
| (def value-holder (box 'unspecified)) |
| (def new-env (rec-extend-env id value-holder env)) |
| (def fun-val (interp expr new-env)) |
| (set-box! value-holder fun-val) |
| new-env) |
| |
| (define (num+ n1 n2) |
| (numV (+ (numV-n n1) (numV-n n2)))) |
| |
| (define (num- n1 n2) |
| (numV (- (numV-n n1) (numV-n n2)))) |
| |
| (define (num-zero? n) |
| (zero? (numV-n n))) |
| |
| ;; run :: s-expr -> number |
| (define (run prog) |
| (match (interp (parse prog) empty-env) |
| [(numV n) n] |
| [(and f (closureV id body env)) f])) |