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.
120 lines
4.5 KiB
Racket
Executable File
120 lines
4.5 KiB
Racket
Executable File
#lang eopl
|
|
|
|
(require "lang.rkt")
|
|
(require "static-data-structures.rkt")
|
|
(require "expand-type.rkt")
|
|
(require "renaming.rkt")
|
|
|
|
(provide <:-iface)
|
|
|
|
;; <:-iface : Iface * Iface * Tenv -> Bool
|
|
;; Page: 289, 323
|
|
(define <:-iface
|
|
(lambda (iface1 iface2 tenv)
|
|
(cases interface iface1
|
|
(simple-iface (decls1)
|
|
(cases interface iface2
|
|
(simple-iface (decls2)
|
|
(<:-decls decls1 decls2 tenv))
|
|
(else #f)))
|
|
(proc-iface (param-name1 param-iface1 result-iface1)
|
|
(cases interface iface2
|
|
(proc-iface (param-name2 param-iface2 result-iface2)
|
|
;; first we rename the param names to the same fresh name
|
|
(let ((new-name (fresh-module-name param-name1)))
|
|
(let ((result-iface1
|
|
(rename-in-iface
|
|
result-iface1 param-name1 new-name))
|
|
(result-iface2
|
|
(rename-in-iface
|
|
result-iface2 param-name2 new-name)))
|
|
(and
|
|
(<:-iface param-iface2 param-iface1 tenv)
|
|
(<:-iface result-iface1 result-iface2
|
|
(extend-tenv-with-module
|
|
new-name
|
|
(expand-iface new-name param-iface1 tenv)
|
|
tenv))))))
|
|
(else #f))))))
|
|
|
|
;; s1 <: s2 iff s1 has at least as much stuff as s2, and in the same
|
|
;; order. We walk down s1 until we find a declaration that declares
|
|
;; the same name as the first component of s2. If we run off the
|
|
;; end of s1, then we fail. As we walk down s1, we record any type
|
|
;; bindings in the tenv
|
|
|
|
;; <:-decls : Listof(Decl) * Listof(Decl) * Tenv -> Bool
|
|
;; Page: 289, 305
|
|
(define <:-decls
|
|
(lambda (decls1 decls2 tenv)
|
|
(cond
|
|
;; if nothing in decls2, any decls1 will do
|
|
((null? decls2) #t)
|
|
;; nothing in decls1 to match, so false
|
|
((null? decls1) #f)
|
|
(else
|
|
;; at this point we know both decls1 and decls2 are non-empty.
|
|
(let ((name1 (decl->name (car decls1)))
|
|
(name2 (decl->name (car decls2))))
|
|
(if (eqv? name1 name2)
|
|
;; same name. They'd better match
|
|
(and
|
|
(<:-decl (car decls1) (car decls2) tenv)
|
|
(<:-decls (cdr decls1) (cdr decls2)
|
|
(extend-tenv-with-decl (car decls1) tenv)))
|
|
;; different names. OK to skip, but record decl1 in the tenv.
|
|
(<:-decls (cdr decls1) decls2
|
|
(extend-tenv-with-decl (car decls1) tenv))))))))
|
|
|
|
;; extend-tenv-with-decl : Decl * Tenv -> Tenv
|
|
;; Page: 309
|
|
(define extend-tenv-with-decl
|
|
(lambda (decl tenv)
|
|
(cases declaration decl
|
|
;; don't need to record val declarations
|
|
(val-decl (name ty) tenv)
|
|
(transparent-type-decl (name ty)
|
|
(extend-tenv-with-type
|
|
name
|
|
(expand-type ty tenv)
|
|
tenv))
|
|
(opaque-type-decl (name)
|
|
(extend-tenv-with-type
|
|
name
|
|
;; the module name doesn't matter, since the only
|
|
;; operation on qualified types is equal?
|
|
(qualified-type (fresh-module-name '%abstype) name)
|
|
tenv)))))
|
|
|
|
;; decl1 and decl2 are known to declare the same name. There are
|
|
;; exactly four combinations that can succeed.
|
|
|
|
;; <:-decl : Decl * Decl * Tenv -> Bool
|
|
;; Page: 311
|
|
(define <:-decl
|
|
(lambda (decl1 decl2 tenv)
|
|
(or
|
|
(and
|
|
(val-decl? decl1)
|
|
(val-decl? decl2)
|
|
(equiv-type? (decl->type decl1) (decl->type decl2) tenv))
|
|
(and
|
|
(transparent-type-decl? decl1)
|
|
(transparent-type-decl? decl2)
|
|
(equiv-type? (decl->type decl1) (decl->type decl2) tenv))
|
|
(and
|
|
(transparent-type-decl? decl1)
|
|
(opaque-type-decl? decl2))
|
|
(and
|
|
(opaque-type-decl? decl1)
|
|
(opaque-type-decl? decl2))
|
|
)))
|
|
|
|
;; equiv-type? : Type * Type * Tenv -> Bool
|
|
;; Page: 311
|
|
(define equiv-type?
|
|
(lambda (ty1 ty2 tenv)
|
|
(equal?
|
|
(expand-type ty1 tenv)
|
|
(expand-type ty2 tenv))))
|