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.
110 lines
3.5 KiB
Racket
Executable File
110 lines
3.5 KiB
Racket
Executable File
#lang eopl
|
|
|
|
(require "lang.rkt") ; for expression?, type?, etc.
|
|
|
|
(provide (all-defined-out)) ; too many things to list
|
|
|
|
(define-datatype type-environment type-environment?
|
|
(empty-tenv)
|
|
(extend-tenv
|
|
(bvar symbol?)
|
|
(bval type?)
|
|
(saved-tenv type-environment?))
|
|
(extend-tenv-with-module
|
|
(name symbol?)
|
|
(interface interface?)
|
|
(saved-tenv type-environment?))
|
|
)
|
|
|
|
;;;;;;;;;;;;;;;; procedures for looking things up tenvs ;;;;;;;;;;;;;;;;
|
|
|
|
;;;;;;;;;;;;;;;; lookup or die
|
|
|
|
;; lookup-qualified-var-in-tenv : Sym * Sym * Tenv -> Type
|
|
;; Page: 285
|
|
(define lookup-qualified-var-in-tenv
|
|
(lambda (m-name var-name tenv)
|
|
(let ((iface (lookup-module-name-in-tenv tenv m-name)))
|
|
(cases interface iface
|
|
(simple-iface (decls)
|
|
(lookup-variable-name-in-decls var-name decls)) ))))
|
|
|
|
(define lookup-variable-name-in-tenv
|
|
(lambda (tenv search-sym)
|
|
(let ((maybe-answer
|
|
(variable-name->maybe-binding-in-tenv tenv search-sym)))
|
|
(if maybe-answer maybe-answer
|
|
(raise-tenv-lookup-failure-error 'variable search-sym tenv)))))
|
|
|
|
(define lookup-module-name-in-tenv
|
|
(lambda (tenv search-sym)
|
|
(let ((maybe-answer
|
|
(module-name->maybe-binding-in-tenv tenv search-sym)))
|
|
(if maybe-answer maybe-answer
|
|
(raise-tenv-lookup-failure-error 'module search-sym tenv)))))
|
|
|
|
(define apply-tenv lookup-variable-name-in-tenv)
|
|
|
|
(define raise-tenv-lookup-failure-error
|
|
(lambda (kind var tenv)
|
|
(eopl:pretty-print
|
|
(list 'tenv-lookup-failure: (list 'missing: kind var) 'in:
|
|
tenv))
|
|
(eopl:error 'lookup-variable-name-in-tenv)))
|
|
|
|
(define lookup-variable-name-in-decls
|
|
(lambda (var-name decls0)
|
|
(let loop ((decls decls0))
|
|
(cond
|
|
((null? decls)
|
|
(raise-lookup-variable-in-decls-error! var-name decls0))
|
|
((eqv? var-name (decl->name (car decls)))
|
|
(decl->type (car decls)))
|
|
(else (loop (cdr decls)))))))
|
|
|
|
(define raise-lookup-variable-in-decls-error!
|
|
(lambda (var-name decls)
|
|
(eopl:pretty-print
|
|
(list 'lookup-variable-decls-failure:
|
|
(list 'missing-variable var-name)
|
|
'in:
|
|
decls))))
|
|
|
|
;;;;;;;;;;;;;;;; lookup or return #f.
|
|
|
|
;; variable-name->maybe-binding-in-tenv : Tenv * Sym -> Maybe(Type)
|
|
(define variable-name->maybe-binding-in-tenv
|
|
(lambda (tenv search-sym)
|
|
(let recur ((tenv tenv))
|
|
(cases type-environment tenv
|
|
(empty-tenv () #f)
|
|
(extend-tenv (name ty saved-tenv)
|
|
(if (eqv? name search-sym)
|
|
ty
|
|
(recur saved-tenv)))
|
|
(else (recur (tenv->saved-tenv tenv)))))))
|
|
|
|
;; module-name->maybe-binding-in-tenv : Tenv * Sym -> Maybe(Iface)
|
|
(define module-name->maybe-binding-in-tenv
|
|
(lambda (tenv search-sym)
|
|
(let recur ((tenv tenv))
|
|
(cases type-environment tenv
|
|
(empty-tenv () #f)
|
|
(extend-tenv-with-module (name m-type saved-tenv)
|
|
(if (eqv? name search-sym)
|
|
m-type
|
|
(recur saved-tenv)))
|
|
(else (recur (tenv->saved-tenv tenv)))))))
|
|
|
|
;; assumes tenv is non-empty.
|
|
(define tenv->saved-tenv
|
|
(lambda (tenv)
|
|
(cases type-environment tenv
|
|
(empty-tenv ()
|
|
(eopl:error 'tenv->saved-tenv
|
|
"tenv->saved-tenv called on empty tenv"))
|
|
(extend-tenv (name ty saved-tenv) saved-tenv)
|
|
(extend-tenv-with-module (name m-type saved-tenv) saved-tenv)
|
|
)))
|
|
|