#| |
<expr> ::= <num> |
| {+ <expr> <expr>} |
| {- <expr> <expr>} |
| {if0 <expr> <expr> <expr>} |
| {with {<sym> <expr>} <expr>} --> syntactic sugar |
| <id> |
| {<expr> <expr>} |
| {fun {<sym>} <expr>} |
| {newbox <expr>} |
| {openbox <expr>} |
| {setbox <expr> <expr>} |
| {seqn <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) |
(newbox val-expr) |
(openbox box-expr) |
(setbox box-expr val-expr) |
(seqn expr1 expr2)) |
|
;; 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 'newbox <s-expr>) |
| (list 'openbox <s-expr>) |
| (list 'setbox <s-expr> <s-expr>) |
| (list 'seqn <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 'fun (list x) b) (fun x (parse b))] |
[(list 'newbox e) (newbox (parse e))] |
[(list 'openbox e) (openbox (parse e))] |
[(list 'setbox e1 e2) (setbox (parse e1) (parse e2))] |
[(list 'seqn e1 e2) (seqn (parse e1) (parse e2))] |
[(list f a) (app (parse f) (parse a))])) |
|
;; values |
(deftype Val |
(numV n) |
(closureV id body env) |
(boxV location)) |
|
|
#|----------------------------- |
Environment abstract data type |
|
empty-env :: Env |
extend-env :: Sym Loc Env -> Env |
env-lookup :: Sym Env -> Loc |
|
representation BNF: |
<env> ::= (mtEnv) |
| (aEnv <id> <loc> <env>) |
|# |
(deftype Env |
(mtEnv) |
(aEnv id loc env)) |
|
(def empty-env (mtEnv)) |
|
(def extend-env aEnv) |
|
(define (env-lookup x env) |
(match env |
[(mtEnv) (error 'env-lookup "free identifier: ~a" x)] |
[(aEnv id loc rest) |
(if (symbol=? id x) |
loc |
(env-lookup x rest))])) |
;;;;;;; |
|
#|----------------------------- |
Store abstract data type |
|
empty-sto :: Sto |
extend-sto :: Loc Val Sto -> Sto |
sto-lookup :: Loc Sto -> Val |
|
representation BNF: |
<sto> ::= (mtSto) |
| (aSto <loc> <val> <sto>) |
<loc> ::= number |
|# |
(deftype Sto |
(mtSto) |
(aSto loc val sto)) |
|
(def empty-sto (mtSto)) |
|
(def extend-sto aSto) |
|
(define (sto-lookup l sto) |
(match sto |
[(mtSto) (error 'sto-lookup "not value at location: ~a" l)] |
[(aSto loc val rest) |
(if (= loc l) |
val |
(sto-lookup l rest))])) |
;;;;;;; |
|
(deftype Value*Store |
(v*s val sto)) |
|
;; interp :: Expr Env Sto -> Value*Store |
(define (interp expr env sto) |
(match expr |
[(num n) (v*s (numV n) sto)] |
|
[(fun id body) (v*s (closureV id body env) sto)] |
|
[(add l r) |
(def (v*s l-val l-sto) (interp l env sto)) |
(def (v*s r-val r-sto) (interp r env l-sto)) |
(v*s (num+ l-val r-val) r-sto)] |
|
[(sub l r) |
(def (v*s l-val l-sto) (interp l env sto)) |
(def (v*s r-val r-sto) (interp r env l-sto)) |
(v*s (num- l-val r-val) r-sto)] |
|
[(if0 c t f) |
(def (v*s c-val c-sto) (interp c env sto)) |
(if (num-zero? c-val) |
(interp t env c-sto) |
(interp f env c-sto))] |
|
[(id x) (v*s (sto-lookup (env-lookup x env) sto) sto)] |
|
[(app fun-expr arg-expr) |
(def (v*s (closureV id body fenv) |
fun-sto) (interp fun-expr env sto)) |
(def (v*s arg-val arg-sto) (interp arg-expr env fun-sto)) |
(def new-loc (next-location arg-sto)) |
(interp body |
(extend-env id new-loc fenv) |
(extend-sto new-loc arg-val arg-sto))] |
|
[(seqn expr1 expr2) |
(def (v*s _ sto1) (interp expr1 env sto)) |
(interp expr2 env sto1)] |
|
[(newbox val-expr) |
(def (v*s val-val val-sto) (interp val-expr env sto)) |
(def new-loc (next-location val-sto)) |
(v*s (boxV new-loc) |
(extend-sto new-loc val-val val-sto))] |
|
[(openbox box-expr) |
(def (v*s (boxV loc) box-sto) (interp box-expr env sto)) |
(v*s (sto-lookup loc box-sto) box-sto)] |
|
[(setbox box-expr val-expr) |
(def (v*s (boxV loc) box-sto) (interp box-expr env sto)) |
(def (v*s val-val val-sto) (interp val-expr env box-sto)) |
(v*s val-val |
(extend-sto loc val-val val-sto))])) |
|
(define (next-location sto) |
(match sto |
[(mtSto) 0] |
[(aSto _ _ rest) (add1 (next-location rest))])) |
|
(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 empty-sto) |
[(v*s (numV n) s) n] |
[(v*s (and b (boxV _)) s) b] |
[(v*s (and f (closureV id body env)) s) f])) |