7491e172ea
The eopl language is now racket-based rather than mzscheme-based. This test-suite, which was originally distributed on the book's web-site has been re-written in the new language. Changes include dropping all drscheme-init.scm and top.scm files. Remaining files were renamed to use the .rkt extension and edited to use the #lang syntax (instead of modulue). Require and provide forms were changed to reflect racket's syntax instead of mzscheme's (eg, only-in vs. only). Several occurrences of one-armed ifs were changed to use when and unless. All tests have been run successfully.
160 lines
4.8 KiB
Racket
Executable File
160 lines
4.8 KiB
Racket
Executable File
#lang eopl
|
|
|
|
;; interpreter for the CALL-BY-NEED language.
|
|
|
|
(require "lang.rkt")
|
|
(require "data-structures.rkt")
|
|
(require "environments.rkt")
|
|
(require "store.rkt")
|
|
(require "pairvals.rkt")
|
|
|
|
(provide value-of-program value-of instrument-newref)
|
|
|
|
;;; exercise: add instrumentation around let and procedure calls, as
|
|
;;; in the call-by-reference language.
|
|
|
|
;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;;
|
|
|
|
;; value-of-program : Program -> ExpVal
|
|
(define value-of-program
|
|
(lambda (pgm)
|
|
(initialize-store!)
|
|
(cases program pgm
|
|
(a-program (body)
|
|
(value-of body (init-env))))))
|
|
|
|
;; value-of : Exp * Env -> ExpVal
|
|
;; Page: 137 and 138
|
|
(define value-of
|
|
(lambda (exp env)
|
|
(cases expression exp
|
|
|
|
(const-exp (num) (num-val num))
|
|
|
|
(var-exp (var)
|
|
(let ((ref1 (apply-env env var)))
|
|
(let ((w (deref ref1)))
|
|
(if (expval? w)
|
|
w
|
|
(let ((v1 (value-of-thunk w)))
|
|
(begin
|
|
(setref! ref1 v1)
|
|
v1))))))
|
|
|
|
(diff-exp (exp1 exp2)
|
|
(let ((val1
|
|
(expval->num
|
|
(value-of exp1 env)))
|
|
(val2
|
|
(expval->num
|
|
(value-of exp2 env))))
|
|
(num-val
|
|
(- val1 val2))))
|
|
|
|
(zero?-exp (exp1)
|
|
(let ((val1 (expval->num (value-of exp1 env))))
|
|
(if (zero? val1)
|
|
(bool-val #t)
|
|
(bool-val #f))))
|
|
|
|
(if-exp (exp0 exp1 exp2)
|
|
(if (expval->bool (value-of exp0 env))
|
|
(value-of exp1 env)
|
|
(value-of exp2 env)))
|
|
|
|
(let-exp (var exp1 body)
|
|
(let ((val (value-of exp1 env)))
|
|
(value-of body
|
|
(extend-env var (newref val) env))))
|
|
|
|
(proc-exp (var body)
|
|
(proc-val
|
|
(procedure var body env)))
|
|
|
|
(call-exp (rator rand)
|
|
(let ((proc (expval->proc (value-of rator env)))
|
|
(arg (value-of-operand rand env)))
|
|
(apply-procedure proc arg)))
|
|
|
|
(letrec-exp (p-names b-vars p-bodies letrec-body)
|
|
(value-of letrec-body
|
|
(extend-env-rec* p-names b-vars p-bodies env)))
|
|
|
|
(begin-exp (exp1 exps)
|
|
(letrec
|
|
((value-of-begins
|
|
(lambda (e1 es)
|
|
(let ((v1 (value-of e1 env)))
|
|
(if (null? es)
|
|
v1
|
|
(value-of-begins (car es) (cdr es)))))))
|
|
(value-of-begins exp1 exps)))
|
|
|
|
(assign-exp (x e)
|
|
(begin
|
|
(setref!
|
|
(apply-env env x)
|
|
(value-of e env))
|
|
(num-val 27)))
|
|
|
|
(newpair-exp (exp1 exp2)
|
|
(let ((v1 (value-of exp1 env))
|
|
(v2 (value-of exp2 env)))
|
|
(mutpair-val (make-pair v1 v2))))
|
|
|
|
(left-exp (exp1)
|
|
(let ((v1 (value-of exp1 env)))
|
|
(let ((p1 (expval->mutpair v1)))
|
|
(left p1))))
|
|
|
|
(setleft-exp (exp1 exp2)
|
|
(let ((v1 (value-of exp1 env))
|
|
(v2 (value-of exp2 env)))
|
|
(let ((p (expval->mutpair v1)))
|
|
(begin
|
|
(setleft p v2)
|
|
(num-val 82)))))
|
|
|
|
(right-exp (exp1)
|
|
(let ((v1 (value-of exp1 env)))
|
|
(let ((p1 (expval->mutpair v1)))
|
|
(right p1))))
|
|
|
|
(setright-exp (exp1 exp2)
|
|
(let ((v1 (value-of exp1 env))
|
|
(v2 (value-of exp2 env)))
|
|
(let ((p (expval->mutpair v1)))
|
|
(begin
|
|
(setright p v2)
|
|
(num-val 83)))))
|
|
|
|
)))
|
|
|
|
;; apply-procedure : Proc * Ref -> ExpVal
|
|
(define apply-procedure
|
|
(lambda (proc1 arg)
|
|
(cases proc proc1
|
|
(procedure (var body saved-env)
|
|
(value-of body
|
|
(extend-env var arg saved-env))))))
|
|
|
|
;; value-of-operand : Exp * Env -> Ref
|
|
;; Page: 137
|
|
(define value-of-operand
|
|
(lambda (exp env)
|
|
(cases expression exp
|
|
(var-exp (var) (apply-env env var)) ; no deref!
|
|
(else
|
|
(newref (a-thunk exp env))))))
|
|
|
|
;; value-of-thunk : Thunk -> ExpVal
|
|
(define value-of-thunk
|
|
(lambda (th)
|
|
(cases thunk th
|
|
(a-thunk (exp1 saved-env)
|
|
(value-of exp1 saved-env)))))
|
|
|
|
|
|
|
|
|