#lang plai (define-type CFAL [num (n number?)] [add (lhs CFAL?) (rhs CFAL?)] [sub (lhs CFAL?) (rhs CFAL?)] [id (name symbol?)] [fun (param symbol?) (body CFAL?)] [app (fun-expr CFAL?) (arg-expr CFAL?)]) (define-type DefrdSub [mtSub] [aSub (name symbol?) (value CFAL-Value?) (ds DefrdSub?)]) (define-type CFAL-Value [numV (n number?)] [closureV (param symbol?) (body CFAL?) (ds DefrdSub?)] [exprV (expr CFAL?) (ds DefrdSub?) (value (box/c (or/c false CFAL-Value?)))]) ;; ---------------------------------------- ;; parse : S-expr -> FAE (define (parse sexp) (cond [(number? sexp) (num sexp)] [(symbol? sexp) (id sexp)] [(pair? sexp) (case (car sexp) [(+) (add (parse (second sexp)) (parse (third sexp)))] [(-) (sub (parse (second sexp)) (parse (third sexp)))] [(fun) (fun (first (second sexp)) (parse (third sexp)))] [else (app (parse (first sexp)) (parse (second sexp)))])])) (test (parse 3) (num 3)) (test (parse 'x) (id 'x)) (test (parse '{+ 1 2}) (add (num 1) (num 2))) (test (parse '{- 1 2}) (sub (num 1) (num 2))) (test (parse '{fun {x} x}) (fun 'x (id 'x))) (test (parse '{1 2}) (app (num 1) (num 2))) ;; ---------------------------------------- ;; interp : CFAL DefrdSub -> CFAL-Value (define (interp a-rcfae ds) (type-case CFAL a-rcfae [num (n) (numV n)] [add (l r) (num+ (interp l ds) (interp r ds))] [sub (l r) (num- (interp l ds) (interp r ds))] [id (name) (lookup name ds)] [fun (param body-expr) (closureV param body-expr ds)] [app (fun-expr arg-expr) (local [(define fun-val (strict (interp fun-expr ds)))] (interp (closureV-body fun-val) (aSub (closureV-param fun-val) (exprV arg-expr ds (box #f)) (closureV-ds fun-val))))])) ;; strict : CFAL-Value -> CFAL-Value (define (strict v) (type-case CFAL-Value v [exprV (expr ds value-box) (if (not (unbox value-box)) (local [(define v (strict (interp expr ds)))] (begin (set-box! value-box v) v)) (unbox value-box))] [else v])) ;; num-op : (number number -> number) -> (FAE-Value FAE-Value -> FAE-Value) (define (num-op op op-name x y) (numV (op (numV-n (strict x)) (numV-n (strict y))))) (define (num+ x y) (num-op + '+ x y)) (define (num- x y) (num-op - '- x y)) (define (lookup name ds) (type-case DefrdSub ds [mtSub () (error 'lookup "free variable")] [aSub (sub-name val rest-sc) (if (symbol=? sub-name name) val (lookup name rest-sc))])) (test/exn (lookup 'x (mtSub)) "free variable") (test (interp (parse 10) (mtSub)) (numV 10)) (test (interp (parse '{+ 10 17}) (mtSub)) (numV 27)) (test (interp (parse '{- 10 7}) (mtSub)) (numV 3)) (test (interp (parse '{{fun {x} {+ x 12}} {+ 1 17}}) (mtSub)) (numV 30)) (test (interp (parse 'x) (aSub 'x (numV 10) (mtSub))) (numV 10)) (test (interp (parse '{{fun {x} {{fun {f} {+ {f 1} {{fun {x} {f 2}} 3}}} {fun {y} {+ x y}}}} 0}) (mtSub)) (numV 3)) ;; Lazy evaluation: (test (interp (parse '{{fun {x} 0} {+ 1 {fun {y} y}}}) (mtSub)) (numV 0))