301 lines
8.6 KiB
Racket
301 lines
8.6 KiB
Racket
#lang plait
|
|
(define-type Exp
|
|
[numE (n : Number)]
|
|
[plusE (lhs : Exp) (rhs : Exp)]
|
|
[minusE (lhs : Exp) (rhs : Exp)] [varE (name : Symbol)]
|
|
[lamE (param : Symbol) (body : Exp)]
|
|
[appE (fun-expr : Exp) (arg-expr : Exp)]
|
|
[errorE (msg : String)] ;; New
|
|
[if0E (test : Exp) (then : Exp) (else : Exp)]
|
|
[minus1E (n : Exp)]
|
|
[timesE (lhs : Exp) (rhs : Exp)]
|
|
)
|
|
|
|
(define-type Value
|
|
[numV (n : Number)]
|
|
[errorV (msg : String)]
|
|
[funV (param : Symbol)
|
|
(body : Exp)
|
|
(env : Env)])
|
|
|
|
(define-type Env
|
|
[emptyEnv]
|
|
[Extend (name : Symbol)
|
|
(value : Value)
|
|
(rest : Env)])
|
|
|
|
(define (lookup name env)
|
|
(type-case Env env
|
|
[(emptyEnv) (error 'lookup (string-append "no binding for" (to-string name)))]
|
|
[(Extend id val rest-env)
|
|
(if (eq? id name)
|
|
val
|
|
(lookup name rest-env))]))
|
|
|
|
|
|
(define-type Continuation
|
|
[emptyCont]
|
|
[plusSecondK (r : Exp)
|
|
(env : Env)
|
|
(k : Continuation)]
|
|
[doPlusK (v1 : Value)
|
|
(k : Continuation)]
|
|
[minusSecondK (r : Exp)
|
|
(env : Env)
|
|
(k : Continuation)]
|
|
[doMinusK (v1 : Value)
|
|
(k : Continuation)]
|
|
[doMinus1K (k : Continuation)]
|
|
[timesSecondK (r : Exp)
|
|
(env : Env)
|
|
(k : Continuation)]
|
|
[doTimesK (v1 : Value)
|
|
(k : Continuation)]
|
|
[appArgK (arg-expr : Exp)
|
|
(env : Env)
|
|
(k : Continuation)]
|
|
[doAppK (fun-val : Value)
|
|
(k : Continuation)]
|
|
[doIfK (then-expr : Exp)
|
|
(else-expr : Exp)
|
|
(env : Env)
|
|
(k : Continuation)]
|
|
)
|
|
|
|
(define (parse-error sx)
|
|
(error 'parse (string-append "parse error: " (to-string sx))))
|
|
|
|
(define (sx-ref sx n) (list-ref (s-exp->list sx) n))
|
|
|
|
(define (parse sx)
|
|
(local
|
|
[(define (px i) (parse (sx-ref sx i)))]
|
|
(cond
|
|
[(s-exp-number? sx) (numE (s-exp->number sx))]
|
|
[(s-exp-symbol? sx) (varE (s-exp->symbol sx))]
|
|
[(s-exp-match? `(let1 SYMBOL ANY ANY) sx)
|
|
(let* ([id (s-exp->symbol (sx-ref sx 1))]
|
|
[named (px 2)]
|
|
[body (px 3)])
|
|
(appE (lamE id body) named))]
|
|
[(s-exp-match? `(lam (SYMBOL) ANY) sx)
|
|
(let* ([args (sx-ref sx 1)]
|
|
[varE (s-exp->symbol (sx-ref args 0))]
|
|
[body (px 2)])
|
|
(lamE varE body))]
|
|
[(s-exp-match? `(error STRING) sx) (errorE (s-exp->string (sx-ref sx 1)))]
|
|
[(s-exp-match? `(error ANY) sx) (parse-error sx)]
|
|
[(s-exp-match? `(-- ANY) sx) (minus1E (px 1))]
|
|
[(s-exp-match? `(ANY ANY) sx) (appE (px 0) (px 1))]
|
|
[(s-exp-list? sx)
|
|
(case (s-exp->symbol (sx-ref sx 0))
|
|
[(+) (plusE (px 1) (px 2))]
|
|
[(-) (minusE (px 1) (px 2))]
|
|
[(*) (timesE (px 1) (px 2))]
|
|
[(if0) (if0E (px 1) (px 2) (px 3))]
|
|
[else (parse-error sx)])]
|
|
[else (parse-error sx)])))
|
|
|
|
(define (arith-op op val1 val2)
|
|
(local
|
|
[(define (numV->number v)
|
|
(type-case Value v
|
|
[(numV n) n]
|
|
[else (error 'arith-op
|
|
(string-append "expects a number, got: " (to-string v)))]))]
|
|
(numV (op (numV->number val1)
|
|
(numV->number val2)))))
|
|
|
|
(define (numzero? x)
|
|
(zero? (numV-n x)))
|
|
|
|
(define (interp expr env k)
|
|
(type-case Exp expr
|
|
[(numE n) (continue k (numV n))]
|
|
[(plusE l r) (interp l env (plusSecondK r env k))]
|
|
[(minusE l r) (interp l env (minusSecondK r env k))]
|
|
[(varE name) (continue k (lookup name env))]
|
|
[(errorE msg) (errorV msg)]
|
|
[(lamE param body-expr)
|
|
(continue k (funV param body-expr env))]
|
|
[(appE fun-expr arg-expr)
|
|
(interp fun-expr env (appArgK arg-expr env k))]
|
|
[(if0E test-expr then-expr else-expr)
|
|
(interp test-expr env (doIfK then-expr else-expr env k))]
|
|
[(minus1E n) (interp n env (doMinus1K k))]
|
|
[(timesE l r) (interp l env (timesSecondK r env k))]
|
|
))
|
|
|
|
(define (continue [k : Continuation] [v : Value]) : Value
|
|
(type-case Continuation k
|
|
[(emptyCont) v]
|
|
[(plusSecondK r env next-k)
|
|
(interp r env (doPlusK v next-k))]
|
|
[(doPlusK v1 next-k)
|
|
(continue next-k (arith-op + v1 v))]
|
|
[(minusSecondK r env next-k)
|
|
(interp r env (doMinusK v next-k))]
|
|
[(doMinusK v1 next-k)
|
|
(continue next-k (arith-op - v1 v))]
|
|
[(doMinus1K next-k)
|
|
(continue next-k (arith-op - v (numV 1)))]
|
|
[(timesSecondK r env next-k)
|
|
(interp r env (doTimesK v next-k))]
|
|
[(doTimesK v1 next-k)
|
|
(continue next-k (arith-op * v1 v))]
|
|
[(appArgK arg-expr env next-k)
|
|
(interp arg-expr env (doAppK v next-k))]
|
|
[(doAppK fun-val next-k)
|
|
(interp (funV-body fun-val)
|
|
(Extend (funV-param fun-val) v (funV-env fun-val))
|
|
next-k)]
|
|
[(doIfK then-expr else-expr env next-k)
|
|
(if (numzero? v)
|
|
(interp then-expr env next-k)
|
|
(interp else-expr env next-k))]
|
|
))
|
|
|
|
(module+ test
|
|
(define init-k (emptyCont))
|
|
|
|
(define (run s-exp)
|
|
(interp (parse s-exp) (emptyEnv) (emptyCont)))
|
|
|
|
|
|
(test (interp (numE 10)
|
|
(emptyEnv)
|
|
init-k)
|
|
(numV 10))
|
|
(test (interp (plusE (numE 10) (numE 7))
|
|
(emptyEnv)
|
|
init-k)
|
|
(numV 17))
|
|
(test (interp (minusE (numE 10) (numE 7))
|
|
(emptyEnv)
|
|
init-k)
|
|
(numV 3))
|
|
(test (interp (appE (lamE 'x (plusE (varE 'x) (numE 12)))
|
|
(plusE (numE 1) (numE 17)))
|
|
(emptyEnv)
|
|
init-k)
|
|
(numV 30))
|
|
(test (interp (varE 'x)
|
|
(Extend 'x (numV 10) (emptyEnv))
|
|
init-k)
|
|
(numV 10))
|
|
|
|
(test (interp (appE (lamE 'x (plusE (varE 'x) (numE 12)))
|
|
(plusE (numE 1) (numE 17)))
|
|
(emptyEnv)
|
|
init-k)
|
|
(numV 30))
|
|
|
|
|
|
(test/exn (interp (varE 'x) (emptyEnv) init-k)
|
|
"no binding")
|
|
|
|
(test/exn
|
|
(run `{ {lam {x} {+ x y}} 0})
|
|
"no binding")
|
|
|
|
(test
|
|
(run
|
|
`{{lam {x}
|
|
{{lam {f} {f 2}}
|
|
{lam {y} {+ x y}}}}
|
|
0})
|
|
(numV 2))
|
|
|
|
|
|
(test (run `{let1 f {lam {x} {+ x 1}}
|
|
{+ {f 2} {error "abort!"}}})
|
|
(errorV "abort!"))
|
|
|
|
(test (run `{{lam {x}
|
|
{{lam {f}
|
|
{+ {f 1}
|
|
{{lam {x} {f 2}} 3}}}
|
|
{lam {y} {+ x y}}}}
|
|
0})
|
|
(numV 3))
|
|
|
|
(test (interp (if0E (numE 0)
|
|
(numE 1)
|
|
(numE 2))
|
|
(emptyEnv)
|
|
init-k)
|
|
(numV 1))
|
|
(test (interp (if0E (numE 1)
|
|
(numE 0)
|
|
(numE 2))
|
|
(emptyEnv)
|
|
init-k)
|
|
(numV 2))
|
|
|
|
(test (run
|
|
`{{lam {mkrec}
|
|
{{lam {fib}
|
|
;; Call fib on 10:
|
|
{fib 10}}
|
|
;; Create recursive fib:
|
|
{mkrec
|
|
{lam {fib}
|
|
;; Fib:
|
|
{lam {n}
|
|
{if0 n
|
|
1
|
|
{if0 {- n 1}
|
|
{error "reached zero"}
|
|
{+ {fib {- n 1}}
|
|
{fib {- n 2}}}}}}}}}}
|
|
;; mkrec:
|
|
{lam {body-proc}
|
|
{{lam {fX}
|
|
{fX fX}}
|
|
{lam {fX}
|
|
{body-proc {lam {x} {{fX fX} x}}}}}}})
|
|
(errorV "reached zero"))
|
|
)
|
|
|
|
; unary decrement
|
|
(module+ test
|
|
(test (parse `{-- 2}) (minus1E (numE 2))))
|
|
|
|
(module+ test
|
|
(test (run `{-- 2}) (numV 1))
|
|
(test (run `{{lam {x} {-- x}} 3}) (numV 2))
|
|
(test (run `{{lam {y} {+ {-- y} {-- y}}} 10}) (numV 18))
|
|
(test (run `{{lam {f} {f 4}} {lam {x} {-- x}}}) (numV 3)))
|
|
|
|
; multiplication
|
|
(module+ test
|
|
(define fact-prog
|
|
`{{lam {mkrec}
|
|
{{lam {fact}
|
|
;; Call fact on 5:
|
|
{fact 5}}
|
|
;; Create recursive fact
|
|
{mkrec
|
|
{lam {fact}
|
|
{lam {n}
|
|
{if0 n
|
|
1
|
|
{* n {fact {-- n}}}}}}}}}
|
|
;; mkrec:
|
|
{lam {body-proc}
|
|
{{lam {fX}
|
|
{fX fX}}
|
|
{lam {fX}
|
|
{body-proc {lam {x} {{fX fX} x}}}}}}})
|
|
|
|
(test (run fact-prog) (numV 120)))
|
|
|
|
; stupid tests for coverage
|
|
(module+ test
|
|
(test/exn (parse-error 'invalid-syntax) "invalid-syntax")
|
|
(test (parse `(error "test error")) (errorE "test error"))
|
|
(test/exn (parse `(error 123)) "parse error")
|
|
(test/exn (parse `(unknown 1 2 3)) "parse error")
|
|
(test/exn (arith-op + (numV 1) (errorV "not a number")) "expects a number")
|
|
(test/exn (parse `#f) "parse error"))
|
|
|