115 lines
3.3 KiB
Racket
115 lines
3.3 KiB
Racket
#lang racket/base
|
|
(require rackunit
|
|
mzlib/serialize
|
|
mzlib/match
|
|
web-server/private/define-closure)
|
|
(provide define-closure-tests)
|
|
|
|
(define-closure id (x) () x)
|
|
|
|
(define-closure add-y (x) (y) (+ x y))
|
|
(define-closure even-p (n) (odd-p) (or (zero? n)
|
|
(odd-p (sub1 n))))
|
|
(define-closure odd-p (n) (even-p) (or (= 1 n)
|
|
(even-p (sub1 n))))
|
|
|
|
(define even-p (make-even-p (lambda () odd-p)))
|
|
(define odd-p (make-odd-p (lambda () even-p)))
|
|
|
|
;; an interpreter
|
|
|
|
(define-closure the-empty-env (var) ()
|
|
(error "unbound symbol: " var))
|
|
|
|
(define-closure extended-env (v) (env var val)
|
|
(if (eqv? v var) val
|
|
(env v)))
|
|
|
|
(define-serializable-struct proc (var body env))
|
|
|
|
(define-closure clsr:evaluate (expr env) (evaluate eval-app)
|
|
(match expr
|
|
[('lambda (var) body) (make-proc var body env)]
|
|
[(expr1 expr2)
|
|
(let ([val1 (evaluate expr1 env)]
|
|
[val2 (evaluate expr2 env)])
|
|
(eval-app val1 val2))]
|
|
[(? number? n) n]
|
|
[var (env var)]))
|
|
|
|
(define-closure clsr:eval-app (val1 val2) (evaluate)
|
|
(cond
|
|
[(proc? val1)
|
|
(evaluate (proc-body val1)
|
|
(make-extended-env
|
|
(lambda () (values (proc-env val1) (proc-var val1) val2))))]
|
|
[else
|
|
(error "stuck term: " (list val1 val2))]))
|
|
|
|
(define evaluate (make-clsr:evaluate (lambda () (values evaluate eval-app))))
|
|
(define eval-app (make-clsr:eval-app (lambda () evaluate)))
|
|
|
|
(define define-closure-tests
|
|
(test-suite
|
|
"Define Closure"
|
|
|
|
(test-case
|
|
"serialize id procedure"
|
|
(check = 7 ((deserialize (serialize (make-id))) 7)))
|
|
|
|
(test-case
|
|
"id procedure"
|
|
(check = 7 ((make-id) 7)))
|
|
|
|
(test-case
|
|
"add-y procedure"
|
|
(check = 2 ((make-add-y (lambda () 1)) 1)))
|
|
|
|
(test-case
|
|
"serialize the add-y procedure"
|
|
(check = 2 ((deserialize (serialize (make-add-y (lambda () 1)))) 1)))
|
|
|
|
(test-case
|
|
"even-p procedure"
|
|
(check-true (even-p 8)))
|
|
|
|
(test-case
|
|
"serialize the even-p procedure"
|
|
(check-true ((deserialize (serialize even-p)) 64)))
|
|
|
|
(test-case
|
|
"simple interpreter case"
|
|
(check = 3 (evaluate 3 (make-the-empty-env))))
|
|
|
|
(test-case
|
|
"serialize simple interpreter case"
|
|
(check = 3 ((deserialize (serialize evaluate))
|
|
3
|
|
(deserialize (serialize (make-the-empty-env))))))
|
|
|
|
(test-case
|
|
"apply identity"
|
|
(check = 3 (evaluate '((lambda (x) x) 3) (make-the-empty-env))))
|
|
|
|
(test-case
|
|
"serialize environments"
|
|
(let* ([e0 (make-the-empty-env)]
|
|
[e1 (make-extended-env (lambda () (values e0 'x 1)))]
|
|
[e2 (make-extended-env (lambda () (values e1 'y 2)))]
|
|
[e3 (make-extended-env (lambda () (values e2 'z 3)))]
|
|
[e4 (make-extended-env (lambda () (values e3 'x 4)))]
|
|
[e5 (make-extended-env (lambda () (values e4 'y 5)))]
|
|
[e6 (make-extended-env (lambda () (values e5 'z 6)))]
|
|
[env3 (deserialize (serialize e3))]
|
|
[env5 (deserialize (serialize e5))]
|
|
[env6 (deserialize (serialize e6))])
|
|
(check = 1 (env3 'x))
|
|
(check = 2 (env3 'y))
|
|
(check = 3 (env3 'z))
|
|
(check = 4 (env5 'x))
|
|
(check = 5 (env5 'y))
|
|
(check = 3 (env5 'z))
|
|
(check = 4 (env6 'x))
|
|
(check = 5 (env6 'y))
|
|
(check = 6 (env6 'z))))))
|