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.
135 lines
4.9 KiB
Racket
Executable File
135 lines
4.9 KiB
Racket
Executable File
#lang eopl
|
|
|
|
(require "cps-out-lang.rkt")
|
|
(require "data-structures.rkt")
|
|
(require "store.rkt")
|
|
|
|
(provide value-of-program value-of/k)
|
|
|
|
;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;;
|
|
|
|
;; value-of-program : Program -> ExpVal
|
|
(define value-of-program
|
|
(lambda (pgm)
|
|
(initialize-store!)
|
|
(cases cps-out-program pgm
|
|
(cps-a-program (body)
|
|
(value-of/k body (init-env) (end-cont))))))
|
|
|
|
(define value-of-simple-exp
|
|
(lambda (exp env)
|
|
|
|
(cases simple-expression exp
|
|
(cps-const-exp (num) (num-val num))
|
|
(cps-var-exp (var) (apply-env env var))
|
|
(cps-diff-exp (exp1 exp2)
|
|
(let ((val1
|
|
(expval->num
|
|
(value-of-simple-exp exp1 env)))
|
|
(val2
|
|
(expval->num
|
|
(value-of-simple-exp exp2 env))))
|
|
(num-val
|
|
(- val1 val2))))
|
|
(cps-zero?-exp (exp1)
|
|
(bool-val
|
|
(zero?
|
|
(expval->num
|
|
(value-of-simple-exp exp1 env)))))
|
|
(cps-sum-exp (exps)
|
|
(let ((nums (map
|
|
(lambda (exp)
|
|
(expval->num
|
|
(value-of-simple-exp exp env)))
|
|
exps)))
|
|
(num-val
|
|
(let sum-loop ((nums nums))
|
|
(if (null? nums) 0
|
|
(+ (car nums) (sum-loop (cdr nums))))))))
|
|
(cps-proc-exp (vars body)
|
|
(proc-val
|
|
(procedure vars body env)))
|
|
)))
|
|
|
|
;; value-of/k : Exp * Env * Cont -> FinalAnswer
|
|
;; Page: 228 and 230-231
|
|
(define value-of/k
|
|
(lambda (exp env cont)
|
|
(cases tfexp exp
|
|
(simple-exp->exp (bexp)
|
|
(apply-cont cont
|
|
(value-of-simple-exp bexp env)))
|
|
(cps-let-exp (var exp1 body)
|
|
(let ((val (value-of-simple-exp exp1 env)))
|
|
(value-of/k body
|
|
(extend-env* (list var) (list val) env)
|
|
cont)))
|
|
(cps-letrec-exp (p-names b-varss p-bodies letrec-body)
|
|
(value-of/k letrec-body
|
|
(extend-env-rec** p-names b-varss p-bodies env)
|
|
cont))
|
|
(cps-if-exp (exp1 exp2 exp3)
|
|
(value-of/k
|
|
(if (expval->bool (value-of-simple-exp exp1 env))
|
|
exp2
|
|
exp3)
|
|
env
|
|
cont))
|
|
(cps-call-exp (rator rands)
|
|
(let ((rator-proc (expval->proc (value-of-simple-exp rator env)))
|
|
(rand-vals (map
|
|
(lambda (bexp) (value-of-simple-exp bexp
|
|
env))
|
|
rands)))
|
|
(apply-procedure/k rator-proc rand-vals cont)))
|
|
|
|
(cps-printk-exp (simple body)
|
|
(begin
|
|
(eopl:printf "~s~%" (value-of-simple-exp simple env))
|
|
(value-of/k body env cont)))
|
|
|
|
(cps-newrefk-exp (simple1 simple2)
|
|
(let ((val1 (value-of-simple-exp simple1 env))
|
|
(val2 (value-of-simple-exp simple2 env)))
|
|
(let ((newval (ref-val (newref val1))))
|
|
(apply-procedure/k
|
|
(expval->proc val2)
|
|
(list newval)
|
|
cont))))
|
|
|
|
(cps-derefk-exp (simple1 simple2)
|
|
(apply-procedure/k
|
|
(expval->proc (value-of-simple-exp simple2 env))
|
|
(list
|
|
(deref
|
|
(expval->ref
|
|
(value-of-simple-exp simple1 env))))
|
|
cont))
|
|
|
|
(cps-setrefk-exp (simple1 simple2 body)
|
|
(let ((ref (expval->ref (value-of-simple-exp simple1 env)))
|
|
(val (value-of-simple-exp simple2 env)))
|
|
(begin
|
|
(setref! ref val)
|
|
(value-of/k body env cont))))
|
|
)))
|
|
|
|
;; apply-cont : Cont * ExpVal -> Final-ExpVal
|
|
;; there's only one continuation, and it only gets invoked once, at
|
|
;; the end of the computation.
|
|
(define apply-cont
|
|
(lambda (cont val)
|
|
(cases continuation cont
|
|
(end-cont () val))))
|
|
|
|
;; apply-procedure/k : Proc * ExpVal * Cont -> ExpVal
|
|
;; Page: 209
|
|
(define apply-procedure/k
|
|
(lambda (proc1 args cont)
|
|
(cases proc proc1
|
|
(procedure (vars body saved-env)
|
|
(value-of/k body
|
|
(extend-env* vars args saved-env)
|
|
cont)))))
|
|
|