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.
127 lines
5.5 KiB
Racket
Executable File
127 lines
5.5 KiB
Racket
Executable File
#lang eopl
|
|
|
|
(require "lang.rkt")
|
|
(require "static-data-structures.rkt")
|
|
(require "expand-type.rkt")
|
|
(require "checker.rkt")
|
|
(require "renaming.rkt")
|
|
(require "subtyping.rkt")
|
|
|
|
(require (only-in racket pretty-print))
|
|
|
|
(provide type-of-program)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; type-of-program : Program -> Type
|
|
;; Page: 286
|
|
(define type-of-program
|
|
(lambda (pgm)
|
|
(cases program pgm
|
|
(a-program (module-defs body)
|
|
(type-of body
|
|
(add-module-defns-to-tenv module-defs (empty-tenv)))))))
|
|
|
|
;; add-module-defns-to-tenv : Listof(ModuleDefn) * Tenv -> Tenv
|
|
;; Page: 286, 305
|
|
(define add-module-defns-to-tenv
|
|
(lambda (defns tenv)
|
|
(if (null? defns)
|
|
tenv
|
|
(cases module-definition (car defns)
|
|
(a-module-definition (m-name expected-iface m-body)
|
|
(let ((actual-iface (interface-of m-body tenv)))
|
|
(if (<:-iface actual-iface expected-iface tenv)
|
|
;; ok, continue in extended tenv
|
|
(let ((new-env (extend-tenv-with-module
|
|
m-name
|
|
(expand-iface m-name expected-iface tenv)
|
|
tenv)))
|
|
(add-module-defns-to-tenv (cdr defns) new-env))
|
|
;; no, raise error
|
|
(report-module-doesnt-satisfy-iface m-name
|
|
expected-iface actual-iface))))))))
|
|
|
|
;; interface-of : ModuleBody * Tenv -> Iface
|
|
;; Page: 322
|
|
(define interface-of
|
|
(lambda (m-body tenv)
|
|
(cases module-body m-body
|
|
(var-module-body (m-name)
|
|
(lookup-module-name-in-tenv tenv m-name))
|
|
(defns-module-body (defns)
|
|
(simple-iface
|
|
(defns-to-decls defns tenv)))
|
|
(app-module-body (rator-id rand-id)
|
|
(let ((rator-iface (lookup-module-name-in-tenv tenv rator-id))
|
|
(rand-iface (lookup-module-name-in-tenv tenv rand-id)))
|
|
(cases interface rator-iface
|
|
(simple-iface (decls)
|
|
(eopl:error 'interface-of
|
|
"attempt to apply non-parameterized module ~s"
|
|
rator-id))
|
|
(proc-iface (param-name param-iface result-iface)
|
|
(if (<:-iface
|
|
rand-iface
|
|
param-iface tenv)
|
|
(rename-in-iface
|
|
result-iface param-name rand-id)
|
|
(raise-bad-module-application-error! param-iface
|
|
rand-iface m-body)))
|
|
(else (eopl:error 'interface-of
|
|
"unknown module type ~s"
|
|
rator-iface))
|
|
)))
|
|
(proc-module-body (rand-name rand-iface m-body)
|
|
;; add the formal parameter to the tenv as if it had been a
|
|
;; top-level module.
|
|
(let ((body-iface
|
|
(interface-of m-body
|
|
(extend-tenv-with-module rand-name
|
|
(expand-iface rand-name rand-iface tenv)
|
|
tenv))))
|
|
(proc-iface rand-name rand-iface body-iface)))
|
|
)))
|
|
|
|
;; defns-to-decls : Listof(Defn) * Tenv -> Listof(Decl)
|
|
;; Page: 288, 305
|
|
;; Convert defns to a set of declarations for just the names defined
|
|
;; in defns. Do this in the context of tenv. The tenv is extended
|
|
;; at every step, so we get the correct let* scoping
|
|
(define defns-to-decls
|
|
(lambda (defns tenv)
|
|
(if (null? defns)
|
|
'()
|
|
(cases definition (car defns)
|
|
(val-defn (var-name exp)
|
|
(let ((ty (type-of exp tenv)))
|
|
(let ((new-env (extend-tenv var-name ty tenv)))
|
|
(cons
|
|
(val-decl var-name ty)
|
|
(defns-to-decls (cdr defns) new-env)))))
|
|
(type-defn (name ty)
|
|
(let ((new-env (extend-tenv-with-type
|
|
name
|
|
(expand-type ty tenv)
|
|
tenv)))
|
|
(cons
|
|
(transparent-type-decl name ty)
|
|
(defns-to-decls (cdr defns) new-env))))))))
|
|
|
|
(define raise-bad-module-application-error!
|
|
(lambda (expected-type rand-type body)
|
|
(pretty-print
|
|
(list 'bad-module-application body
|
|
'actual-rand-interface: rand-type
|
|
'expected-rand-interface: expected-type))
|
|
(eopl:error 'interface-of
|
|
"Bad module application ~s" body)))
|
|
|
|
(define report-module-doesnt-satisfy-iface
|
|
(lambda (m-name expected-type actual-type)
|
|
(pretty-print
|
|
(list 'error-in-defn-of-module: m-name
|
|
'expected-type: expected-type
|
|
'actual-type: actual-type))
|
|
(eopl:error 'type-of-module-defn)))
|