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.
138 lines
4.3 KiB
Racket
Executable File
138 lines
4.3 KiB
Racket
Executable File
#lang eopl
|
|
|
|
(require "lang.rkt")
|
|
(require "data-structures.rkt")
|
|
(require "environments.rkt")
|
|
|
|
(provide value-of-program value-of)
|
|
|
|
;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;;
|
|
|
|
;; value-of-program : Program -> Expval
|
|
;; Page: 284
|
|
(define value-of-program
|
|
(lambda (pgm)
|
|
(cases program pgm
|
|
(a-program (module-defs body)
|
|
(let ((env
|
|
(add-module-defns-to-env module-defs (empty-env))))
|
|
;; (eopl:pretty-print env)
|
|
(value-of body env))))))
|
|
|
|
;; add-module-defns-to-env : Listof(Defn) * Env -> Env
|
|
;; Page: 284
|
|
(define add-module-defns-to-env
|
|
(lambda (defs env)
|
|
(if (null? defs)
|
|
env
|
|
(cases module-definition (car defs)
|
|
(a-module-definition (m-name iface m-body)
|
|
(add-module-defns-to-env
|
|
(cdr defs)
|
|
(extend-env-with-module
|
|
m-name
|
|
(value-of-module-body m-body env)
|
|
env)))))))
|
|
|
|
;; We will have let* scoping inside a module body.
|
|
;; We put all the values in the environment, not just the ones
|
|
;; that are in the interface. But the typechecker will prevent
|
|
;; anybody from using the extras.
|
|
|
|
;; value-of-module-body : ModuleBody * Env -> TypedModule
|
|
;; Page: 285
|
|
(define value-of-module-body
|
|
(lambda (m-body env)
|
|
(cases module-body m-body
|
|
(defns-module-body (defns)
|
|
(simple-module
|
|
(defns-to-env defns env))) )))
|
|
|
|
|
|
(define raise-cant-apply-non-proc-module!
|
|
(lambda (rator-val)
|
|
(eopl:error 'value-of-module-body
|
|
"can't apply non-proc-module-value ~s" rator-val)))
|
|
|
|
;; defns-to-env : Listof(Defn) * Env -> Env
|
|
;; Page: 285
|
|
(define defns-to-env
|
|
(lambda (defns env)
|
|
(if (null? defns)
|
|
(empty-env) ; we're making a little environment
|
|
(cases definition (car defns)
|
|
(val-defn (var exp)
|
|
(let ((val (value-of exp env)))
|
|
;; new environment for subsequent definitions
|
|
(let ((new-env (extend-env var val env)))
|
|
(extend-env var val
|
|
(defns-to-env
|
|
(cdr defns) new-env)))))
|
|
))))
|
|
|
|
;; value-of : Exp * Env -> ExpVal
|
|
(define value-of
|
|
(lambda (exp env)
|
|
|
|
(cases expression exp
|
|
|
|
(const-exp (num) (num-val num))
|
|
|
|
(var-exp (var) (apply-env env var))
|
|
|
|
(qualified-var-exp (m-name var-name)
|
|
(lookup-qualified-var-in-env m-name var-name env))
|
|
|
|
(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)))
|
|
(let ((new-env (extend-env var val env)))
|
|
;; (eopl:pretty-print new-env)
|
|
(value-of body new-env))))
|
|
|
|
(proc-exp (bvar ty body)
|
|
(proc-val
|
|
(procedure bvar body env)))
|
|
|
|
(call-exp (rator rand)
|
|
(let ((proc (expval->proc (value-of rator env)))
|
|
(arg (value-of rand env)))
|
|
(apply-procedure proc arg)))
|
|
|
|
(letrec-exp (ty1 proc-name bvar ty2 proc-body letrec-body)
|
|
(value-of letrec-body
|
|
(extend-env-recursively proc-name bvar proc-body env)))
|
|
|
|
)))
|
|
|
|
;; apply-procedure : Proc * ExpVal -> ExpVal
|
|
(define apply-procedure
|
|
(lambda (proc1 arg)
|
|
(cases proc proc1
|
|
(procedure (var body saved-env)
|
|
(value-of body (extend-env var arg saved-env))))))
|
|
|
|
|
|
|
|
|