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.
152 lines
3.9 KiB
Racket
Executable File
152 lines
3.9 KiB
Racket
Executable File
#lang eopl
|
|
|
|
(require "cps-out-lang.rkt") ; for tfexp?
|
|
(provide (all-defined-out)) ; too many things to list
|
|
|
|
;;;;;;;;;;;;;;;; expressed values ;;;;;;;;;;;;;;;;
|
|
|
|
;;; an expressed value is either a number, a boolean or a procval.
|
|
|
|
(define-datatype expval expval?
|
|
(num-val
|
|
(value number?))
|
|
(bool-val
|
|
(boolean boolean?))
|
|
(proc-val
|
|
(proc proc?)))
|
|
|
|
;;; extractors:
|
|
|
|
(define expval->num
|
|
(lambda (v)
|
|
(cases expval v
|
|
(num-val (num) num)
|
|
(else (expval-extractor-error 'num v)))))
|
|
|
|
(define expval->bool
|
|
(lambda (v)
|
|
(cases expval v
|
|
(bool-val (bool) bool)
|
|
(else (expval-extractor-error 'bool v)))))
|
|
|
|
(define expval->proc
|
|
(lambda (v)
|
|
(cases expval v
|
|
(proc-val (proc) proc)
|
|
(else (expval-extractor-error 'proc v)))))
|
|
|
|
(define expval-extractor-error
|
|
(lambda (variant value)
|
|
(eopl:error 'expval-extractors "Looking for a ~s, found ~s"
|
|
variant value)))
|
|
|
|
;;;;;;;;;;;;;;;; continuations ;;;;;;;;;;;;;;;;
|
|
|
|
;; the interpreter is tail-recursive, so it really doesn't do
|
|
;; anything with the continuation. So all we need is one
|
|
;; continuation value.
|
|
|
|
(define-datatype continuation continuation?
|
|
(end-cont)
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;; procedures ;;;;;;;;;;;;;;;;
|
|
|
|
(define-datatype proc proc?
|
|
(procedure
|
|
(vars (list-of symbol?))
|
|
(body tfexp?)
|
|
(env environment?)))
|
|
|
|
;;;;;;;;;;;;;;;; environment structures ;;;;;;;;;;;;;;;;
|
|
|
|
;;; represent environment as a list of bindings.
|
|
;;; binding ::= ('let (list-of id) (list-of expval))
|
|
;;; | ('letrec (list-of id) (list-of bvar) (list-of expression))
|
|
|
|
;;; The first binding for extend-env*, the second is for
|
|
;;; extend-env-rec**.
|
|
|
|
;;; this representation is designed to make the printed representation
|
|
;;; of the environment more readable.
|
|
|
|
(define empty-env
|
|
(lambda ()
|
|
'()))
|
|
|
|
(define empty-env?
|
|
(lambda (x) (null? x)))
|
|
|
|
(define extend-env*
|
|
(lambda (syms vals old-env)
|
|
(cons (list 'let syms vals) old-env)))
|
|
|
|
(define extend-env-rec**
|
|
(lambda (p-names b-varss p-bodies saved-env)
|
|
(cons
|
|
(list 'letrec p-names b-varss p-bodies)
|
|
saved-env)))
|
|
|
|
(define apply-env
|
|
(lambda (env search-sym)
|
|
(if (null? env)
|
|
(eopl:error 'apply-env "No binding for ~s" search-sym)
|
|
(let* ((binding (car env))
|
|
(saved-env (cdr env)))
|
|
(let ((pos (list-index search-sym (cadr binding))))
|
|
(if pos
|
|
(case (car binding)
|
|
((let)
|
|
(list-ref (caddr binding) pos))
|
|
((letrec)
|
|
(let ((bvars (caddr binding))
|
|
(bodies (cadddr binding)))
|
|
(proc-val
|
|
(procedure
|
|
(list-ref bvars pos)
|
|
(list-ref bodies pos)
|
|
env)))))
|
|
(apply-env saved-env search-sym)))))))
|
|
|
|
;; returns position of sym in los, else #f
|
|
(define list-index
|
|
(lambda (sym los)
|
|
(let loop ((pos 0) (los los))
|
|
;; los is at position pos of the original los
|
|
(cond
|
|
((null? los) #f)
|
|
((eqv? sym (car los)) pos)
|
|
(else (loop (+ pos 1) (cdr los)))))))
|
|
|
|
;; not precise, but will do.
|
|
(define environment?
|
|
(list-of
|
|
(lambda (p)
|
|
(and
|
|
(pair? p)
|
|
(or (eqv? (car p) 'let) (eqv? (car p) 'letrec))))))
|
|
|
|
|
|
;;;;;;;;;;;;;;;; initial environment ;;;;;;;;;;;;;;;;
|
|
|
|
;; init-env : () -> environment
|
|
|
|
;; (init-env) builds an environment in which i is bound to the
|
|
;; expressed value 1, v is bound to the expressed value 5, and x is
|
|
;; bound to the expressed value 10.
|
|
|
|
(define init-env
|
|
(let ((extend-env1
|
|
(lambda (sym val env)
|
|
(extend-env* (list sym) (list val) env))))
|
|
(lambda ()
|
|
(extend-env1
|
|
'i (num-val 1)
|
|
(extend-env1
|
|
'v (num-val 5)
|
|
(extend-env1
|
|
'x (num-val 10)
|
|
(empty-env)))))))
|
|
|
|
;; exercise: Improve this code by getting rid of extend-env1.
|