#lang plait (define-type Value (numV [n : Number]) (closV [arg : Symbol] [body : Exp] [env : Env]) (listV [l : (Listof Value)]) (symV [s : Symbol])) (define-type Exp (numE [n : Number]) (idE [s : Symbol]) (plusE [l : Exp] [r : Exp]) (multE [l : Exp] [r : Exp]) (lamE [n : Symbol] [body : Exp]) (appE [fun : Exp] [arg : Exp]) (if0E [tst : Exp] [thn : Exp] [els : Exp]) (quoteE [s-exp : S-Exp]) (consE [fst : Exp] [rst : Exp]) (firstE [lst : Exp]) (restE [lst : Exp]) (empty?E [arg : Exp]) (cons?E [arg : Exp]) (symbol?E [arg : Exp]) (number?E [arg : Exp]) (symbol=?E [l : Exp] [r : Exp])) (define-type Binding (bind [name : Symbol] [val : Value])) (define-type-alias Env (Listof Binding)) (define mt-env empty) (define extend-env cons) (module+ test (print-only-errors #t)) ;; parse ---------------------------------------- (define (parse* [s : S-Exp] [env : Env]) : Exp (cond [(s-exp-match? `{let-macro {[SYMBOL ANY]} ANY} s) (let ([bs (s-exp->list (first (s-exp->list (second (s-exp->list s)))))]) (parse* (third (s-exp->list s)) (extend-env (bind (s-exp->symbol (first bs)) (interp (parse (second bs)) mt-env)) env)))] [(s-exp-match? `NUMBER s) (numE (s-exp->number s))] [(s-exp-match? `SYMBOL s) (idE (s-exp->symbol s))] [(s-exp-match? `{+ ANY ANY} s) (plusE (parse* (second (s-exp->list s)) env) (parse* (third (s-exp->list s)) env))] [(s-exp-match? `{* ANY ANY} s) (multE (parse* (second (s-exp->list s)) env) (parse* (third (s-exp->list s)) env))] [(s-exp-match? `{lambda {SYMBOL} ANY} s) (lamE (s-exp->symbol (first (s-exp->list (second (s-exp->list s))))) (parse* (third (s-exp->list s)) env))] [(s-exp-match? `{if0 ANY ANY ANY} s) (if0E (parse* (second (s-exp->list s)) env) (parse* (third (s-exp->list s)) env) (parse* (fourth (s-exp->list s)) env))] [(s-exp-match? `{quote ANY} s) (quoteE (second (s-exp->list s)))] [(s-exp-match? `{cons ANY ANY} s) (consE (parse* (second (s-exp->list s)) env) (parse* (third (s-exp->list s)) env))] [(s-exp-match? `{first ANY} s) (firstE (parse* (second (s-exp->list s)) env))] [(s-exp-match? `{rest ANY} s) (restE (parse* (second (s-exp->list s))env))] [(s-exp-match? `{empty? ANY} s) (empty?E (parse* (second (s-exp->list s)) env))] [(s-exp-match? `{cons? ANY} s) (cons?E (parse* (second (s-exp->list s)) env))] [(s-exp-match? `{symbol? ANY} s) (symbol?E (parse* (second (s-exp->list s)) env))] [(s-exp-match? `{number? ANY} s) (number?E (parse* (second (s-exp->list s)) env))] [(s-exp-match? `{symbol=? ANY ANY} s) (symbol=?E (parse* (second (s-exp->list s)) env) (parse* (third (s-exp->list s)) env))] [(s-exp-match? `{ANY ANY ...} s) (let ([rator (first (s-exp->list s))]) (try (parse* (apply-macro (lookup (s-exp->symbol rator) env) s) env) (lambda () (if (= (length (s-exp->list s)) 2) (appE (parse* rator env) (parse* (second (s-exp->list s)) env)) (error 'parse "invalid input")))))] [else (error 'parse "invalid input")])) (define (parse [s : S-Exp]) : Exp (parse* s mt-env)) (module+ test (test (parse `2) (numE 2)) (test (parse `x) (idE 'x)) (test (parse `{+ 2 1}) (plusE (numE 2) (numE 1))) (test (parse `{* 3 4}) (multE (numE 3) (numE 4))) (test (parse `{+ {* 3 4} 8}) (plusE (multE (numE 3) (numE 4)) (numE 8))) (test (parse `{lambda {x} 9}) (lamE 'x (numE 9))) (test (parse `{double 9}) (appE (idE 'double) (numE 9))) (test (parse `{if0 1 2 3}) (if0E (numE 1) (numE 2) (numE 3))) (test (parse `'(1 x)) (quoteE `(1 x))) (test (parse `{cons 1 2}) (consE (numE 1) (numE 2))) (test (parse `{first 1}) (firstE (numE 1))) (test (parse `{rest 1}) (restE (numE 1))) (test (parse `{empty? 1}) (empty?E (numE 1))) (test (parse `{cons? 1}) (cons?E (numE 1))) (test (parse `{symbol? 1}) (symbol?E (numE 1))) (test (parse `{number? 1}) (number?E (numE 1))) (test (parse `{symbol=? 1 2}) (symbol=?E (numE 1) (numE 2))) (test/exn (parse `{{+ 1 2}}) "invalid input") (test/exn (parse `{}) "invalid input") (test (parse `{let-macro {[m {lambda {s} 10}]} {m}}) (numE 10))) ;; apply-macro ---------------------------------------- (define (apply-macro [transformer : Value] [s : S-Exp]) : S-Exp (type-case Value transformer [(closV arg body env) (value->s-exp (interp body (extend-env (bind arg (s-exp->value s)) env)))] [else (error 'apply-macro "not a function")])) (module+ test (test (apply-macro (closV 'a (consE (idE 'a) (quoteE `{})) mt-env) `{1 2}) `{{1 2}}) (test/exn (apply-macro (numV 1) `{1 2}) "not a function")) ;; interp ---------------------------------------- (define (interp [a : Exp] [env : Env]) : Value (type-case Exp a [(numE n) (numV n)] [(idE s) (lookup s env)] [(plusE l r) (num+ (interp l env) (interp r env))] [(multE l r) (num* (interp l env) (interp r env))] [(lamE n body) (closV n body env)] [(appE fun arg) (type-case Value (interp fun env) [(closV n body c-env) (interp body (extend-env (bind n (interp arg env)) c-env))] [else (error 'interp "not a function")])] [(if0E tst thn els) (type-case Value (interp tst env) [(numV n) (if (zero? n) (interp thn env) (interp els env))] [else (error 'interp "not a number")])] [(quoteE s-exp) (s-exp->value s-exp)] [(consE fst rst) (local [(define fst-v (interp fst env)) (define rst-v (interp rst env))] (type-case Value rst-v [(listV l) (listV (cons fst-v l))] [else (error 'interp "not a list")]))] [(firstE lst) (type-case Value (interp lst env) [(listV l) (if (empty? l) (error 'interp "empty list") (first l))] [else (error 'interp "not a list")])] [(restE lst) (type-case Value (interp lst env) [(listV l) (if (empty? l) (error 'interp "empty list") (listV (rest l)))] [else (error 'interp "not a list")])] [(empty?E lst) (type-case Value (interp lst env) [(listV l) (numV (if (empty? l) 0 1))] [else (numV 1)])] [(cons?E lst) (type-case Value (interp lst env) [(listV l) (numV (if (empty? l) 1 0))] [else (numV 1)])] [(symbol?E lst) (type-case Value (interp lst env) [(symV s) (numV 0)] [else (numV 1)])] [(number?E lst) (type-case Value (interp lst env) [(numV n) (numV 0)] [else (numV 1)])] [(symbol=?E l r) (type-case Value (interp l env) [(symV l-s) (type-case Value (interp r env) [(symV r-s) (if (symbol=? l-s r-s) (numV 0) (numV 1))] [else (error 'interp "not a symbol")])] [else (error 'interp "not a symbol")])])) (module+ test (define (add-let s) `{let-macro {[let {lambda {s} {cons {cons 'lambda {cons {cons {first {first {first {rest s}}}} '{}} {cons {first {rest {rest s}}} '{}}}} {cons {first {rest {first {first {rest s}}}}} '{}}}}]} ,s}) (test (interp (parse `2) mt-env) (numV 2)) (test/exn (interp (parse `x) mt-env) "free variable") (test (interp (parse `x) (extend-env (bind 'x (numV 9)) mt-env)) (numV 9)) (test (interp (parse `{+ 2 1}) mt-env) (numV 3)) (test (interp (parse `{* 2 1}) mt-env) (numV 2)) (test (interp (parse `{+ {* 2 3} {+ 5 8}}) mt-env) (numV 19)) (test (interp (parse `{lambda {x} {+ x x}}) mt-env) (closV 'x (plusE (idE 'x) (idE 'x)) mt-env)) (test (interp (parse (add-let `{let {[x 5]} {+ x x}})) mt-env) (numV 10)) (test (interp (parse (add-let `{let {[x 5]} {let {[x {+ 1 x}]} {+ x x}}})) mt-env) (numV 12)) (test (interp (parse (add-let `{let {[x 5]} {let {[y 6]} x}})) mt-env) (numV 5)) (test (interp (parse `{{lambda {x} {+ x x}} 8}) mt-env) (numV 16)) (test/exn (interp (parse `{1 2}) mt-env) "not a function") (test/exn (interp (parse `{+ 1 {lambda {x} x}}) mt-env) "not a number") (test/exn (interp (parse (add-let `{let {[bad {lambda {x} {+ x y}}]} {let {[y 5]} {bad 2}}})) mt-env) "free variable") (test (interp (parse `{if0 0 1 2}) mt-env) (numV 1)) (test (interp (parse `{if0 3 1 2}) mt-env) (numV 2)) (test (interp (parse `'x) mt-env) (symV 'x)) (test (interp (parse `'()) mt-env) (listV empty)) (test (interp (parse `{cons 1 '{}}) mt-env) (listV (list (numV 1)))) (test (interp (parse `{first {cons 1 '{}}}) mt-env) (numV 1)) (test (interp (parse `{rest {cons 1 '{}}}) mt-env) (listV empty)) (test (interp (parse `{empty? '{}}) mt-env) (numV 0)) (test (interp (parse `{empty? {cons 1 '{}}}) mt-env) (numV 1)) (test (interp (parse `{empty? 2}) mt-env) (numV 1)) (test (interp (parse `{cons? {cons 1 '{}}}) mt-env) (numV 0)) (test (interp (parse `{cons? '{}}) mt-env) (numV 1)) (test (interp (parse `{cons? 2}) mt-env) (numV 1)) (test (interp (parse `{symbol? 'x}) mt-env) (numV 0)) (test (interp (parse `{symbol? 1}) mt-env) (numV 1)) (test (interp (parse `{number? 1}) mt-env) (numV 0)) (test (interp (parse `{number? 'x}) mt-env) (numV 1)) (test (interp (parse `{symbol=? 'x 'x}) mt-env) (numV 0)) (test (interp (parse `{symbol=? 'x 'y}) mt-env) (numV 1)) (test/exn (interp (parse `{if0 '{} 1 2}) mt-env) "not a number") (test/exn (interp (parse `{cons 1 2}) mt-env) "not a list") (test/exn (interp (parse `{first 2}) mt-env) "not a list") (test/exn (interp (parse `{rest 2}) mt-env) "not a list") (test/exn (interp (parse `{first '{}}) mt-env) "empty list") (test/exn (interp (parse `{rest '{}}) mt-env) "empty list") (test/exn (interp (parse `{symbol=? 1 'x}) mt-env) "not a symbol") (test/exn (interp (parse `{symbol=? 'x 1}) mt-env) "not a symbol")) ;; value->s-exp ---------------------------------------- (define (value->s-exp [v : Value]) : S-Exp (type-case Value v [(numV n) (number->s-exp n)] [(listV l) (list->s-exp (map value->s-exp l))] [(symV s) (symbol->s-exp s)] [else (error 'value->s-exp "cannot convert")])) (module+ test (test (value->s-exp (numV 1)) `1) (test (value->s-exp (symV 'x)) `x) (test (value->s-exp (listV (list (numV 1) (symV 'z)))) `(1 z)) (test/exn (value->s-exp (closV 'a (idE 'a) mt-env)) "cannot convert")) ;; s-exp->value ---------------------------------------- (define (s-exp->value [s : S-Exp]) (cond [(s-exp-number? s) (numV (s-exp->number s))] [(s-exp-symbol? s) (symV (s-exp->symbol s))] [(s-exp-list? s) (listV (map s-exp->value (s-exp->list s)))] [else (error 's-exp->value "cannot convert")])) (module+ test (test (s-exp->value `1) (numV 1)) (test (s-exp->value `x) (symV 'x)) (test (s-exp->value `(1 z)) (listV (list (numV 1) (symV 'z)))) (test (s-exp->value `()) (listV empty)) (test (s-exp->value `(1 (z z))) (listV (list (numV 1) (listV (list (symV 'z) (symV 'z)))))) (test/exn (s-exp->value `"string") "cannot convert")) ;; num+ and num* ---------------------------------------- (define (num-op [op : (Number Number -> Number)] [l : Value] [r : Value]) (cond [(and (numV? l) (numV? r)) (numV (op (numV-n l) (numV-n r)))] [else (error 'interp "not a number")])) (define (num+ [l : Value] [r : Value]) : Value (num-op + l r)) (define (num* [l : Value] [r : Value]) : Value (num-op * l r)) (module+ test (test (num+ (numV 1) (numV 2)) (numV 3)) (test (num* (numV 2) (numV 3)) (numV 6))) ;; lookup ---------------------------------------- (define (lookup [n : Symbol] [env : Env]) : Value (cond [(empty? env) (error 'lookup "free variable")] [else (cond [(symbol=? n (bind-name (first env))) (bind-val (first env))] [else (lookup n (rest env))])])) (module+ test (test/exn (lookup 'x mt-env) "free variable") (test (lookup 'x (extend-env (bind 'x (numV 8)) mt-env)) (numV 8)) (test (lookup 'x (extend-env (bind 'x (numV 9)) (extend-env (bind 'x (numV 8)) mt-env))) (numV 9)) (test (lookup 'y (extend-env (bind 'x (numV 9)) (extend-env (bind 'y (numV 8)) mt-env))) (numV 8))) ;; ---------------------------------------- (module+ test (test (interp (parse `{let-macro {[delay {lambda {s} {cons 'lambda {cons '{dummy} {cons {first {rest s}} '{}}}}}]} {let-macro {[force {lambda {s} {cons {first {rest s}} '{0}}}]} {force {delay 7}}}}) mt-env) (numV 7)) (test (interp (parse (add-let `{let {[mk-rec {lambda {body-proc} {let {[fX {lambda {fX} {let {[f {lambda {x} {{fX fX} x}}]} {body-proc f}}}]} {fX fX}}}]} (let {[count-xs {mk-rec {lambda {count-xs} {lambda {s} {if0 {symbol? s} {if0 {symbol=? s 'x} 1 0} {if0 {cons? s} {+ {count-xs {first s}} {count-xs {rest s}}} 0}}}}}]} {count-xs '{1 x {{x x}} {{{{{{x y z}}}}}}}})})) mt-env) (numV 4)))