#lang plai-typed (require plai-typed/s-exp-match (typed-in racket/base [gensym : (-> symbol)])) (define-type Value [numV (n : number)] [closV (arg : symbol) (body : ExprC) (env : Env)] [listV (l : (listof Value))] [symV (s : symbol)]) (define-type ExprC [numC (n : number)] [idC (s : symbol)] [plusC (l : ExprC) (r : ExprC)] [multC (l : ExprC) (r : ExprC)] [lamC (n : symbol) (body : ExprC)] [appC (fun : ExprC) (arg : ExprC)] [if0C (tst : ExprC) (thn : ExprC) (els : ExprC)] [quoteC (s-exp : s-expression)] [consC (fst : ExprC) (rst : ExprC)] [firstC (lst : ExprC)] [restC (lst : ExprC)] [empty?C (arg : ExprC)] [cons?C (arg : ExprC)] [symbol?C (arg : ExprC)] [number?C (arg : ExprC)] [symbol=?C (l : ExprC) (r : ExprC)] [gensymC]) (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 true)) ;; parse ---------------------------------------- (define (parse* [s : s-expression] [env : Env]) : ExprC (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) (numC (s-exp->number s))] [(s-exp-match? `SYMBOL s) (idC (s-exp->symbol s))] [(s-exp-match? '{+ ANY ANY} s) (plusC (parse* (second (s-exp->list s)) env) (parse* (third (s-exp->list s)) env))] [(s-exp-match? '{* ANY ANY} s) (multC (parse* (second (s-exp->list s)) env) (parse* (third (s-exp->list s)) env))] [(s-exp-match? '{lambda {SYMBOL} ANY} s) (lamC (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) (if0C (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) (quoteC (second (s-exp->list s)))] [(s-exp-match? '{cons ANY ANY} s) (consC (parse* (second (s-exp->list s)) env) (parse* (third (s-exp->list s)) env))] [(s-exp-match? '{first ANY} s) (firstC (parse* (second (s-exp->list s)) env))] [(s-exp-match? '{rest ANY} s) (restC (parse* (second (s-exp->list s))env))] [(s-exp-match? '{empty? ANY} s) (empty?C (parse* (second (s-exp->list s)) env))] [(s-exp-match? '{cons? ANY} s) (cons?C (parse* (second (s-exp->list s)) env))] [(s-exp-match? '{symbol? ANY} s) (symbol?C (parse* (second (s-exp->list s)) env))] [(s-exp-match? '{number? ANY} s) (number?C (parse* (second (s-exp->list s)) env))] [(s-exp-match? '{symbol=? ANY ANY} s) (symbol=?C (parse* (second (s-exp->list s)) env) (parse* (third (s-exp->list s)) env))] [(s-exp-match? '{gensym} s) (gensymC)] [(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) (appC (parse* rator env) (parse* (second (s-exp->list s)) env)) (error 'parse "invalid input")))))] [else (error 'parse "invalid input")])) (define (parse [s : s-expression]) : ExprC (parse* s mt-env)) (module+ test (test (parse '2) (numC 2)) (test (parse `x) ; note: backquote instead of normal quote (idC 'x)) (test (parse '{+ 2 1}) (plusC (numC 2) (numC 1))) (test (parse '{* 3 4}) (multC (numC 3) (numC 4))) (test (parse '{+ {* 3 4} 8}) (plusC (multC (numC 3) (numC 4)) (numC 8))) (test (parse '{lambda {x} 9}) (lamC 'x (numC 9))) (test (parse '{double 9}) (appC (idC 'double) (numC 9))) (test (parse '{if0 1 2 3}) (if0C (numC 1) (numC 2) (numC 3))) (test (parse ''(1 x)) (quoteC '(1 x))) (test (parse '{cons 1 2}) (consC (numC 1) (numC 2))) (test (parse '{first 1}) (firstC (numC 1))) (test (parse '{rest 1}) (restC (numC 1))) (test (parse '{empty? 1}) (empty?C (numC 1))) (test (parse '{cons? 1}) (cons?C (numC 1))) (test (parse '{symbol? 1}) (symbol?C (numC 1))) (test (parse '{number? 1}) (number?C (numC 1))) (test (parse '{symbol=? 1 2}) (symbol=?C (numC 1) (numC 2))) (test (parse '{gensym}) (gensymC)) (test/exn (parse '{{+ 1 2}}) "invalid input") (test/exn (parse '{}) "invalid input") (test (parse '{let-macro {[m {lambda {s} 10}]} {m}}) (numC 10))) ;; apply-macro ---------------------------------------- (define (apply-macro [transformer : Value] [s : s-expression]) : s-expression (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 (consC (idC 'a) (quoteC '{})) mt-env) '{1 2}) '{{1 2}}) (test/exn (apply-macro (numV 1) '{1 2}) "not a function")) ;; interp ---------------------------------------- (define (interp [a : ExprC] [env : Env]) : Value (type-case ExprC a [numC (n) (numV n)] [idC (s) (lookup s env)] [plusC (l r) (num+ (interp l env) (interp r env))] [multC (l r) (num* (interp l env) (interp r env))] [lamC (n body) (closV n body env)] [appC (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")])] [if0C (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")])] [quoteC (s-exp) (s-exp->value s-exp)] [consC (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")]))] [firstC (lst) (type-case Value (interp lst env) [listV (l) (if (empty? l) (error 'interp "empty list") (first l))] [else (error 'interp "not a list")])] [restC (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?C (lst) (type-case Value (interp lst env) [listV (l) (numV (if (empty? l) 0 1))] [else (numV 1)])] [cons?C (lst) (type-case Value (interp lst env) [listV (l) (numV (if (empty? l) 1 0))] [else (numV 1)])] [symbol?C (lst) (type-case Value (interp lst env) [symV (s) (numV 0)] [else (numV 1)])] [number?C (lst) (type-case Value (interp lst env) [numV (n) (numV 0)] [else (numV 1)])] [symbol=?C (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")])] [gensymC () (symV (gensym))])) (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 (plusC (idC 'x) (idC '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-expression (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 (idC 'a) mt-env)) "cannot convert")) ;; s-exp->value ---------------------------------------- (define (s-exp->value [s : s-expression]) (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]) : 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 (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)) (test (interp (parse (add-let '{let-macro {[delay {lambda {s} {cons 'lambda {cons {cons {gensym} '{}} {cons {first {rest s}} '{}}}}}]} {let-macro {[force {lambda {s} {cons {first {rest s}} '{0}}}]} {let {[dummy 8]} {force {delay dummy}}}}})) mt-env) (numV 8)) (test (interp (parse (add-let `{let-macro {[case {lambda {s} ,(add-let `{let {[tmp {gensym}]} {cons 'let {cons {cons {cons tmp {cons {first {rest s}} '{}}} '{}} {cons {if0 {if0 {symbol? {first {first {rest {rest s}}}}} {symbol=? 'else {first {first {rest {rest s}}}}} 1} {first {rest {first {rest {rest s}}}}} {cons 'if0 {cons {cons '+ {cons tmp {cons {* -1 {first {first {first {rest {rest s}}}}}} '{}}}} {cons {first {rest {first {rest {rest s}}}}} {cons {cons 'case {cons tmp {rest {rest {rest s}}}}} '{}}}}}} '{}}}}})}]} {let {[f {lambda {n} {case n [{1} 10] [{2} 100] [else 1]}}]} {+ {+ {f 1} {f 2}} {* -1 {f 3}}}}})) mt-env) (numV 109)))