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.
209 lines
6.7 KiB
Racket
Executable File
209 lines
6.7 KiB
Racket
Executable File
#lang eopl
|
|
|
|
(require "lang.rkt")
|
|
(require "data-structures.rkt")
|
|
(require "environments.rkt")
|
|
(require "store.rkt")
|
|
(require "classes.rkt")
|
|
|
|
(require (only-in racket pretty-print))
|
|
|
|
(provide value-of-program value-of instrument-let instrument-newref)
|
|
|
|
;;;;;;;;;;;;;;;; switches for instrument-let ;;;;;;;;;;;;;;;;
|
|
|
|
(define instrument-let (make-parameter #f))
|
|
|
|
;; say (instrument-let #t) to turn instrumentation on.
|
|
;; (instrument-let #f) to turn it off again.
|
|
|
|
;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;;
|
|
|
|
;; value-of-program : Program -> ExpVal
|
|
;; Page: 336
|
|
(define value-of-program
|
|
(lambda (pgm)
|
|
(initialize-store!)
|
|
(cases program pgm
|
|
(a-program (class-decls body)
|
|
(initialize-class-env! class-decls)
|
|
(value-of body (init-env))))))
|
|
|
|
;; value-of : Exp * Env -> ExpVal
|
|
;; Page: 336 and 337
|
|
(define value-of
|
|
(lambda (exp env)
|
|
(cases expression exp
|
|
|
|
(const-exp (num) (num-val num))
|
|
|
|
(var-exp (var) (deref (apply-env env var)))
|
|
|
|
(diff-exp (exp1 exp2)
|
|
(let ((val1
|
|
(expval->num
|
|
(value-of exp1 env)))
|
|
(val2
|
|
(expval->num
|
|
(value-of exp2 env))))
|
|
(num-val
|
|
(- val1 val2))))
|
|
|
|
(sum-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 (vars exps body)
|
|
(when (instrument-let)
|
|
(eopl:printf "entering let ~s~%" vars))
|
|
(let ((new-env
|
|
(extend-env
|
|
vars
|
|
(map newref (values-of-exps exps env))
|
|
env)))
|
|
(when (instrument-let)
|
|
(eopl:printf "entering body of let ~s with env =~%" vars)
|
|
(pretty-print (env->list new-env))
|
|
(eopl:printf "store =~%")
|
|
(pretty-print (store->readable (get-store-as-list)))
|
|
(eopl:printf "~%")
|
|
)
|
|
(value-of body new-env)))
|
|
|
|
(proc-exp (bvars body)
|
|
(proc-val
|
|
(procedure bvars body env)))
|
|
|
|
(call-exp (rator rands)
|
|
(let ((proc (expval->proc (value-of rator env)))
|
|
(args (values-of-exps rands env)))
|
|
(apply-procedure proc args)))
|
|
|
|
(letrec-exp (p-names b-varss p-bodies letrec-body)
|
|
(value-of letrec-body
|
|
(extend-env-rec** p-names b-varss 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)))
|
|
|
|
|
|
(list-exp (exps)
|
|
(list-val
|
|
(values-of-exps exps env)))
|
|
|
|
;; new cases for CLASSES language
|
|
|
|
(new-object-exp (class-name rands)
|
|
(let ((args (values-of-exps rands env))
|
|
(obj (new-object class-name)))
|
|
(apply-method
|
|
(find-method class-name 'initialize)
|
|
obj
|
|
args)
|
|
obj))
|
|
|
|
(self-exp ()
|
|
(apply-env env '%self))
|
|
|
|
(method-call-exp (obj-exp method-name rands)
|
|
(let ((args (values-of-exps rands env))
|
|
(obj (value-of obj-exp env)))
|
|
(apply-method
|
|
(find-method (object->class-name obj) method-name)
|
|
obj
|
|
args)))
|
|
|
|
(super-call-exp (method-name rands)
|
|
(let ((args (values-of-exps rands env))
|
|
(obj (apply-env env '%self)))
|
|
(apply-method
|
|
(find-method (apply-env env '%super) method-name)
|
|
obj
|
|
args)))
|
|
)))
|
|
|
|
;; apply-procedure : Proc * Listof(ExpVal) -> ExpVal
|
|
(define apply-procedure
|
|
(lambda (proc1 args)
|
|
(cases proc proc1
|
|
(procedure (vars body saved-env)
|
|
(let ((new-env
|
|
(extend-env
|
|
vars
|
|
(map newref args)
|
|
saved-env)))
|
|
(when (instrument-let)
|
|
(eopl:printf
|
|
"entering body of proc ~s with env =~%"
|
|
vars)
|
|
(pretty-print (env->list new-env))
|
|
(eopl:printf "store =~%")
|
|
(pretty-print (store->readable (get-store-as-list)))
|
|
(eopl:printf "~%"))
|
|
(value-of body new-env))))))
|
|
|
|
|
|
;; apply-method : Method * Obj * Listof(ExpVal) -> ExpVal
|
|
(define apply-method
|
|
(lambda (m self args)
|
|
(cases method m
|
|
(a-method (vars body super-name field-names)
|
|
(value-of body
|
|
(extend-env vars (map newref args)
|
|
(extend-env-with-self-and-super
|
|
self super-name
|
|
(extend-env field-names (object->fields self)
|
|
(empty-env)))))))))
|
|
|
|
(define values-of-exps
|
|
(lambda (exps env)
|
|
(map
|
|
(lambda (exp) (value-of exp env))
|
|
exps)))
|
|
|
|
;; store->readable : Listof(List(Ref,Expval))
|
|
;; -> Listof(List(Ref,Something-Readable))
|
|
(define store->readable
|
|
(lambda (l)
|
|
(map
|
|
(lambda (p)
|
|
(cons
|
|
(car p)
|
|
(expval->printable (cadr p))))
|
|
l)))
|
|
|
|
|
|
|
|
|