suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

merging 322:325 from sstrickl/branches

Browse Source 
This makes tenv and lenv, which were arguments to almost everything,
into parameters.  The only time they need to be set is after parsing
and before calling anything else, so there's one use in compile/defns
and one use in compile/interaction.

While I was at it, I took a lot of the infrequently-changing
arguments to typecheck-expression and made some typechecker-local
parameters also.

svn: r326
This commit is contained in:
Stevie Strickland 2005-07-04 18:40:02 +00:00
parent b13fb49c93
commit 39cb4f027f
14 changed files with 542 additions and 505 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
collects/honu/compile.ss
View File

@ -5,13 +5,13 @@
(lib "plt-match.ss")
"ast.ss"
"honu-context.ss"
"parameters.ss"
"readerr.ss"
"tenv.ss"
"tenv-utils.ss"
"parsers/post-parsing.ss"
"private/compiler/translate.ss"
"private/compiler/translate-expression.ss"
"private/compiler/translate-utils.ss"
"private/typechecker/type-utils.ss"
"private/typechecker/typechecker.ss"
"private/typechecker/typecheck-expression.ss")
@ -28,30 +28,33 @@
((syntax/c any/c)
(union honu:type? false/c)))])
(define (compile/defns tenv lenv pgm)
(let ([pgm (post-parse-program tenv (add-defns-to-tenv pgm tenv))])
(let ([checked (typecheck tenv lenv pgm)])
(parameterize ([current-compile-context honu-compile-context])
(translate tenv checked)))))
(parameterize ([current-type-environment tenv]
[current-lexical-environment lenv])
(let ([pgm (post-parse-program (add-defns-to-tenv pgm))])
(let ([checked (typecheck pgm)])
(parameterize ([current-compile-context honu-compile-context])
(translate checked))))))
(define (check-bound-names lenv names)
(define (check-bound-names names)
(for-each (lambda (n)
(if (and n (bound-identifier-mapping-get lenv n (lambda () #f)))
(if (and n (get-lenv-entry n))
(raise-read-error-with-stx
(format "~a already bound" (printable-key n))
n)))
names))
(define (compile/interaction tenv lenv ast)
(match (post-parse-interaction tenv ast)
[(struct honu:bind-top (stx names _ value))
(check-bound-names lenv names)
(let ([checked (typecheck-defn tenv lenv ast)])
(parameterize ([current-compile-context honu-compile-context])
(values (translate-defn tenv checked) #f)))]
[else
(let-values ([(checked type) (typecheck-expression tenv (lambda (n) #f)
(wrap-as-function lenv) (make-top-type #f) #f ast)])
(parameterize ([current-compile-context honu-compile-context])
(values (translate-expression tenv #f checked) type)))]))
(parameterize ([current-type-environment tenv]
[current-lexical-environment lenv])
(match (post-parse-interaction ast)
[(struct honu:bind-top (stx names _ value))
(check-bound-names names)
(let ([checked (typecheck-defn ast)])
(parameterize ([current-compile-context honu-compile-context])
(values (translate-defn checked) #f)))]
[else
(let-values ([(checked type) (typecheck-expression (wrap-lenv) (make-top-type #f) ast)])
(parameterize ([current-compile-context honu-compile-context])
(values (translate-expression #f checked) type)))])))
)

11
collects/honu/parameters.ss Normal file
View File

@ -0,0 +1,11 @@
(module parameters mzscheme
(provide (all-defined))
(define current-compile-context (make-parameter #f))
;; tenv and lenv, respectively
(define current-type-environment (make-parameter #f))
(define current-lexical-environment (make-parameter #f))
)

21
collects/honu/parsers/post-parsing.ss
View File

@ -4,6 +4,7 @@
(lib "plt-match.ss")
(lib "struct.ss")
"../ast.ss"
"../parameters.ss"
"../readerr.ss"
"../tenv.ss"
"../utils.ss")
@ -33,15 +34,15 @@
;;;; and so we no longer need to cover them.
(provide post-parse-program post-parse-interaction)
(define (post-parse-program tenv defns)
(convert-slots (convert-static tenv (check-this (simplify-ast defns)))))
(define (post-parse-program defns)
(convert-slots (convert-static (check-this (simplify-ast defns)))))
(define (post-parse-interaction tenv ast)
(define (post-parse-interaction ast)
(cond
[(honu:expr? ast)
(convert-static-expression (check-this-expression (simplify-expression ast) #f) '())]
[(honu:bind-top? ast)
(convert-static-defn tenv (check-this-defn (simplify-defn ast)))]))
(convert-static-defn (check-this-defn (simplify-defn ast)))]))
;
;
@ -58,10 +59,10 @@
;
;
(define (convert-static tenv defns)
(map (lambda (d) (convert-static-defn tenv d)) defns))
(define (convert-static defns)
(map convert-static-defn defns))
(define (convert-static-defn tenv defn)
(define (convert-static-defn defn)
(match defn
[(struct honu:iface (_ _ _ _))
defn]
@ -76,7 +77,7 @@
[(super-new)
(convert-static-super-new super-new env)]
[(env)
(extend-env-with-type-members tenv env arg-type)]
(extend-env-with-type-members env arg-type)]
[(members-after _)
(convert-static-members members-after env)])
(copy-struct honu:mixin defn
@ -90,8 +91,8 @@
[(struct honu:bind-top (_ _ _ _))
defn]))
(define (extend-env-with-type-members tenv env type)
(let ([type-entry (get-type-entry tenv type)])
(define (extend-env-with-type-members env type)
(let ([type-entry (get-type-entry type)])
(fold (lambda (m e)
(cons (tenv:member-name m) e))
env

56
collects/honu/private/compiler/translate-class-utils.ss
View File

@ -13,37 +13,37 @@
(define-struct comp:exp-bind (old new method?) #f)
(provide translate-class-exports translate-subclass-exports)
(define (translate-class-exports tenv exports)
(let ([exports (filter-exports tenv (generate-exports tenv exports))])
(define (translate-class-exports exports)
(let ([exports (filter-exports (generate-exports exports))])
(map (lambda (e)
(translate-export tenv #f #f e))
(translate-export #f #f e))
exports)))
(define (translate-subclass-exports tenv super-types arg-type exports)
(let ([exports (filter-exports tenv (generate-exports tenv exports))])
(define (translate-subclass-exports super-types arg-type exports)
(let ([exports (filter-exports (generate-exports exports))])
(map (lambda (e)
(if (ormap (lambda (t)
(<:_P tenv t (comp:export-type e)))
(<:_P t (comp:export-type e)))
super-types)
(translate-export tenv #t arg-type e)
(translate-export tenv #f arg-type e)))
(translate-export #t arg-type e)
(translate-export #f arg-type e)))
exports)))
(define (generate-super-exports tenv type-entry comp-binds)
(define (generate-super-exports type-entry comp-binds)
(let loop ([super-types (tenv:type-supers type-entry)]
[super-comp-exps '()])
(if (null? super-types)
super-comp-exps
(let ([super-entry (get-type-entry tenv (car super-types))])
(let ([super-entry (get-type-entry (car super-types))])
(let loop2 ([super-members (append (tenv:type-members super-entry)
(tenv:type-inherited super-entry))]
[super-comp-binds '()])
(if (null? super-members)
(loop (cdr super-types)
(cons (make-comp:export #f (car super-types) super-comp-binds)
(append (generate-super-exports tenv super-entry comp-binds)
(append (generate-super-exports super-entry comp-binds)
super-comp-exps)))
(let ([matched (find (lambda (eb)
(tenv-key=? (tenv:member-name (car super-members))
@ -53,19 +53,19 @@
(cons matched super-comp-binds)))))))))
(define (generate-exports tenv exports)
(define (generate-exports exports)
(let loop ([exports exports]
[comp-exps '()])
(if (null? exports)
comp-exps
(let* ([export (car exports)]
[type-entry (get-type-entry tenv (honu:export-type export))])
[type-entry (get-type-entry (honu:export-type export))])
(let loop2 ([exp-binds (honu:export-binds export)]
[members (append (tenv:type-members type-entry)
(tenv:type-inherited type-entry))]
[comp-binds '()])
(if (null? exp-binds)
(let ([super-exports (generate-super-exports tenv type-entry comp-binds)])
(let ([super-exports (generate-super-exports type-entry comp-binds)])
(loop (cdr exports)
(cons (make-comp:export (honu:ast-stx export)
(honu:export-type export)
@ -82,13 +82,13 @@
(honu:type-disp? (tenv:member-type matched)))
comp-binds)))))))))
(define (filter-exports tenv exports)
(define (filter-exports exports)
(let loop ([exports exports]
[kept-exps '()])
(if (null? exports)
kept-exps
(let-values ([(matches non-matches) (partition (lambda (exp)
(type-equal? tenv
(type-equal?
(comp:export-type (car exports))
(comp:export-type exp)))
exports)])
@ -97,31 +97,31 @@
(loop non-matches (cons exp-with-stx kept-exps))
(loop non-matches (cons (car exports) kept-exps))))))))
(define (translate-export tenv in-super? arg-type export)
(define (translate-export in-super? arg-type export)
(cons 'begin
(map (lambda (b)
(translate-exp-bind tenv in-super? arg-type (comp:export-type export) b))
(translate-exp-bind in-super? arg-type (comp:export-type export) b))
(comp:export-binds export))))
(define (translate-exp-bind tenv in-super? arg-type type binding)
(define (translate-exp-bind in-super? arg-type type binding)
(let ([right-defn (if in-super? 'define/override 'define/public)])
(match binding
[(struct comp:exp-bind (old-name new-name #t))
(at #f `(,right-defn (,(translate-method-name type new-name) arg-tuple)
,(translate-static-method tenv arg-type old-name 'arg-tuple)))]
,(translate-static-method arg-type old-name 'arg-tuple)))]
[(struct comp:exp-bind (old-name new-name #f))
(at #f `(begin
(,right-defn (,(translate-field-getter-name type new-name) args)
,(translate-static-field-getter tenv arg-type old-name))
,(translate-static-field-getter arg-type old-name))
(,right-defn (,(translate-field-setter-name type new-name) set-arg)
,(translate-static-field-setter tenv arg-type old-name 'set-arg))))])))
,(translate-static-field-setter arg-type old-name 'set-arg))))])))
(provide translate-super-new translate-inits translate-member)
(define (translate-super-new tenv arg-type super-new)
(define (translate-super-new arg-type super-new)
(at (honu:ast-stx super-new)
(cons 'super-new (map (lambda (a)
(list (at-ctxt (honu:name-arg-name a))
(translate-expression tenv arg-type (honu:name-arg-value a))))
(translate-expression arg-type (honu:name-arg-value a))))
(honu:super-new-args super-new)))))
(define (translate-inits inits)
@ -132,20 +132,20 @@
(define (mangle-init-name name)
(at name (string->symbol (string-append "init-" (symbol->string (syntax-e name))))))
(define (translate-member tenv arg-type member)
(define (translate-member arg-type member)
(match member
[(struct honu:init-field (stx name _ value))
(if value
`(begin (init ([,(mangle-init-name name) ,(at-ctxt name)]
,(translate-expression tenv arg-type value)))
,(translate-expression arg-type value)))
(define ,(at-ctxt name) ,(mangle-init-name)))
`(begin (init ([,(mangle-init-name name) ,(at-ctxt name)]))
(define ,(at-ctxt name) ,(mangle-init-name name))))]
[(struct honu:field (stx name _ value))
`(define ,(at-ctxt name) ,(translate-expression tenv arg-type value))]
`(define ,(at-ctxt name) ,(translate-expression arg-type value))]
[(struct honu:method (stx name _ formals body))
(translate-function stx name formals
(translate-expression tenv arg-type body))]))
(translate-expression arg-type body))]))
)

190
collects/honu/private/compiler/translate-expression.ss
View File

@ -8,10 +8,10 @@
"../typechecker/type-utils.ss"
"translate-utils.ss")
(provide/contract [translate-expression (tenv? (union honu:type? false/c) honu:expr?
(provide/contract [translate-expression ((union honu:type? false/c) honu:expr?
. -> .
(syntax/c any/c))])
(define (translate-expression tenv arg-type expr)
(define (translate-expression arg-type expr)
(match expr
[(struct honu:lit (stx _ value))
(at stx value)]
@ -20,54 +20,54 @@
[(struct honu:tuple (stx args))
;; list is a bindable name in Honu, so... we use list*, which isn't.
(at stx `(list* ,@(map (lambda (e)
(translate-expression tenv arg-type e))
(translate-expression arg-type e))
args)
()))]
[(struct honu:lambda (stx _ formals body))
(translate-function stx #f formals (translate-expression tenv arg-type body))]
(translate-function stx #f formals (translate-expression arg-type body))]
[(struct honu:call (stx func arg))
(match func
[(struct honu:member (stx 'my _ name #t))
(at stx (translate-static-method tenv arg-type name
(translate-expression tenv arg-type arg)))]
(at stx (translate-static-method arg-type name
(translate-expression arg-type arg)))]
[(struct honu:member (stx obj elab name #t))
(at stx `(honu:send ,(translate-expression tenv arg-type obj)
(at stx `(honu:send ,(translate-expression arg-type obj)
,(translate-method-name elab name)
,(translate-expression tenv arg-type arg)))]
,(translate-expression arg-type arg)))]
[else
(at stx `(,(translate-expression tenv arg-type func)
,(translate-expression tenv arg-type arg)))])]
(at stx `(,(translate-expression arg-type func)
,(translate-expression arg-type arg)))])]
[(struct honu:select (stx slot arg))
(at stx `(list-ref ,(translate-expression tenv arg-type arg)
(at stx `(list-ref ,(translate-expression arg-type arg)
(- ,slot 1)))]
[(struct honu:if (stx test then else))
(if else
(at stx `(if ,(translate-expression tenv arg-type test)
,(translate-expression tenv arg-type then)
,(translate-expression tenv arg-type else)))
(at stx `(if ,(translate-expression tenv arg-type test)
,(translate-expression tenv arg-type then)
(at stx `(if ,(translate-expression arg-type test)
,(translate-expression arg-type then)
,(translate-expression arg-type else)))
(at stx `(if ,(translate-expression arg-type test)
,(translate-expression arg-type then)
,void-value)))]
[(struct honu:cond (stx clauses else))
(if else
(at stx `(cond ,@(map (lambda (c)
`(,(translate-expression tenv arg-type (honu:cond-clause-pred c))
,(translate-expression tenv arg-type (honu:cond-clause-rhs c))))
`(,(translate-expression arg-type (honu:cond-clause-pred c))
,(translate-expression arg-type (honu:cond-clause-rhs c))))
clauses)
(else ,(translate-expression tenv arg-type else))))
(else ,(translate-expression arg-type else))))
(at stx `(cond ,@(map (lambda (c)
`(,(translate-expression tenv arg-type (honu:cond-clause-pred c))
,(translate-expression tenv arg-type (honu:cond-clause-rhs c))))
`(,(translate-expression arg-type (honu:cond-clause-pred c))
,(translate-expression arg-type (honu:cond-clause-rhs c))))
clauses)
(else ,void-value))))]
[(struct honu:un-op (stx op op-stx op-type arg))
(case op
[(not)
(at stx
`(,(at op-stx 'not) ,(translate-expression tenv arg-type arg)))]
`(,(at op-stx 'not) ,(translate-expression arg-type arg)))]
[(minus)
(at stx
`(,(at op-stx '-) ,(translate-expression tenv arg-type arg)))]
`(,(at op-stx '-) ,(translate-expression arg-type arg)))]
[else (raise-read-error-with-stx
"Haven't translated unary operator yet."
op-stx)])]
@ -78,222 +78,222 @@
(eqv? (honu:type-prim-name op-type) 'string))
(at stx
`(,(at op-stx 'string=?)
,(translate-expression tenv arg-type larg)
,(translate-expression tenv arg-type rarg)))
,(translate-expression arg-type larg)
,(translate-expression arg-type rarg)))
(at stx
`(,(at op-stx 'eqv?)
,(translate-expression tenv arg-type larg)
,(translate-expression tenv arg-type rarg))))]
,(translate-expression arg-type larg)
,(translate-expression arg-type rarg))))]
[(neq)
(if (and (honu:type-prim? op-type)
(eqv? (honu:type-prim-name op-type) 'string))
(at stx
`(,(at op-stx 'not)
(,(at op-stx 'string=?)
,(translate-expression tenv arg-type larg)
,(translate-expression tenv arg-type rarg))))
,(translate-expression arg-type larg)
,(translate-expression arg-type rarg))))
(at stx
`(,(at op-stx 'not)
(,(at op-stx 'eqv?)
,(translate-expression tenv arg-type larg)
,(translate-expression tenv arg-type rarg)))))]
,(translate-expression arg-type larg)
,(translate-expression arg-type rarg)))))]
[(clseq)
(at stx
`(,(at op-stx 'equal?)
,(translate-expression tenv arg-type larg)
,(translate-expression tenv arg-type rarg)))]
,(translate-expression arg-type larg)
,(translate-expression arg-type rarg)))]
[(and)
(at stx
`(,(at op-stx 'and)
,(translate-expression tenv arg-type larg)
,(translate-expression tenv arg-type rarg)))]
,(translate-expression arg-type larg)
,(translate-expression arg-type rarg)))]
[(or)
(at stx
`(,(at op-stx 'or)
,(translate-expression tenv arg-type larg)
,(translate-expression tenv arg-type rarg)))]
,(translate-expression arg-type larg)
,(translate-expression arg-type rarg)))]
[(lt)
(case (honu:type-prim-name op-type)
[(int float)
(at stx
`(,(at op-stx '<)
,(translate-expression tenv arg-type larg)
,(translate-expression tenv arg-type rarg)))]
,(translate-expression arg-type larg)
,(translate-expression arg-type rarg)))]
[(string)
(at stx
`(,(at op-stx 'string<?)
,(translate-expression tenv arg-type larg)
,(translate-expression tenv arg-type rarg)))]
,(translate-expression arg-type larg)
,(translate-expression arg-type rarg)))]
[(char)
(at stx
`(,(at op-stx 'char<?)
,(translate-expression tenv arg-type larg)
,(translate-expression tenv arg-type rarg)))])]
,(translate-expression arg-type larg)
,(translate-expression arg-type rarg)))])]
[(le)
(case (honu:type-prim-name op-type)
[(int float)
(at stx
`(,(at op-stx '<=)
,(translate-expression tenv arg-type larg)
,(translate-expression tenv arg-type rarg)))]
,(translate-expression arg-type larg)
,(translate-expression arg-type rarg)))]
[(string)
(at stx
`(,(at op-stx 'string<=?)
,(translate-expression tenv arg-type larg)
,(translate-expression tenv arg-type rarg)))]
,(translate-expression arg-type larg)
,(translate-expression arg-type rarg)))]
[(char)
(at stx
`(,(at op-stx 'char<=?)
,(translate-expression tenv arg-type larg)
,(translate-expression tenv arg-type rarg)))])]
,(translate-expression arg-type larg)
,(translate-expression arg-type rarg)))])]
[(gt)
(case (honu:type-prim-name op-type)
[(int float)
(at stx
`(,(at op-stx '>)
,(translate-expression tenv arg-type larg)
,(translate-expression tenv arg-type rarg)))]
,(translate-expression arg-type larg)
,(translate-expression arg-type rarg)))]
[(string)
(at stx
`(,(at op-stx 'string>?)
,(translate-expression tenv arg-type larg)
,(translate-expression tenv arg-type rarg)))]
,(translate-expression arg-type larg)
,(translate-expression arg-type rarg)))]
[(char)
(at stx
`(,(at op-stx 'char>?)
,(translate-expression tenv arg-type larg)
,(translate-expression tenv arg-type rarg)))])]
,(translate-expression arg-type larg)
,(translate-expression arg-type rarg)))])]
[(ge)
(case (honu:type-prim-name op-type)
[(int float)
(at stx
`(,(at op-stx '>=)
,(translate-expression tenv arg-type larg)
,(translate-expression tenv arg-type rarg)))]
,(translate-expression arg-type larg)
,(translate-expression arg-type rarg)))]
[(string)
(at stx
`(,(at op-stx 'string>=?)
,(translate-expression tenv arg-type larg)
,(translate-expression tenv arg-type rarg)))]
,(translate-expression arg-type larg)
,(translate-expression arg-type rarg)))]
[(char)
(at stx
`(,(at op-stx 'char>=?)
,(translate-expression tenv arg-type larg)
,(translate-expression tenv arg-type rarg)))])]
,(translate-expression arg-type larg)
,(translate-expression arg-type rarg)))])]
[(plus)
(case (honu:type-prim-name op-type)
[(int float)
(at stx
`(,(at op-stx '+)
,(translate-expression tenv arg-type larg)
,(translate-expression tenv arg-type rarg)))]
,(translate-expression arg-type larg)
,(translate-expression arg-type rarg)))]
[(string)
(at stx
`(,(at op-stx 'string-append)
,(translate-expression tenv arg-type larg)
,(translate-expression tenv arg-type rarg)))])]
,(translate-expression arg-type larg)
,(translate-expression arg-type rarg)))])]
[(minus)
(at stx
`(,(at op-stx '-)
,(translate-expression tenv arg-type larg)
,(translate-expression tenv arg-type rarg)))]
,(translate-expression arg-type larg)
,(translate-expression arg-type rarg)))]
[(times)
(at stx
`(,(at op-stx '*)
,(translate-expression tenv arg-type larg)
,(translate-expression tenv arg-type rarg)))]
,(translate-expression arg-type larg)
,(translate-expression arg-type rarg)))]
[(div)
(case (honu:type-prim-name op-type)
[(int)
(at stx
`(,(at op-stx 'quotient)
,(translate-expression tenv arg-type larg)
,(translate-expression tenv arg-type rarg)))]
,(translate-expression arg-type larg)
,(translate-expression arg-type rarg)))]
[(float)
(at stx
`(,(at op-stx '/)
,(translate-expression tenv arg-type larg)
,(translate-expression tenv arg-type rarg)))])]
,(translate-expression arg-type larg)
,(translate-expression arg-type rarg)))])]
[(mod)
(at stx
`(,(at op-stx 'remainder)
,(translate-expression tenv arg-type larg)
,(translate-expression tenv arg-type rarg)))]
,(translate-expression arg-type larg)
,(translate-expression arg-type rarg)))]
[else (raise-read-error-with-stx
"Haven't translated binary operator yet."
op-stx)])]
[(struct honu:return (stx body))
(at stx
`(last-k ,(translate-expression tenv arg-type body)))]
`(last-k ,(translate-expression arg-type body)))]
[(struct honu:let (stx bindings body))
(at stx
`(let*-values ,(map (lambda (b)
(let-values ([(bound-names body)
(translate-binding-clause (honu:binding-names b)
(translate-expression tenv arg-type (honu:binding-value b)))])
(translate-expression arg-type (honu:binding-value b)))])
;; make sure to give the let binding the appropriate syntax,
;; otherwise errors will highlight the entire let expression.
(at (honu:ast-stx b) `(,bound-names ,body))))
bindings)
,(translate-expression tenv arg-type body)))]
,(translate-expression arg-type body)))]
[(struct honu:seq (stx effects value))
(at stx
`(begin ,@(map (lambda (e)
(translate-expression tenv arg-type e))
(translate-expression arg-type e))
effects)
,(translate-expression tenv arg-type value)))]
,(translate-expression arg-type value)))]
[(struct honu:while (stx test body))
(at stx
`(let loop ()
(if ,(translate-expression tenv arg-type test)
(begin ,(translate-expression tenv arg-type body) (loop))
(if ,(translate-expression arg-type test)
(begin ,(translate-expression arg-type body) (loop))
,void-value)))]
[(struct honu:assn (stx lhs rhs))
(match lhs
[(struct honu:var (_ _))
(at stx `(begin (set! ,(translate-expression tenv arg-type lhs)
,(translate-expression tenv arg-type rhs))
(at stx `(begin (set! ,(translate-expression arg-type lhs)
,(translate-expression arg-type rhs))
,void-value))]
[(struct honu:member (mstx 'my _ name method?))
(if method?
(raise-read-error-with-stx
"Left-hand side of assignment cannot be a method name"
mstx)
(at stx (translate-static-field-setter tenv arg-type name
(translate-expression tenv arg-type rhs))))]
(at stx (translate-static-field-setter arg-type name
(translate-expression arg-type rhs))))]
[(struct honu:member (mstx obj elab name method?))
(if method?
(raise-read-error-with-stx
"Left-hand side of assignment cannot be a method name"
mstx)
(at stx `(honu:send ,(translate-expression tenv arg-type obj)
(at stx `(honu:send ,(translate-expression arg-type obj)
,(translate-field-setter-name elab name)
,(translate-expression tenv arg-type rhs))))]
,(translate-expression arg-type rhs))))]
[else
(raise-read-error-with-stx
"Left-hand side of assignment is invalid"
stx)])]
[(struct honu:member (stx 'my _ name method?))
(if method?
(at stx (translate-static-method tenv arg-type name))
(at stx (translate-static-field-getter tenv arg-type name)))]
(at stx (translate-static-method arg-type name))
(at stx (translate-static-field-getter arg-type name)))]
[(struct honu:member (stx obj elab name method?))
(if method?
(at stx `(lambda (args)
(honu:send ,(translate-expression tenv arg-type obj)
(honu:send ,(translate-expression arg-type obj)
,(translate-method-name elab name)
args)))
(at stx `(honu:send ,(translate-expression tenv arg-type obj)
(at stx `(honu:send ,(translate-expression arg-type obj)
,(translate-field-getter-name elab name)
,void-value)))]
[(struct honu:new (stx class _ args))
(at stx `(new ,(translate-class-name class)
,@(map (lambda (a)
`(,(honu:name-arg-name a)
,(translate-expression tenv arg-type (honu:name-arg-value a))))
,(translate-expression arg-type (honu:name-arg-value a))))
args)))]
[(struct honu:cast (stx obj type))
(at stx `(let ([cast-obj ,(translate-expression tenv arg-type obj)])
(at stx `(let ([cast-obj ,(translate-expression arg-type obj)])
;; you can always cast null to an interface type
(if (or (is-a? cast-obj null%)
(is-a? cast-obj ,(translate-iface-name type)))
@ -307,7 +307,7 @@
(string->symbol (substring class-string 0 (- (string-length class-string) 1))))
(quote ,(printable-type type))))))))]
[(struct honu:isa (stx obj type))
(at stx `(let ([cast-obj ,(translate-expression tenv arg-type obj)])
(at stx `(let ([cast-obj ,(translate-expression arg-type obj)])
;; null is a member of any interface type
(or (is-a? cast-obj null%)
(is-a? cast-obj ,(translate-iface-name type)))))]

16
collects/honu/private/compiler/translate-utils.ss
View File

@ -3,11 +3,9 @@
(require (all-except (lib "list.ss" "srfi" "1") any)
(lib "contract.ss")
"../../ast.ss"
"../../parameters.ss"
"../../tenv.ss")
(provide current-compile-context)
(define current-compile-context (make-parameter #f))
(define stx-for-original-property (read-syntax #f (open-input-string "original")))
(provide/contract [at ((union (syntax/c any/c) false/c)
@ -93,9 +91,9 @@
"-set!"))))
(provide translate-static-method translate-static-field-getter translate-static-field-setter)
(define (translate-static-method tenv arg-type name arg)
(define (translate-static-method arg-type name arg)
(if arg-type
(let ([type-entry (get-type-entry tenv arg-type)])
(let ([type-entry (get-type-entry arg-type)])
(if (s:member name
(map tenv:member-name (append (tenv:type-members type-entry)
(tenv:type-inherited type-entry)))
@ -111,9 +109,9 @@
`(,(at-ctxt name) ,arg)
(at-ctxt name))))
(define (translate-static-field-getter tenv arg-type name)
(define (translate-static-field-getter arg-type name)
(if arg-type
(let ([type-entry (get-type-entry tenv arg-type)])
(let ([type-entry (get-type-entry arg-type)])
(if (s:member name
(map tenv:member-name (append (tenv:type-members type-entry)
(tenv:type-inherited type-entry)))
@ -122,9 +120,9 @@
(at-ctxt name)))
(at-ctxt name)))
(define (translate-static-field-setter tenv arg-type name arg)
(define (translate-static-field-setter arg-type name arg)
(if arg-type
(let ([type-entry (get-type-entry tenv arg-type)])
(let ([type-entry (get-type-entry arg-type)])
(if (s:member name
(map tenv:member-name (append (tenv:type-members type-entry)
(tenv:type-inherited type-entry)))

52
collects/honu/private/compiler/translate.ss
View File

@ -11,13 +11,13 @@
"translate-expression.ss"
"translate-utils.ss")
(provide/contract [translate (tenv? (listof honu:defn?)
(provide/contract [translate ((listof honu:defn?)
. -> .
(listof (syntax/c any/c)))]
[translate-defn (tenv? honu:defn?
[translate-defn (honu:defn?
. -> .
(syntax/c any/c))])
(define (translate tenv defns)
(define (translate defns)
(let loop ([defns-to-go defns]
[syntaxes '()])
(cond
@ -30,13 +30,13 @@
(tenv-key=? (honu:mixin-name d)
(honu:subclass-mixin (car defns-to-go)))))
defns)])
(loop (cdr defns-to-go) (cons (translate-subclass tenv mixin (car defns-to-go)) syntaxes)))]
(loop (cdr defns-to-go) (cons (translate-subclass mixin (car defns-to-go)) syntaxes)))]
[else
(loop (cdr defns-to-go) (cons (translate-defn tenv (car defns-to-go)) syntaxes))])))
(loop (cdr defns-to-go) (cons (translate-defn (car defns-to-go)) syntaxes))])))
(define (translate-member-names tenv name)
(define (translate-member-names name)
(let* ([iface (make-iface-type name name)]
[type-entry (get-type-entry tenv iface)])
[type-entry (get-type-entry iface)])
(let loop ([members (append (tenv:type-members type-entry) (tenv:type-inherited type-entry))]
[names '()])
(if (null? members)
@ -50,38 +50,38 @@
(cons (translate-field-getter-name iface (tenv:member-name (car members)))
names))))))))
(define (translate-defn tenv defn)
(define (translate-defn defn)
(match defn
[(struct honu:bind-top (stx names _ value))
(let-values ([(bound-names body) (translate-binding-clause names (translate-expression tenv #f value))])
(let-values ([(bound-names body) (translate-binding-clause names (translate-expression #f value))])
(at stx `(define-values ,bound-names ,body)))]
[(struct honu:function (stx name _ args body))
(translate-function stx name args (translate-expression tenv #f body))]
(translate-function stx name args (translate-expression #f body))]
[(struct honu:iface (stx name supers members))
(at stx `(define ,(translate-iface-name (make-iface-type name name))
(interface ,(if (null? supers)
(list (translate-iface-name (make-any-type #f)))
(map translate-iface-name supers))
,@(translate-member-names tenv name))))]
,@(translate-member-names name))))]
[(struct honu:class (stx name _ _ impls inits members exports))
(at stx `(define ,(translate-class-name name)
(class* object% ,(map translate-iface-name impls)
(inspect #f)
,(translate-inits inits)
,@(map (lambda (m)
(translate-member tenv #f m)) members)
,@(translate-class-exports tenv exports)
,(translate-formatter tenv name members #f)
(translate-member #f m)) members)
,@(translate-class-exports exports)
,(translate-formatter name members #f)
(super-new))))]
[else (raise-read-error-with-stx
"Haven't translated that type of definition yet."
(honu:ast-stx defn))]))
(define (translate-subclass tenv mixin-defn defn)
(define (translate-subclass mixin-defn defn)
(match (list mixin-defn defn)
[(list (struct honu:mixin (mstx mname _ arg-type _ impls inits _ super-new members-before members-after exports))
(struct honu:subclass (stx name base mixin)))
(let* ([base-entry (get-class-entry tenv base)]
(let* ([base-entry (get-class-entry base)]
[base-types (cons (tenv:class-sub-type base-entry)
(tenv:class-impls base-entry))])
(at stx `(define ,(translate-class-name name)
@ -89,14 +89,14 @@
(inspect #f)
,(translate-inits inits)
,@(map (lambda (m)
(translate-member tenv arg-type m)) members-before)
,(translate-super-new tenv arg-type super-new)
(translate-member arg-type m)) members-before)
,(translate-super-new arg-type super-new)
,@(map (lambda (m)
(translate-member tenv arg-type m)) members-after)
,@(translate-subclass-exports tenv base-types arg-type exports)
,(translate-formatter tenv name (append members-before members-after) arg-type)))))]))
(translate-member arg-type m)) members-after)
,@(translate-subclass-exports base-types arg-type exports)
,(translate-formatter name (append members-before members-after) arg-type)))))]))
(define (translate-formatter tenv name members arg-type)
(define (translate-formatter name members arg-type)
(let ([right-define (if arg-type 'define/override 'define/public)])
`(,right-define (format-class renderer indent print-fields?)
(if print-fields?
@ -111,7 +111,7 @@
(if (not (honu:type-disp? (tenv:member-type m)))
(tenv:member-name m)
#f))
(tenv:type-members (get-type-entry tenv arg-type)))
(tenv:type-members (get-type-entry arg-type)))
'())]
;; how much more do we want the members indented? Let's try 2 spaces more.
[indent-delta 2])
@ -119,7 +119,7 @@
(null? printable-smembers))
'("")
(fold-right (lambda (m l)
(list* "\n" (translate-super-member-formatter tenv arg-type m indent-delta) l))
(list* "\n" (translate-super-member-formatter arg-type m indent-delta) l))
(fold-right (lambda (m l)
(list* "\n" (translate-member-formatter m indent-delta) l))
'("\n" (make-string indent #\space))
@ -137,11 +137,11 @@
;; the 3 is for " = "
(renderer ,name (+ indent ,(+ indent-delta (string-length (symbol->string (syntax-e name))) 3))))))
(define (translate-super-member-formatter tenv arg-type name indent-delta)
(define (translate-super-member-formatter arg-type name indent-delta)
`(format "~a~a = ~a;"
(make-string (+ indent ,indent-delta) #\space)
(quote ,(syntax-e name))
;; as before, the 3 is for " = "
(renderer ,(translate-static-field-getter tenv arg-type name)
(renderer ,(translate-static-field-getter arg-type name)
(+ indent ,(+ indent-delta (string-length (symbol->string (syntax-e name))) 3)))))
)

60
collects/honu/private/typechecker/type-utils.ss
View File

@ -82,7 +82,7 @@
"null"]))
(provide type-valid?)
(define (type-valid? tenv t)
(define (type-valid? t)
(match t
[(struct honu:type-iface-top (_)) #t]
[(struct honu:type-prim (stx name))
@ -92,22 +92,22 @@
(format "Unexpected primitive type ~a" name)
stx)])]
[(struct honu:type-iface (stx name))
(let ([tentry (get-tenv-entry tenv name)])
(let ([tentry (get-tenv-entry name)])
(and tentry (tenv:type? tentry)))]
[(struct honu:type-tuple (_ args))
(andmap (lambda (t)
(type-valid? tenv t))
(type-valid? t))
args)]
[(struct honu:type-func (_ arg ret))
(and (type-valid? tenv arg)
(type-valid? tenv ret))]
(and (type-valid? arg)
(type-valid? ret))]
[(struct honu:type-disp (_ disp arg ret))
(and (type-valid? tenv disp)
(type-valid? tenv arg)
(type-valid? tenv ret))]))
(and (type-valid? disp)
(type-valid? arg)
(type-valid? ret))]))
(provide type-equal?)
(define (type-equal? tenv t1 t2)
(define (type-equal? t1 t2)
(cond
;; first all the easy ones
[(and (honu:type-top? t1)
@ -135,13 +135,13 @@
;; function, dispatch types are equal if their component types are.
[(and (honu:type-func? t1)
(honu:type-func? t2))
(and (type-equal? tenv (honu:type-func-arg t1) (honu:type-func-arg t2))
(type-equal? tenv (honu:type-func-ret t1) (honu:type-func-ret t2)))]
(and (type-equal? (honu:type-func-arg t1) (honu:type-func-arg t2))
(type-equal? (honu:type-func-ret t1) (honu:type-func-ret t2)))]
[(and (honu:type-disp? t1)
(honu:type-disp? t2))
(and (type-equal? tenv (honu:type-disp-disp t1) (honu:type-disp-disp t2))
(type-equal? tenv (honu:type-disp-arg t1) (honu:type-disp-arg t2))
(type-equal? tenv (honu:type-disp-ret t1) (honu:type-disp-ret t2)))]
(and (type-equal? (honu:type-disp-disp t1) (honu:type-disp-disp t2))
(type-equal? (honu:type-disp-arg t1) (honu:type-disp-arg t2))
(type-equal? (honu:type-disp-ret t1) (honu:type-disp-ret t2)))]
;; tuple types are equal if they have the same number of components and
;; their components are pairwise equal
[(and (honu:type-tuple? t1)
@ -150,7 +150,7 @@
[t2-args (honu:type-tuple-args t2)])
(and (= (length t1-args) (length t2-args))
(andmap (lambda (t1 t2)
(type-equal? tenv t1 t2))
(type-equal? t1 t2))
t1-args t2-args)))]
;; for select types, they must be the same type on the same slot
;; (should we even get here?)
@ -169,8 +169,8 @@
#'Any]))
;; is t1 a _direct_ subtype of t2?
(define (Subtype_P tenv t1 t2)
(let ([type-entry (get-type-entry tenv t1)])
(define (Subtype_P t1 t2)
(let ([type-entry (get-type-entry t1)])
(match type-entry
[(struct tenv:type (_ supers _ _))
(let ([super-names (map get-type-name supers)])
@ -178,10 +178,10 @@
;; is t1 a (ref-trans-closed) subtype of t2?
(provide <:_P)
(define (<:_P tenv t1 t2)
(define (<:_P t1 t2)
(cond
;; if t1 = t2, t1 <:_P t2
[(type-equal? tenv t1 t2)
[(type-equal? t1 t2)
#t]
;; if t1 is the bottom of the type lattice, then it trivially holds
[(honu:type-bot? t1)
@ -197,15 +197,15 @@
[(and (honu:type-func? t1)
(honu:type-func? t2))
;; the arg is contravariant and the ret is covariant
(and (<:_P tenv (honu:type-func-arg t2) (honu:type-func-arg t1))
(<:_P tenv (honu:type-func-ret t1) (honu:type-func-ret t2)))]
(and (<:_P (honu:type-func-arg t2) (honu:type-func-arg t1))
(<:_P (honu:type-func-ret t1) (honu:type-func-ret t2)))]
;; for dispatch types...
[(and (honu:type-disp? t1)
(honu:type-disp? t2))
;; dispatch args must be co-, regular args contra-, and ret co-
(and (<:_P tenv (honu:type-disp-disp t1) (honu:type-disp-disp t2))
(<:_P tenv (honu:type-disp-arg t2) (honu:type-disp-arg t1))
(<:_P tenv (honu:type-disp-ret t1) (honu:type-disp-ret t2)))]
(and (<:_P (honu:type-disp-disp t1) (honu:type-disp-disp t2))
(<:_P (honu:type-disp-arg t2) (honu:type-disp-arg t1))
(<:_P (honu:type-disp-ret t1) (honu:type-disp-ret t2)))]
;; for tuple types...
[(and (honu:type-tuple? t1)
(honu:type-tuple? t2))
@ -215,7 +215,7 @@
(and (= (length t1-args) (length t2-args))
;; and each component must be a subtype (covariantly)
(andmap (lambda (t1 t2)
(<:_P tenv t1 t2))
(<:_P t1 t2))
t1-args t2-args)))]
;; for a select statement (s, t), we have that a tuple type (t_1 ... t_n) is <:_P t if
;; if t_s <:_P t.
@ -225,12 +225,12 @@
[t1-args (honu:type-tuple-args t1)])
(and (<= t2-slot (length t1-args))
;; we have to subtract one from t2-slot because list-ref is zero-based
(<:_P tenv (list-ref t1-args (- t2-slot 1)) (honu:type-select-type t2))))]
(<:_P (list-ref t1-args (- t2-slot 1)) (honu:type-select-type t2))))]
;; not sure if this is necessary. Hmm.
[(and (honu:type-select? t1)
(honu:type-select? t2))
(and (= (honu:type-select-slot t1) (honu:type-select-slot t2))
(<:_P tenv (honu:type-select-type t1) (honu:type-select-type t2)))]
(<:_P (honu:type-select-type t1) (honu:type-select-type t2)))]
;; the bottom of the iface lattice is <:_P either the iface-top or
;; any iface
[(and (honu:type-iface-bot? t1)
@ -244,14 +244,14 @@
;; if two (non-equal) iface types...
[(and (honu:type-iface? t1)
(honu:type-iface? t2))
(if (Subtype_P tenv t1 t2)
(if (Subtype_P t1 t2)
;; return true if it's a direct subtype relation
#t
(let ([type-entry (get-type-entry tenv t1)])
(let ([type-entry (get-type-entry t1)])
;; if any of the direct supertypes of t1 is a subtype of t2,
;; then t1 is also
(ormap (lambda (t)
(<:_P tenv t t2))
(<:_P t t2))
(tenv:type-supers type-entry))))]
[else #f]))

76
collects/honu/private/typechecker/typecheck-class-utils.ss
View File

@ -8,16 +8,17 @@
"../../tenv.ss"
"../../utils.ss"
"typecheck-expression.ss"
"typecheck-parameters.ss"
"type-utils.ss")
(provide extend-cenv-with-type-members typecheck-members typecheck-supernew typecheck-exports)
(define (typecheck-exports tenv cenv selftype init-impls exports)
(define (typecheck-exports cenv selftype init-impls exports)
(let loop ([impls init-impls]
[exports exports])
(cond
[(and (null? exports)
(null? impls))
(if (not (s:member selftype init-impls (lambda (t1 t2) (type-equal? tenv t1 t2))))
(if (not (s:member selftype init-impls (lambda (t1 t2) (type-equal? t1 t2))))
(raise-read-error-with-stx
(format "No export statement for self type ~a"
(printable-type selftype))
@ -31,21 +32,21 @@
(printable-type (car impls)))
(honu:ast-stx (car impls)))]
[(null? impls)
(if (s:member selftype init-impls (lambda (t1 t2) (type-equal? tenv t1 t2)))
(if (s:member selftype init-impls (lambda (t1 t2) (type-equal? t1 t2)))
(raise-read-error-with-stx
(format "Extra export statement for unimplemented type ~a"
(printable-type (honu:export-type (car exports))))
(honu:ast-stx (car exports)))
(let-values ([(matched non-matches) (partition-first (lambda (e)
(type-equal? tenv (honu:export-type e) selftype))
(type-equal? (honu:export-type e) selftype))
exports)])
(if (not matched)
(raise-read-error-with-stx
(format "No export statement for self type ~a"
(printable-type selftype))
(honu:ast-stx selftype))
(let ([type-entry (get-type-entry tenv selftype)])
(typecheck-export tenv cenv type-entry matched)
(let ([type-entry (get-type-entry selftype)])
(typecheck-export cenv type-entry matched)
(if (not (null? non-matches))
(raise-read-error-with-stx
(format "Extra export statement for unimplemented type ~a"
@ -54,19 +55,19 @@
(void))))))]
[else
(let-values ([(matched non-matches) (partition-first (lambda (t)
(type-equal? tenv (honu:export-type (car exports)) t))
(type-equal? (honu:export-type (car exports)) t))
impls)])
(if (not matched)
(raise-read-error-with-stx
(format "Extra export statement for unimplemented type ~a"
(honu:export-type (car exports)))
(honu:ast-stx (car exports)))
(let* ([type-entry (get-type-entry tenv matched)]
(let* ([type-entry (get-type-entry matched)]
[export (car exports)])
(typecheck-export tenv cenv type-entry export)
(typecheck-export cenv type-entry export)
(loop non-matches (cdr exports)))))])))
(define (typecheck-export tenv cenv type-entry export)
(define (typecheck-export cenv type-entry export)
;; make sure to use both defined members and inherited members here
(let loop ([type-members (append (tenv:type-members type-entry) (tenv:type-inherited type-entry))]
[export-binds (honu:export-binds export)])
@ -106,7 +107,7 @@
(honu:exp-bind-new (car export-binds)))]
;; if it's a method, then allow exporting a subtype
[(honu:type-disp? (tenv:member-type matched))
(if (<:_P tenv cenv-entry (tenv:member-type matched))
(if (<:_P cenv-entry (tenv:member-type matched))
(loop non-matches (cdr export-binds))
(raise-read-error-with-stx
(format "Exported static member ~a has type ~a which is not a subtype of ~a's type ~a"
@ -117,7 +118,7 @@
(honu:exp-bind-old (car export-binds))))]
;; for fields, we just do invariance until we get read-only fields
[else
(if (type-equal? tenv cenv-entry (tenv:member-type matched))
(if (type-equal? cenv-entry (tenv:member-type matched))
(loop non-matches (cdr export-binds))
(raise-read-error-with-stx
(format "Exported static member ~a has type ~a which is not the same type as ~a's type ~a"
@ -129,8 +130,8 @@
(define (extend-cenv-with-type-members tenv cenv type)
(let ([type-entry (get-type-entry tenv type)])
(define (extend-cenv-with-type-members cenv type)
(let ([type-entry (get-type-entry type)])
(fold (lambda (m e)
(extend-fenv (tenv:member-name m)
(tenv:member-type m)
@ -138,7 +139,7 @@
cenv
(tenv:type-members type-entry))))
(define (typecheck-supernew tenv cenv lenv withs supernew)
(define (typecheck-supernew cenv lenv withs supernew)
(let loop ([withs withs]
[args (honu:super-new-args supernew)]
[checked-args '()])
@ -168,10 +169,10 @@
(printable-key (honu:name-arg-name (car args))))
(honu:name-arg-name (car args)))
(let ([first-arg (car args)])
(let-values ([(e1 t1) (typecheck-expression tenv cenv lenv
(honu:formal-type matched)
(honu:formal-type matched)
(honu:name-arg-value first-arg))])
(let-values ([(e1 t1) (parameterize ([current-class-environment cenv])
(typecheck-expression lenv
(honu:formal-type matched)
(honu:name-arg-value first-arg)))])
(loop non-matches
(cdr args)
(cons (copy-struct honu:name-arg first-arg
@ -179,7 +180,7 @@
checked-args))))))])))
(define (typecheck-members tenv cenv lenv selftype members)
(define (typecheck-members cenv lenv selftype members)
(let loop ([members members]
[cenv cenv]
[ret '()])
@ -188,7 +189,7 @@
(values (reverse ret) cenv)]
[(or (honu:init-field? (car members))
(honu:field? (car members)))
(let ([member (typecheck-member tenv cenv lenv selftype (car members))])
(let ([member (typecheck-member cenv lenv selftype (car members))])
(loop (cdr members)
(extend-fenv (get-class-member-name (car members))
(get-class-member-type selftype (car members))
@ -207,48 +208,51 @@
;; I only through the reverse in to keep the order the same.
;; it doesn't really matter.
(append (reverse (map (lambda (m)
(typecheck-member tenv cenv lenv selftype m))
(typecheck-member cenv lenv selftype m))
methods))
ret))))])))
(define (typecheck-member tenv cenv lenv selftype member)
(define (typecheck-member cenv lenv selftype member)
(match member
[(struct honu:init-field (stx name type value))
(if (not (type-valid? tenv type))
(if (not (type-valid? type))
(raise-read-error-with-stx
"Type of init field is undefined"
(honu:ast-stx type)))
(if value
(let-values ([(e1 t1) (typecheck-expression tenv cenv (extend-fenv #'this selftype lenv) type #f value)])
(let-values ([(e1 t1) (parameterize ([current-class-environment cenv])
(typecheck-expression lenv type value))])
(copy-struct honu:init-field member
[honu:init-field-value e1]))
member)]
[(struct honu:field (stx name type value))
(if (not (type-valid? tenv type))
(if (not (type-valid? type))
(raise-read-error-with-stx
"Type of field is undefined"
(honu:ast-stx type)))
(let-values ([(e1 t1) (typecheck-expression tenv cenv (extend-fenv #'this selftype lenv) type #f value)])
(let-values ([(e1 t1) (parameterize ([current-class-environment cenv])
(typecheck-expression cenv lenv type value))])
(copy-struct honu:field member
[honu:field-value e1]))]
[(struct honu:method (stx name type args body))
(if (not (type-valid? tenv type))
(if (not (type-valid? type))
(raise-read-error-with-stx
"Return type of method is undefined"
(honu:ast-stx type)))
(for-each (lambda (t)
(if (not (type-valid? tenv t))
(if (not (type-valid? t))
(raise-read-error-with-stx
"Type of method argument is undefined"
(honu:ast-stx t))))
(map honu:formal-type args))
(let-values ([(e1 t1) (typecheck-expression tenv cenv (fold (lambda (arg fenv)
(extend-fenv (honu:formal-name arg)
(honu:formal-type arg)
fenv))
(extend-fenv #'this selftype lenv)
args)
type type body)])
(let-values ([(e1 t1) (parameterize ([current-class-environment cenv]
[current-return-type type])
(typecheck-expression (fold (lambda (arg fenv)
(extend-fenv (honu:formal-name arg)
(honu:formal-type arg)
fenv))
lenv args)
type body))])
(copy-struct honu:method member
[honu:method-body e1]))]))

242
collects/honu/private/typechecker/typecheck-expression.ss
View File

@ -8,39 +8,30 @@
"../../readerr.ss"
"../../tenv.ss"
"../../utils.ss"
"typecheck-parameters.ss"
"type-utils.ss")
(provide/contract [typecheck-expression ((tenv?
((syntax/c symbol?) . -> . (union honu:type? false/c))
((syntax/c symbol?) . -> . (union honu:type? false/c))
(union honu:type? false/c)
(provide/contract [typecheck-expression ((((syntax/c symbol?) . -> . (union honu:type? false/c))
(union honu:type? false/c)
honu:expr?)
. ->* .
(honu:expr?
honu:type?))])
;; tenv : tenv?
;; interface/class/mixin environment
;; cenv : ((syntax/c symbol?) . -> . (union honu:type false/c))
;; static environment inside of a class or mixin definition
;; (i.e. for my.<id>)
;; lenv : ((syntax/c symbol?) . -> . (union honu:type false/c))
;; lexical environment (includes top-level bindings and
;; binding for #'this if inside class or mixin)
;; ctype : (union honu:type? false/c)
;; type of context for expression
;; rtype : (union honu:type? false/c)
;; return type for method/function
;; expr : honu:expr?
;; expression to typecheck
(define (typecheck-expression tenv cenv lenv ctype rtype expr)
(define (typecheck-expression lenv ctype expr)
(match expr
[(struct honu:this (stx))
(cond
[(lenv #'this) => (lambda (t)
(if (<:_P tenv t ctype)
(if (<:_P t ctype)
(values expr t)
(raise-honu-type-error stx ctype t)))]
[else (raise-read-error-with-stx
@ -52,7 +43,7 @@
;; a) (>= (length args) n)
;; b) (type-equal? (list-ref args (- n 1)) t)
;; c) (list-ref args m) <:_P (type-top) for all m =/= n (vacuously true)
(let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-honu:type-select stx slot ctype) rtype arg)])
(let-values ([(e1 t1) (typecheck-expression lenv (make-honu:type-select stx slot ctype) arg)])
(if (not (honu:type-tuple? t1))
(raise-read-error-with-stx "Tried to use select with non-tuple expression" stx))
(let ([etype (list-ref (honu:type-tuple-args t1) (- slot 1))])
@ -62,7 +53,7 @@
[(struct honu:var (stx name))
(cond
[(lenv name) => (lambda (t)
(if (<:_P tenv t ctype)
(if (<:_P t ctype)
(values expr t)
(raise-honu-type-error stx ctype t)))]
[else (raise-read-error-with-stx
@ -70,44 +61,44 @@
stx)])]
[(struct honu:assn (stx lhs rhs))
;; the context type for the lhs is a vacuous one.
(let*-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-top-type (honu:ast-stx lhs)) rtype lhs)]
[(e2 t2) (typecheck-expression tenv cenv lenv t1 rtype rhs)])
(let*-values ([(e1 t1) (typecheck-expression lenv (make-top-type (honu:ast-stx lhs)) lhs)]
[(e2 t2) (typecheck-expression lenv t1 rhs)])
(let ([void-type (make-void-type stx)])
(if (<:_P tenv void-type ctype)
(if (<:_P void-type ctype)
(values (copy-struct honu:assn expr
[honu:assn-lhs e1]
[honu:assn-rhs e2])
void-type)
(raise-honu-type-error stx ctype void-type))))]
[(struct honu:call (stx func arg))
(let*-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-func-type (honu:ast-stx func)
(let*-values ([(e1 t1) (typecheck-expression lenv (make-func-type (honu:ast-stx func)
(make-bottom-type (honu:ast-stx func))
ctype) rtype func)]
[(e2 t2) (typecheck-expression tenv cenv lenv (honu:type-func-arg t1) rtype arg)])
ctype) func)]
[(e2 t2) (typecheck-expression lenv (honu:type-func-arg t1) arg)])
(let ([ret-type (honu:type-func-ret t1)])
(if (<:_P tenv ret-type ctype)
(if (<:_P ret-type ctype)
(values (copy-struct honu:call expr
[honu:call-func e1]
[honu:call-arg e2])
ret-type)
(raise-honu-type-error stx ctype ret-type))))]
[(struct honu:lit (stx type value))
(if (<:_P tenv type ctype)
(if (<:_P type ctype)
(values expr type)
(raise-honu-type-error stx ctype type))]
[(struct honu:un-op (stx op op-stx _ arg))
(case op
[(not)
(let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-bool-type (honu:ast-stx arg)) rtype arg)])
(let-values ([(e1 t1) (typecheck-expression lenv (make-bool-type (honu:ast-stx arg)) arg)])
(let ([ret-type (make-bool-type stx)])
(if (<:_P tenv ret-type ctype)
(if (<:_P ret-type ctype)
(values (copy-struct honu:un-op expr
[honu:un-op-op-type t1]
[honu:un-op-arg e1])
ret-type)
(raise-honu-type-error stx ctype ret-type))))]
[(minus)
(let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-top-type (honu:ast-stx arg)) rtype arg)])
(let-values ([(e1 t1) (typecheck-expression lenv (make-top-type (honu:ast-stx arg)) arg)])
(if (not (honu:type-prim? t1))
(raise-read-error-with-stx
"Invalid type for argument to unary minus"
@ -119,7 +110,7 @@
(format "Argument to unary minus must be int or float type, got ~a"
(printable-type t1))
(honu:ast-stx arg))])])
(if (<:_P tenv ret-type ctype)
(if (<:_P ret-type ctype)
(values (copy-struct honu:un-op expr
[honu:un-op-op-type t1]
[honu:un-op-arg e1])
@ -133,10 +124,10 @@
(case op
;; binary boolean operators
[(or and)
(let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-bool-type (honu:ast-stx larg)) rtype larg)]
[(e2 t2) (typecheck-expression tenv cenv lenv (make-bool-type (honu:ast-stx rarg)) rtype rarg)])
(let-values ([(e1 t1) (typecheck-expression lenv (make-bool-type (honu:ast-stx larg)) larg)]
[(e2 t2) (typecheck-expression lenv (make-bool-type (honu:ast-stx rarg)) rarg)])
(let ([ret-type (make-bool-type stx)])
(if (<:_P tenv ret-type ctype)
(if (<:_P ret-type ctype)
(values (copy-struct honu:bin-op expr
[honu:bin-op-op-type (make-bool-type (honu:ast-stx larg))]
[honu:bin-op-larg e1]
@ -144,10 +135,10 @@
ret-type)
(raise-honu-type-error stx ctype ret-type))))]
[(clseq)
(let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-any-type (honu:ast-stx larg)) rtype larg)]
[(e2 t2) (typecheck-expression tenv cenv lenv (make-any-type (honu:ast-stx rarg)) rtype rarg)])
(let-values ([(e1 t1) (typecheck-expression lenv (make-any-type (honu:ast-stx larg)) larg)]
[(e2 t2) (typecheck-expression lenv (make-any-type (honu:ast-stx rarg)) rarg)])
(let ([ret-type (make-bool-type stx)])
(if (<:_P tenv ret-type ctype)
(if (<:_P ret-type ctype)
(values (copy-struct honu:bin-op expr
[honu:bin-op-op-type (make-any-type (honu:ast-stx larg))]
[honu:bin-op-larg e1]
@ -155,15 +146,15 @@
ret-type)
(raise-honu-type-error stx ctype ret-type))))]
[(equal neq)
(let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-top-type (honu:ast-stx larg)) rtype larg)]
[(e2 t2) (typecheck-expression tenv cenv lenv (make-top-type (honu:ast-stx rarg)) rtype rarg)])
(let-values ([(e1 t1) (typecheck-expression lenv (make-top-type (honu:ast-stx larg)) larg)]
[(e2 t2) (typecheck-expression lenv (make-top-type (honu:ast-stx rarg)) rarg)])
(let ([ret-type (make-bool-type stx)]
[arg-type (cond
[(and (<:_P tenv t1 (make-any-type (honu:ast-stx larg)))
(<:_P tenv t2 (make-any-type (honu:ast-stx rarg))))
[(and (<:_P t1 (make-any-type (honu:ast-stx larg)))
(<:_P t2 (make-any-type (honu:ast-stx rarg))))
(make-any-type (honu:ast-stx larg))]
[(check-prim-types-for-binop stx tenv t1 t2) => (lambda (t) t)])])
(if (<:_P tenv ret-type ctype)
[(check-prim-types-for-binop stx t1 t2) => (lambda (t) t)])])
(if (<:_P ret-type ctype)
(values (copy-struct honu:bin-op expr
[honu:bin-op-op-type arg-type]
[honu:bin-op-larg e1]
@ -171,11 +162,11 @@
ret-type)
(raise-honu-type-error stx ctype ret-type))))]
[(le lt ge gt)
(let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-top-type (honu:ast-stx larg)) rtype larg)]
[(e2 t2) (typecheck-expression tenv cenv lenv (make-top-type (honu:ast-stx rarg)) rtype rarg)])
(let-values ([(e1 t1) (typecheck-expression lenv (make-top-type (honu:ast-stx larg)) larg)]
[(e2 t2) (typecheck-expression lenv (make-top-type (honu:ast-stx rarg)) rarg)])
(let ([ret-type (make-bool-type stx)]
[arg-type (check-prim-types-for-binop stx tenv t1 t2)])
(if (<:_P tenv ret-type ctype)
[arg-type (check-prim-types-for-binop stx t1 t2)])
(if (<:_P ret-type ctype)
(values (copy-struct honu:bin-op expr
[honu:bin-op-op-type arg-type]
[honu:bin-op-larg e1]
@ -183,12 +174,12 @@
ret-type)
(raise-honu-type-error stx ctype ret-type))))]
[(plus)
(let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-top-type (honu:ast-stx larg)) rtype larg)]
[(e2 t2) (typecheck-expression tenv cenv lenv (make-top-type (honu:ast-stx rarg)) rtype rarg)])
(let ([arg-type (check-prim-types-for-binop stx tenv t1 t2)])
(let-values ([(e1 t1) (typecheck-expression lenv (make-top-type (honu:ast-stx larg)) larg)]
[(e2 t2) (typecheck-expression lenv (make-top-type (honu:ast-stx rarg)) rarg)])
(let ([arg-type (check-prim-types-for-binop stx t1 t2)])
(case (honu:type-prim-name arg-type)
[(int float string)
(if (<:_P tenv arg-type ctype)
(if (<:_P arg-type ctype)
(values (copy-struct honu:bin-op expr
[honu:bin-op-op-type arg-type]
[honu:bin-op-larg e1]
@ -199,12 +190,12 @@
"The plus operator requires both arguments to be of type int, type float, or type string"
stx)])))]
[(minus times div)
(let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-top-type (honu:ast-stx larg)) rtype larg)]
[(e2 t2) (typecheck-expression tenv cenv lenv (make-top-type (honu:ast-stx rarg)) rtype rarg)])
(let ([arg-type (check-prim-types-for-binop stx tenv t1 t2)])
(let-values ([(e1 t1) (typecheck-expression lenv (make-top-type (honu:ast-stx larg)) larg)]
[(e2 t2) (typecheck-expression lenv (make-top-type (honu:ast-stx rarg)) rarg)])
(let ([arg-type (check-prim-types-for-binop stx t1 t2)])
(case (honu:type-prim-name arg-type)
[(int float)
(if (<:_P tenv arg-type ctype)
(if (<:_P arg-type ctype)
(values (copy-struct honu:bin-op expr
[honu:bin-op-op-type arg-type]
[honu:bin-op-larg e1]
@ -215,10 +206,10 @@
"Arithmetic operator requires both arguments to be of type int or type float"
stx)])))]
[(mod)
(let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-int-type (honu:ast-stx larg)) rtype larg)]
[(e2 t2) (typecheck-expression tenv cenv lenv (make-int-type (honu:ast-stx rarg)) rtype rarg)])
(let-values ([(e1 t1) (typecheck-expression lenv (make-int-type (honu:ast-stx larg)) larg)]
[(e2 t2) (typecheck-expression lenv (make-int-type (honu:ast-stx rarg)) rarg)])
(let ([ret-type (make-int-type stx)])
(if (<:_P tenv ret-type ctype)
(if (<:_P ret-type ctype)
(values (copy-struct honu:bin-op expr
[honu:bin-op-op-type (make-int-type (honu:ast-stx larg))]
[honu:bin-op-larg e1]
@ -236,19 +227,20 @@
(honu:formal-type f)
e))
lenv args)])
(let-values ([(body _) (typecheck-expression tenv cenv body-lenv ret-type ret-type body)])
(let-values ([(body _) (parameterize ([current-return-type ret-type])
(typecheck-expression body-lenv ret-type body))])
;; we also have the lambda's return type be what was explicitly annotated instead of what we got back
(let ([lam-type (make-func-type stx (make-tuple-type stx (map honu:formal-type args)) ret-type)])
(if (<:_P tenv lam-type ctype)
(if (<:_P lam-type ctype)
(values (copy-struct honu:lambda expr
[honu:lambda-body body])
lam-type)
(raise-honu-type-error stx ctype lam-type)))))]
[(struct honu:if (stx test then else))
(if else
(let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-bool-type (honu:ast-stx test)) rtype test)]
[(e2 t2) (typecheck-expression tenv cenv lenv ctype rtype then)]
[(e3 t3) (typecheck-expression tenv cenv lenv ctype rtype else)])
(let-values ([(e1 t1) (typecheck-expression lenv (make-bool-type (honu:ast-stx test)) test)]
[(e2 t2) (typecheck-expression lenv ctype then)]
[(e3 t3) (typecheck-expression lenv ctype else)])
;; this should work, but I get the following:
;; -- context expected 1 value, received 2 values: #<struct:honu:if> #<struct:honu:type-prim>
;; with the arrow going from values -> cond, so I'm going to rewrite as a nested-if for now.
@ -266,13 +258,13 @@
;; [honu:if-else e3])
;; ctype)]
;; if there was no ctype, then we require either t2 <: t3 or t3 <: t2, and we'll pick the supertype.
[(<:_P tenv t2 t3)
[(<:_P t2 t3)
(values (copy-struct honu:if expr
[honu:if-cond e1]
[honu:if-then e2]
[honu:if-else e3])
t3)]
[(<:_P tenv t3 t2)
[(<:_P t3 t2)
(values (copy-struct honu:if expr
[honu:if-cond e1]
[honu:if-then e2]
@ -284,10 +276,10 @@
"Branches of if statement are of unrelated types"
stx)]))
;; if else is #f, there was no else branch, so the then branch must be of void type.
(let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-bool-type (honu:ast-stx test)) rtype test)]
[(e2 t2) (typecheck-expression tenv cenv lenv (make-void-type (honu:ast-stx then)) rtype then)])
(let-values ([(e1 t1) (typecheck-expression lenv (make-bool-type (honu:ast-stx test)) test)]
[(e2 t2) (typecheck-expression lenv (make-void-type (honu:ast-stx then)) then)])
(let ([ret-type (make-void-type stx)])
(if (<:_P tenv ret-type ctype)
(if (<:_P ret-type ctype)
(values (copy-struct honu:if expr
[honu:if-cond e1]
[honu:if-then e2])
@ -296,46 +288,48 @@
"Found if expression without else branch in non-void context"
stx)))))]
[(struct honu:cast (stx obj type))
(if (not (type-valid? tenv type))
(if (not (type-valid? type))
(raise-read-error-with-stx
"Type argument of cast is not a valid type"
(honu:ast-stx type)))
(let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-any-type (honu:ast-stx obj)) rtype obj)])
(if (<:_P tenv type ctype)
(let-values ([(e1 t1) (typecheck-expression lenv (make-any-type (honu:ast-stx obj)) obj)])
(if (<:_P type ctype)
(values (copy-struct honu:cast expr
[honu:cast-obj e1])
type)
(raise-honu-type-error stx ctype type)))]
[(struct honu:isa (stx obj type))
(if (not (type-valid? tenv type))
(if (not (type-valid? type))
(raise-read-error-with-stx
"Type argument of isa is not a valid type"
(honu:ast-stx type)))
(let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-any-type (honu:ast-stx obj)) rtype obj)])
(let-values ([(e1 t1) (typecheck-expression lenv (make-any-type (honu:ast-stx obj)) obj)])
(let ([ret-type (make-bool-type stx)])
(if (<:_P tenv ret-type ctype)
(if (<:_P ret-type ctype)
(values (copy-struct honu:isa expr
[honu:isa-obj e1])
ret-type)
(raise-honu-type-error stx ctype ret-type))))]
[(struct honu:member (stx 'my _ name _))
(cond
[(cenv name) => (lambda (t)
(if (honu:type-disp? t)
(let ([fun-type (make-func-type (honu:ast-stx t) (honu:type-disp-arg t) (honu:type-disp-ret t))])
(if (<:_P tenv fun-type ctype)
(values (copy-struct honu:member expr
[honu:member-method? #t])
fun-type)
(raise-honu-type-error stx ctype fun-type)))
(if (<:_P tenv t ctype)
(values expr t)
(raise-honu-type-error stx ctype t))))]
[((current-class-environment) name)
=>
(lambda (t)
(if (honu:type-disp? t)
(let ([fun-type (make-func-type (honu:ast-stx t) (honu:type-disp-arg t) (honu:type-disp-ret t))])
(if (<:_P fun-type ctype)
(values (copy-struct honu:member expr
[honu:member-method? #t])
fun-type)
(raise-honu-type-error stx ctype fun-type)))
(if (<:_P t ctype)
(values expr t)
(raise-honu-type-error stx ctype t))))]
[else (raise-read-error-with-stx
(format "Static member ~a not found" (syntax-e name))
stx)])]
[(struct honu:member (stx obj _ name _))
(let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-any-type (honu:ast-stx obj)) rtype obj)])
(let-values ([(e1 t1) (typecheck-expression lenv (make-any-type (honu:ast-stx obj)) obj)])
;; if obj was something like error or return, which do not give us a valid type for
;; getting the appropriate member...
(if (honu:type-bot? t1)
@ -347,11 +341,11 @@
(raise-read-error-with-stx
"Null has no fields or methods"
stx))
(let ([t (get-member-type tenv t1 name)])
(let ([t (get-member-type t1 name)])
(cond
[(honu:type-disp? t)
(let ([fun-type (make-func-type (honu:ast-stx t) (honu:type-disp-arg t) (honu:type-disp-ret t))])
(if (<:_P tenv fun-type ctype)
(if (<:_P fun-type ctype)
(values (copy-struct honu:member expr
[honu:member-obj e1]
[honu:member-elab t1]
@ -359,7 +353,7 @@
fun-type)
(raise-honu-type-error stx ctype fun-type)))]
[t
(if (<:_P tenv t ctype)
(if (<:_P t ctype)
(values (copy-struct honu:member expr
[honu:member-obj e1]
[honu:member-elab t1])
@ -369,10 +363,10 @@
(format "Member ~a not found in type ~a" (syntax-e name) (printable-type t1))
stx)])))]
[(struct honu:new (stx class type args))
(let ([class-entry (get-class-entry tenv class)]
(let ([class-entry (get-class-entry class)]
[new-type (if type type ctype)])
;; the following can only be triggered if the type annontation isn't a type
(if (and type (not (type-valid? tenv type)))
(if (and type (not (type-valid? type)))
(raise-read-error-with-stx
(format "Type annotation ~a on new statement is not a valid type" (printable-type new-type))
(honu:ast-stx new-type)))
@ -381,34 +375,34 @@
(raise-read-error-with-stx
"type of instantiation must be explicitly annotated"
stx))
(if (not (<:_P tenv new-type (make-any-type stx)))
(if (not (<:_P new-type (make-any-type stx)))
(raise-read-error-with-stx
(format "new statement appears in context of non-interface type ~a"
(printable-type new-type))
stx))
;; the class must implement a subtype of the type we're instantiating it at
(if (not (ormap (lambda (t)
(<:_P tenv t new-type))
(<:_P t new-type))
(tenv:class-impls class-entry)))
(raise-read-error-with-stx
(format "class ~a does not implement a subtype of type ~a"
(printable-key class)
(printable-type new-type))
stx))
(let ([args (check-inits tenv stx (lambda (e t)
(typecheck-expression tenv cenv lenv t rtype e))
(let ([args (check-inits stx (lambda (e t)
(typecheck-expression lenv t e))
(tenv:class-inits class-entry) args)])
(if (<:_P tenv new-type ctype)
(if (<:_P new-type ctype)
(values (copy-struct honu:new expr
[honu:new-type new-type]
[honu:new-args args])
new-type)
(raise-honu-type-error stx ctype new-type))))]
[(struct honu:while (stx cond body))
(let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-bool-type (honu:ast-stx cond)) rtype cond)]
[(e2 t2) (typecheck-expression tenv cenv lenv (make-void-type (honu:ast-stx body)) rtype body)])
(let-values ([(e1 t1) (typecheck-expression lenv (make-bool-type (honu:ast-stx cond)) cond)]
[(e2 t2) (typecheck-expression lenv (make-void-type (honu:ast-stx body)) body)])
(let ([ret-type (make-void-type stx)])
(if (<:_P tenv ret-type ctype)
(if (<:_P ret-type ctype)
(values (copy-struct honu:while expr
[honu:while-cond e1]
[honu:while-body e2])
@ -417,9 +411,9 @@
[(struct honu:cond (stx clauses else))
(if else
(let-values ([(clauses types) (map-two-values (lambda (c)
(typecheck-cond-clause tenv cenv lenv ctype rtype c))
(typecheck-cond-clause lenv ctype c))
clauses)]
[(else etype) (typecheck-expression tenv cenv lenv ctype rtype else)])
[(else etype) (typecheck-expression lenv ctype else)])
(cond
;; if ctype exists, just use it
;;
@ -429,7 +423,7 @@
;; [honu:cond-clauses clauses])
;; ctype)]
;; otherwise find the most super type of all the branches
[(pick-super-type-from-list tenv (cons etype types))
[(pick-super-type-from-list (cons etype types))
=>
(lambda (t)
(values (copy-struct honu:cond expr
@ -443,11 +437,11 @@
stx)]))
;; if else is #f, there was no else branch, so the cond clauses must be of void type.
(let-values ([(clauses types) (map-two-values (lambda (c)
(typecheck-cond-clause tenv cenv lenv
(make-void-type (honu:ast-stx c)) rtype c))
(typecheck-cond-clause lenv
(make-void-type (honu:ast-stx c)) c))
clauses)])
(let ([ret-type (make-void-type stx)])
(if (<:_P tenv ret-type ctype)
(if (<:_P ret-type ctype)
(values (copy-struct honu:cond expr
[honu:cond-clauses clauses])
ret-type)
@ -458,9 +452,9 @@
;; returns don't return to their context, but to the context of the method or function call in which
;; they were invoked. Because of this a) rtype must not be #f (else we're not in a method or function
;; body) and b) the type of a return statement is the bottom type (same as error).
(if rtype
(if (current-return-type)
;; we use rtype as the context type here, since that's the type that needs to be returned.
(let-values ([(e1 _) (typecheck-expression tenv cenv lenv rtype rtype body)])
(let-values ([(e1 _) (typecheck-expression lenv (current-return-type) body)])
;; we don't need to check (bottom-type) <:_P ctype, because that's vacuously true.
(values (copy-struct honu:return expr
[honu:return-body e1])
@ -480,7 +474,7 @@
(length (honu:type-tuple-args ctype)))
stx))
(let-values ([(vals types) (map-two-values (lambda (e t)
(typecheck-expression tenv cenv lenv t rtype e))
(typecheck-expression lenv t e))
vals (honu:type-tuple-args ctype))])
(values (copy-struct honu:tuple expr
[honu:tuple-vals vals])
@ -494,7 +488,7 @@
(length vals))
stx))
(let-values ([(vals types) (map-two-values (lambda (e t)
(typecheck-expression tenv cenv lenv t rtype e))
(typecheck-expression lenv t e))
vals (gen-top-except-for (length vals)
(honu:type-select-slot ctype)
(honu:type-select-type ctype)))])
@ -506,8 +500,8 @@
;; we have no knowledge about what's wanted, we just check each component with ctype.
[(honu:type-top? ctype)
(let-values ([(vals types) (map-two-values (lambda (e)
(typecheck-expression tenv cenv lenv
(make-top-type (honu:ast-stx e)) rtype e))
(typecheck-expression lenv
(make-top-type (honu:ast-stx e)) e))
vals)])
(values (copy-struct honu:tuple expr
[honu:tuple-vals vals])
@ -517,19 +511,19 @@
stx)])]
[(struct honu:let (_ bindings body))
(let*-values ([(bindings lenv) (map-and-fold (lambda (bind lenv)
(typecheck-binding tenv cenv lenv rtype bind))
(typecheck-binding lenv bind))
lenv
bindings)]
[(e1 t1) (typecheck-expression tenv cenv lenv ctype rtype body)])
[(e1 t1) (typecheck-expression lenv ctype body)])
(values (copy-struct honu:let expr
[honu:let-bindings bindings]
[honu:let-body e1])
t1))]
[(struct honu:seq (_ effects value))
(let-values ([(effects _) (map-two-values (lambda (e)
(typecheck-expression tenv cenv lenv (make-void-type (honu:ast-stx e)) rtype e))
(typecheck-expression lenv (make-void-type (honu:ast-stx e)) e))
effects)]
[(e1 t1) (typecheck-expression tenv cenv lenv ctype rtype value)])
[(e1 t1) (typecheck-expression lenv ctype value)])
(values (copy-struct honu:seq expr
[honu:seq-effects effects]
[honu:seq-value e1])
@ -538,18 +532,18 @@
;; bindings have no ctype because they're always in the void type context
;; they return the elaborated binding and a new environment extended with the
;; type of the bound variable.
(define (typecheck-binding tenv cenv lenv rtype binding)
(define (typecheck-binding lenv binding)
(match binding
[(struct honu:binding (stx names types value))
(for-each (lambda (n t)
(if (and (not (and (not n)
(honu:type-top? t)))
(not (type-valid? tenv t)))
(not (type-valid? t)))
(raise-read-error-with-stx
"Type of locally bound variable is undefined"
(honu:ast-stx t))))
names types)
(let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-tuple-type (honu:ast-stx value) types) rtype value)])
(let-values ([(e1 t1) (typecheck-expression lenv (make-tuple-type (honu:ast-stx value) types) value)])
(values (copy-struct honu:binding binding
[honu:binding-value e1])
(fold (lambda (name type lenv)
@ -558,17 +552,17 @@
lenv))
lenv names types)))]))
(define (typecheck-cond-clause tenv cenv lenv ctype rtype clause)
(define (typecheck-cond-clause lenv ctype clause)
(match clause
[(struct honu:cond-clause (stx pred rhs))
(let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-bool-type (honu:ast-stx pred)) rtype pred)]
[(e2 t2) (typecheck-expression tenv cenv lenv ctype rtype rhs)])
(let-values ([(e1 t1) (typecheck-expression lenv (make-bool-type (honu:ast-stx pred)) pred)]
[(e2 t2) (typecheck-expression lenv ctype rhs)])
(values (copy-struct honu:cond-clause clause
[honu:cond-clause-pred e1]
[honu:cond-clause-rhs e2])
t2))]))
(define (check-prim-types-for-binop stx tenv t1 t2)
(define (check-prim-types-for-binop stx t1 t2)
(cond
[(and (honu:type-bot? t1)
(honu:type-prim? t2))
@ -578,7 +572,7 @@
t1]
[(and (honu:type-prim? t1)
(honu:type-prim? t2)
(type-equal? tenv t1 t2))
(type-equal? t1 t2))
t1]
[else
(raise-read-error-with-stx
@ -587,7 +581,7 @@
(printable-type t2))
stx)]))
(define (check-inits tenv stx type-fun inits new-args)
(define (check-inits stx type-fun inits new-args)
(let-values ([(new-args remaining-inits)
(map-and-fold (lambda (arg inits)
(let*-values ([(init remaining-inits)
@ -625,19 +619,19 @@
;; assumes a non-empty list
(define (pick-super-type-from-list tenv ts)
(define (pick-super-type-from-list ts)
(define (pick-super-type-with-acc ts t)
(cond
;; t is a super-type of all the other branches
[(andmap (lambda (t2)
(<:_P tenv t2 t))
(<:_P t2 t))
ts)
t]
;; if there's a type t2 in ts that is not equal to t
;; but t <:_P t2, then recur with t2 instead.
[(find (lambda (t2)
(and (not (type-equal? tenv t t2))
(<:_P tenv t t2)))
(and (not (type-equal? t t2))
(<:_P t t2)))
ts)
=>
(lambda (t)

22
collects/honu/private/typechecker/typecheck-parameters.ss Normal file
View File

@ -0,0 +1,22 @@
(module typecheck-parameters mzscheme
(provide (all-defined))
;; since the class-environment doesn't change within typecheck-expression, we make it a parameter
;; that we set before calling it.
;;
;; cenv : ((syntax/c symbol?) . -> . (union honu:type false/c))
;; static environment inside of a class or mixin definition
;; (i.e. for my.<id>)
(define current-class-environment (make-parameter (lambda (name) #f)))
;; since the return type only changes when we go into a lambda in typecheck-expression, we
;; make it a parameter also.
;;
;; rtype : (union honu:type? false/c)
;; return type for method/function
(define current-return-type (make-parameter #f))
)

97
collects/honu/private/typechecker/typechecker.ss
View File

@ -10,21 +10,16 @@
"../../utils.ss"
"typecheck-class-utils.ss"
"typecheck-expression.ss"
"typecheck-parameters.ss"
"type-utils.ss")
(provide/contract [typecheck (tenv?
tenv?
(listof honu:defn?)
(provide/contract [typecheck ((listof honu:defn?)
. -> .
(listof honu:defn?))]
[typecheck-defn (tenv?
tenv?
honu:defn?
[typecheck-defn (honu:defn?
. -> .
honu:defn?)])
;; since lenv is a hashtable and thus will be mutated, we don't need to return it from
;; typecheck or typecheck-defn.
(define (typecheck tenv lenv defns)
(define (typecheck defns)
(let loop ([defns defns]
[results '()])
(cond
@ -33,19 +28,19 @@
;; (i.e. if they are no intervening non-function definitions)
[(honu:function? (car defns))
(let-values ([(funcs remaining) (span honu:function? defns)])
(loop remaining (append (typecheck-functions tenv lenv funcs) results)))]
[else (loop (cdr defns) (cons (typecheck-defn tenv lenv (car defns)) results))])))
(loop remaining (append (typecheck-functions funcs) results)))]
[else (loop (cdr defns) (cons (typecheck-defn (car defns)) results))])))
(define (typecheck-functions tenv lenv funcs)
(define (typecheck-functions funcs)
(define (check-function-type func)
(match func
[(struct honu:function (stx name type args body))
(if (not (type-valid? tenv type))
(if (not (type-valid? type))
(raise-read-error-with-stx
"Return type of function is undefined"
(honu:ast-stx type)))
(for-each (lambda (t)
(if (not (type-valid? tenv t))
(if (not (type-valid? t))
(raise-read-error-with-stx
"Type of function argument is undefined"
(honu:ast-stx type))))
@ -54,9 +49,8 @@
;; first we add the functions to the lexical environment so that when we typecheck
;; the bodies, they'll be in scope.
(for-each (lambda (f)
(extend-tenv (honu:function-name f)
(make-tenv:value (honu:ast-stx f) (check-function-type f))
lenv))
(extend-lenv (honu:function-name f)
(make-tenv:value (honu:ast-stx f) (check-function-type f))))
funcs)
(let loop ([funcs funcs]
[new-funcs '()])
@ -66,61 +60,60 @@
new-funcs
(match (car funcs)
[(struct honu:function (stx name type args body))
(let-values ([(e1 t1) (typecheck-expression tenv (lambda (name) #f)
(fold (lambda (a e)
(extend-fenv (honu:formal-name a)
(honu:formal-type a)
e))
(wrap-as-function lenv)
args)
type type body)])
(let-values ([(e1 t1) (parameterize ([current-return-type type])
(typecheck-expression (fold (lambda (a e)
(extend-fenv (honu:formal-name a)
(honu:formal-type a)
e))
(wrap-lenv)
args)
type body))])
(loop (cdr funcs)
(cons (copy-struct honu:function (car funcs)
[honu:function-body e1])
new-funcs)))]))))
(define (typecheck-defn tenv lenv defn)
(define (typecheck-defn defn)
(match defn
[(struct honu:bind-top (stx names types value))
(for-each (lambda (n t)
(if (and (not (and (not n)
(honu:type-top? t)))
(not (type-valid? tenv t)))
(not (type-valid? t)))
(raise-read-error-with-stx
"Type of top-level bound variable is undefined"
(honu:ast-stx t))))
names types)
(let-values ([(e1 t1) (typecheck-expression tenv (lambda (name) #f) (wrap-as-function lenv)
(make-tuple-type stx types) #f value)])
(let-values ([(e1 t1) (typecheck-expression (wrap-lenv) (make-tuple-type stx types) value)])
(for-each (lambda (n t)
(if n (extend-tenv n (make-tenv:value stx t) lenv)))
(if n (extend-lenv n (make-tenv:value stx t))))
names types)
(copy-struct honu:bind-top defn
[honu:bind-top-value e1]))]
[(struct honu:iface (stx name supers members))
(for-each (lambda (t)
(if (not (type-valid? tenv t))
(if (not (type-valid? t))
(raise-read-error-with-stx
"No definition for supertype"
(honu:ast-stx t))))
supers)
(for-each (lambda (m)
(typecheck-member-decl tenv m))
(typecheck-member-decl m))
members)
defn]
[(struct honu:class (stx name type final? impls inits members exports))
(if (not (type-valid? tenv type))
(if (not (type-valid? type))
(raise-read-error-with-stx
"Self-type of class is undefined"
(honu:ast-stx type)))
(for-each (lambda (t)
(if (not (type-valid? tenv t))
(if (not (type-valid? t))
(raise-read-error-with-stx
"Implemented type is undefined"
(honu:ast-stx type))))
impls)
(for-each (lambda (t)
(if (not (type-valid? tenv t))
(if (not (type-valid? t))
(raise-read-error-with-stx
"Type of init slot is undefined"
(honu:ast-stx type))))
@ -131,34 +124,35 @@
e))
(lambda (n) #f)
inits)])
(let-values ([(members cenv) (typecheck-members tenv cenv (wrap-as-function lenv) type members)])
(typecheck-exports tenv cenv type impls exports)
(let*-values ([(lenv) (extend-fenv #'this type (wrap-lenv))]
[(members cenv) (typecheck-members cenv lenv type members)])
(typecheck-exports cenv type impls exports)
(copy-struct honu:class defn
[honu:class-members members])))]
[(struct honu:mixin (stx name type arg-type final? impls inits withs
supernew members-before members-after exports))
(if (not (type-valid? tenv arg-type))
(if (not (type-valid? arg-type))
(raise-read-error-with-stx
"Argument type of mixin is undefined"
(honu:ast-stx arg-type)))
(if (not (type-valid? tenv type))
(if (not (type-valid? type))
(raise-read-error-with-stx
"Result type of mixin is undefined"
(honu:ast-stx type)))
(for-each (lambda (t)
(if (not (type-valid? tenv t))
(if (not (type-valid? t))
(raise-read-error-with-stx
"Implemented type is undefined"
(honu:ast-stx type))))
impls)
(for-each (lambda (t)
(if (not (type-valid? tenv t))
(if (not (type-valid? t))
(raise-read-error-with-stx
"Type of init slot is undefined"
(honu:ast-stx type))))
(map honu:formal-type inits))
(for-each (lambda (t)
(if (not (type-valid? tenv t))
(if (not (type-valid? t))
(raise-read-error-with-stx
"Type of expected init slot is undefined"
(honu:ast-stx type))))
@ -169,11 +163,12 @@
e))
(lambda (n) #f)
inits)])
(let*-values ([(members-before cenv) (typecheck-members tenv cenv (wrap-as-function lenv) type members-before)]
[(supernew) (typecheck-supernew tenv cenv (wrap-as-function lenv) withs supernew)]
[(cenv) (extend-cenv-with-type-members tenv cenv arg-type)]
[(members-after cenv) (typecheck-members tenv cenv (wrap-as-function lenv) type members-after)])
(typecheck-exports tenv cenv type impls exports)
(let*-values ([(lenv) (extend-fenv #'this type (wrap-lenv))]
[(members-before cenv) (typecheck-members cenv lenv type members-before)]
[(supernew) (typecheck-supernew cenv lenv withs supernew)]
[(cenv) (extend-cenv-with-type-members cenv arg-type)]
[(members-after cenv) (typecheck-members cenv lenv type members-after)])
(typecheck-exports cenv type impls exports)
(copy-struct honu:mixin defn
[honu:mixin-members-before members-before]
[honu:mixin-super-new supernew]
@ -186,20 +181,20 @@
"Haven't typechecked that type of definition yet."
(honu:ast-stx defn))]))
(define (typecheck-member-decl tenv member)
(define (typecheck-member-decl member)
(match member
[(struct honu:field-decl (stx name type))
(if (not (type-valid? tenv type))
(if (not (type-valid? type))
(raise-read-error-with-stx
"Type of field is undefined"
stx))]
[(struct honu:method-decl (stx name type args))
(if (not (type-valid? tenv type))
(if (not (type-valid? type))
(raise-read-error-with-stx
"Return type of method is undefined"
(honu:ast-stx type)))
(for-each (lambda (t)
(if (not (type-valid? tenv t))
(if (not (type-valid? t))
(raise-read-error-with-stx
"Type of method argument is undefined"
(honu:ast-stx type))))

84
collects/honu/tenv-utils.ss
View File

@ -2,6 +2,7 @@
(require "readerr.ss"
"ast.ss"
"parameters.ss"
"tenv.ss"
"private/typechecker/type-utils.ss"
(lib "plt-match.ss")
@ -96,7 +97,7 @@
class-name)))))
(provide add-defns-to-tenv add-defn-to-tenv)
(define (add-defns-to-tenv defns tenv)
(define (add-defns-to-tenv defns)
(let loop ([defns defns]
[skipped '()]
[changed? #f]
@ -125,10 +126,10 @@
;; if we went through all the supers with them being defined,
;; then we can add this type as well.
[(null? supers)
(loop (cdr defns) skipped #t (cons (add-defn-to-tenv (car defns) tenv) new-defns))]
(loop (cdr defns) skipped #t (cons (add-defn-to-tenv (car defns)) new-defns))]
;; if there is an entry, we check to make sure it's a type, and
;; if it is, then we continue looping in the inner loop
[(get-tenv-entry tenv (car supers))
[(get-tenv-entry (car supers))
=>
(lambda (e)
(if (not (tenv:type? e))
@ -144,7 +145,7 @@
;; their entries, so we just run them through as we hit them.
[(or (honu:class? (car defns))
(honu:mixin? (car defns)))
(loop (cdr defns) skipped #t (cons (add-defn-to-tenv (car defns) tenv) new-defns))]
(loop (cdr defns) skipped #t (cons (add-defn-to-tenv (car defns)) new-defns))]
;; for structs, we will get back a list of two things: the new type
;; and the new class definition, so append those onto new-defns
[(honu:struct? (car defns))
@ -154,19 +155,19 @@
(make-struct-type-decls inits members))]
[new-class (make-honu:class stx name type final? (cons type impls) inits members
(cons (make-struct-export type inits members (list)) exports))])
(loop (cdr defns) skipped #t (cons (add-defn-to-tenv new-class tenv)
(cons (add-defn-to-tenv new-iface tenv) new-defns))))])]
(loop (cdr defns) skipped #t (cons (add-defn-to-tenv new-class)
(cons (add-defn-to-tenv new-iface) new-defns))))])]
;; for subclasses, we check to make sure the base (and its self-type) and
;; the mixin (and its arg-type) are in the tenv. If not, skip it.
;; Give appropriate errors for each thing that can go wrong.
[(honu:subclass? (car defns))
(let* ([base (get-tenv-entry tenv (honu:subclass-base (car defns)))]
(let* ([base (get-tenv-entry (honu:subclass-base (car defns)))]
[selftype (if (and base (tenv:class? base))
(get-tenv-entry tenv (honu:type-iface-name (tenv:class-sub-type base)))
(get-tenv-entry (honu:type-iface-name (tenv:class-sub-type base)))
#f)]
[mixin (get-tenv-entry tenv (honu:subclass-mixin (car defns)))]
[mixin (get-tenv-entry (honu:subclass-mixin (car defns)))]
[argtype (if (and mixin (tenv:mixin? mixin))
(get-tenv-entry tenv (honu:type-iface-name (tenv:mixin-arg-type mixin)))
(get-tenv-entry (honu:type-iface-name (tenv:mixin-arg-type mixin)))
#f)])
(cond
[(and base (not (tenv:class? base)))
@ -194,7 +195,7 @@
base))
;; if the base's selftype does not match the mixin's argtype,
;; we cannot apply the mixin to the base.
(if (not (<:_P tenv (tenv:class-sub-type base) (tenv:mixin-arg-type mixin)))
(if (not (<:_P (tenv:class-sub-type base) (tenv:mixin-arg-type mixin)))
(raise-read-error-with-stx
(format "Class ~a (~a) is not of an appropriate type (~a) for mixin ~a"
(printable-key (honu:subclass-base (car defns)))
@ -202,7 +203,7 @@
(printable-type (tenv:mixin-arg-type mixin))
(printable-key (honu:subclass-mixin (car defns))))
(honu:subclass-base (car defns))))
(loop (cdr defns) skipped #t (cons (add-defn-to-tenv (car defns) tenv) new-defns))]
(loop (cdr defns) skipped #t (cons (add-defn-to-tenv (car defns)) new-defns))]
;; if we get here, we cannot yet make the entry for this subclass,
;; so skip it.
[else
@ -214,7 +215,7 @@
(match (car defns)
[(struct honu:substruct (stx name type base arg-type final? impls inits withs super-new
members-before members-after exports))
(let ([argtype (get-tenv-entry tenv (honu:type-iface-name arg-type))])
(let ([argtype (get-tenv-entry (honu:type-iface-name arg-type))])
(cond
[(and argtype (not (tenv:type? argtype)))
(raise-read-error-with-stx
@ -235,13 +236,13 @@
(tenv:type-members argtype))
exports))]
[new-sclass (make-honu:subclass stx name base mixin-name)])
(loop (cons new-sclass (cdr defns)) skipped #t (cons (add-defn-to-tenv new-mixin tenv)
(cons (add-defn-to-tenv new-iface tenv) new-defns))))]
(loop (cons new-sclass (cdr defns)) skipped #t (cons (add-defn-to-tenv new-mixin)
(cons (add-defn-to-tenv new-iface) new-defns))))]
[else
(loop (cdr defns) (cons (car defns) skipped) changed? new-defns)]))])])))
(define (check-super-for-members tenv name members super-name)
(match (get-tenv-entry tenv super-name)
(define (check-super-for-members name members super-name)
(match (get-tenv-entry super-name)
[(struct tenv:type (_ _ super-members super-inherited))
;; here we make sure to use both defined members and inherited members
(let loop ([super-members (append super-members super-inherited)]
@ -261,7 +262,7 @@
;; if we eventually allow co-/contra-variance here, this is where
;; we'd do it.
(if (honu:type-disp? (tenv:member-type (car super-members)))
(if (<:_P tenv (tenv:member-type m) (tenv:member-type (car super-members)))
(if (<:_P (tenv:member-type m) (tenv:member-type (car super-members)))
(loop (cdr super-members) inherited)
(raise-read-error-with-stx
(format "Type ~a defines member ~a with type ~a, is not a subtype of type ~a as defined in supertype ~a"
@ -272,7 +273,7 @@
(printable-key super-name))
(tenv:member-stx m)))
;; this handles mutable fields -- we don't have immutable fields yet
(if (type-equal? tenv (tenv:member-type m) (tenv:member-type (car super-members)))
(if (type-equal? (tenv:member-type m) (tenv:member-type (car super-members)))
(loop (cdr super-members) inherited)
(raise-read-error-with-stx
(format "Type ~a defines member ~a with type ~a, was defined with type ~a in supertype ~a"
@ -297,7 +298,7 @@
(honu:type-disp-ret member-type))])
member)))
(define (type-equal-modulo-disp? tenv t1 t2)
(define (type-equal-modulo-disp? t1 t2)
(let ([t1 (if (honu:type-disp? t1)
(make-func-type (honu:ast-stx t1)
(honu:type-disp-arg t1)
@ -308,9 +309,9 @@
(honu:type-disp-arg t2)
(honu:type-disp-ret t2))
t2)])
(type-equal? tenv t1 t2)))
(type-equal? t1 t2)))
(define (check-and-remove-duplicate-members tenv subtype inherited-members)
(define (check-and-remove-duplicate-members subtype inherited-members)
(let loop ([inherited-members inherited-members]
[unique-members '()])
(if (null? inherited-members)
@ -331,8 +332,7 @@
;; (modulo the dispatch arguments of methods)
;;
;; doesn't matter which we keep, so we'll just keep the first one that matched.
[(type-equal-modulo-disp? tenv
(tenv:member-type current-member)
[(type-equal-modulo-disp? (tenv:member-type current-member)
(tenv:member-type (cdr (car matching-members))))
(loop2 (cdr matching-members))]
[else
@ -346,7 +346,7 @@
(printable-type (tenv:member-type (cdr (car matching-members)))))
subtype)])))))))
(define (add-defn-to-tenv defn tenv)
(define (add-defn-to-tenv defn)
(match defn
;; for types, we need to recur over our supertypes, make sure that we don't have any definitions that countermand
;; those in our super classes (which will also make sure that our superclass definitions are consistent), and
@ -358,25 +358,23 @@
;; we have to do this because members of the type can refer to the type itself.
;; this is only for <:_P checks.
(extend-tenv name
(make-tenv:type src-stx supers '() '())
tenv)
(make-tenv:type src-stx supers '() '()))
(let* ([tenv-members (convert-members (make-iface-type name name) members)]
[inherited-decls
(apply append (map (lambda (n) (check-super-for-members tenv name tenv-members n))
(apply append (map (lambda (n) (check-super-for-members name tenv-members n))
(map honu:type-iface-name supers)))]
[unique-inherited
;; remove duplicate entries for the same member name, making sure they match.
(check-and-remove-duplicate-members tenv name inherited-decls)])
(check-and-remove-duplicate-members name inherited-decls)])
(extend-tenv-without-checking name
(make-tenv:type src-stx supers tenv-members unique-inherited)
tenv)
(make-tenv:type src-stx supers tenv-members unique-inherited))
defn)]
;; for classes and mixins, just add a new appropriate entry.
[(struct honu:class (src-stx name t f? impls inits defns _))
(extend-tenv name (make-tenv:class src-stx t impls
(get-inits inits defns)
f? #f) tenv)
f? #f))
defn]
[(struct honu:mixin (src-stx name type arg-type final? impls inits
withs _ defns-before defns-after _))
@ -384,13 +382,13 @@
(get-inits inits
(append defns-before
defns-after))
withs final?) tenv)
withs final?))
defn]
;; all the heavy lifting of subclasses is in generate-subclass-tenv,
;; which does things like make sure that the withs of the mixin are satisfied
;; by the base, collects all the inits needed for the resulting class, etc.
[(struct honu:subclass (src-stx name base mixin))
(extend-tenv name (generate-subclass-tenv defn tenv) tenv)
(extend-tenv name (generate-subclass-tenv defn))
defn]))
(define (convert-members iface members)
@ -429,10 +427,10 @@
#t)))
init-fields))))
(define (generate-subclass-tenv defn tenv)
(let ([base (get-class-entry tenv (honu:subclass-base defn))]
[mixin (get-mixin-entry tenv (honu:subclass-mixin defn))])
(let ([new-inits (remove-used-inits tenv defn
(define (generate-subclass-tenv defn)
(let ([base (get-class-entry (honu:subclass-base defn))]
[mixin (get-mixin-entry (honu:subclass-mixin defn))])
(let ([new-inits (remove-used-inits defn
(tenv:class-inits base)
(tenv:mixin-withs mixin))])
(make-tenv:class (honu:ast-stx defn)
@ -443,7 +441,7 @@
(tenv:mixin-final? mixin)
(honu:subclass-base defn)))))
(define (remove-used-inits tenv defn old-inits withs)
(define (remove-used-inits defn old-inits withs)
(let loop ([old-inits old-inits]
[withs withs]
[new-inits '()])
@ -460,7 +458,7 @@
(tenv-key=? (honu:formal-name w) (tenv:init-name curr)))
withs)])
(if index
(if (<:_P tenv (honu:formal-type (list-ref withs index)) (tenv:init-type curr))
(if (<:_P (honu:formal-type (list-ref withs index)) (tenv:init-type curr))
(loop (cdr old-inits)
(append (take withs index)
(drop withs (+ index 1)))
@ -474,7 +472,9 @@
withs
(cons curr new-inits)))))))
(provide display-lenv display-tenv)
(provide display-lenv display-current-lenv display-tenv display-current-tenv)
(define (display-current-lenv)
(display-lenv (current-lexical-environment)))
(define (display-lenv lenv)
(tenv-for-each lenv
(lambda (k v)
@ -482,6 +482,8 @@
(printable-key k)
(printable-type (tenv:value-type v)))))))
(define (display-current-tenv)
(display-lenv (current-type-environment)))
(define (display-tenv tenv)
(tenv-for-each tenv
(lambda (k v)

81
collects/honu/tenv.ss
View File

@ -4,6 +4,7 @@
(lib "boundmap.ss" "syntax")
(lib "contract.ss")
"ast.ss"
"parameters.ss"
"readerr.ss")
(provide (struct tenv:entry (stx))
@ -99,22 +100,24 @@
(provide/contract [empty-tenv (-> tenv?)]
[get-builtin-lenv (-> tenv?)]
[extend-tenv (identifier? tenv:entry? tenv? . -> . void?)]
[extend-tenv-without-checking (identifier? tenv:entry? tenv? . -> . void?)]
[create-tenv ((listof identifier?)
(listof tenv:entry?)
. -> .
tenv?)])
[extend-tenv (identifier? tenv:entry? . -> . void?)]
[extend-lenv (identifier? tenv:value? . -> . void?)]
[extend-tenv-without-checking (identifier? tenv:entry? . -> . void?)])
(define (empty-tenv) (make-bound-identifier-mapping))
(define (get-builtin-lenv)
(let ([tenv (empty-tenv)])
(for-each (lambda (n t)
(extend-tenv n (make-tenv:value #f t) tenv))
(map car builtin-list)
(map cdr builtin-list))
tenv))
(define (extend-tenv key val tenv)
(if (get-tenv-entry tenv key)
(create-tenv (map car builtin-list)
(map (lambda (p)
(make-tenv:value (car p) (cdr p))) builtin-list)))
(define (extend-tenv key val)
(extend-tenv/checks key val (current-type-environment)))
(define (extend-lenv key val)
(extend-tenv/checks key val (current-lexical-environment)))
(define (extend-tenv-without-checking key val)
(extend-tenv/no-checks key val (current-type-environment)))
(define (extend-tenv/checks key val tenv)
(if (bound-identifier-mapping-get tenv key (lambda () #f))
(if (eqv? (string-ref (symbol->string (printable-key key)) 0) #\$)
(raise-read-error-with-stx
(format "~a already bound by a subclass or substruct"
@ -124,33 +127,36 @@
(format "~a already bound by top-level definition" (printable-key key))
key))
(bound-identifier-mapping-put! tenv key val)))
(define (extend-tenv-without-checking key val tenv)
(define (extend-tenv/no-checks key val tenv)
(bound-identifier-mapping-put! tenv key val))
(define (create-tenv keys vals)
(let ((table (empty-tenv)))
(begin (for-each extend-tenv table keys vals)
(begin (for-each (lambda (k v)
(extend-tenv/checks k v table))
keys vals)
table)))
;; only use this if you a) don't want an error or b) don't know what you should get.
(provide/contract [get-tenv-entry (tenv? identifier? . -> . (union tenv:entry? false/c))])
(define (get-tenv-entry tenv key)
(bound-identifier-mapping-get tenv key (lambda () #f)))
(provide/contract [get-tenv-entry (identifier? . -> . (union tenv:entry? false/c))]
[get-lenv-entry (identifier? . -> . (union tenv:entry? false/c))])
(define (get-tenv-entry key)
(bound-identifier-mapping-get (current-type-environment) key (lambda () #f)))
(define (get-lenv-entry key)
(bound-identifier-mapping-get (current-lexical-environment) key (lambda () #f)))
(provide/contract [get-type-entry (tenv?
(union honu:type-iface?
(provide/contract [get-type-entry ((union honu:type-iface?
honu:type-iface-top?) . -> . tenv:type?)]
[get-class-entry (tenv? identifier? . -> . tenv:class?)]
[get-mixin-entry (tenv? identifier? . -> . tenv:mixin?)]
[get-member-type (tenv?
(union honu:type-iface?
[get-class-entry (identifier? . -> . tenv:class?)]
[get-mixin-entry (identifier? . -> . tenv:mixin?)]
[get-member-type ((union honu:type-iface?
honu:type-iface-top?)
identifier? . -> . honu:type?)]
[get-value-entry (tenv? identifier? . -> . tenv:value?)])
(define (get-type-entry tenv type)
[get-value-entry (identifier? . -> . tenv:value?)])
(define (get-type-entry type)
(if (honu:type-iface-top? type)
(make-tenv:type #f (list) (list) (list))
(let* ([name (honu:type-iface-name type)]
[entry (get-tenv-entry tenv name)])
[entry (get-tenv-entry name)])
(cond
[(not entry)
(raise-read-error-with-stx
@ -161,8 +167,8 @@
(format "Definition of ~a is not a type" (printable-key name))
name)]
[else entry]))))
(define (get-class-entry tenv name)
(let ([entry (get-tenv-entry tenv name)])
(define (get-class-entry name)
(let ([entry (get-tenv-entry name)])
(cond
[(not entry)
(raise-read-error-with-stx
@ -173,8 +179,8 @@
(format "Definition of ~a is not a class" (printable-key name))
name)]
[else entry])))
(define (get-mixin-entry tenv name)
(let ([entry (get-tenv-entry tenv name)])
(define (get-mixin-entry name)
(let ([entry (get-tenv-entry name)])
(cond
[(not entry)
(raise-read-error-with-stx
@ -185,8 +191,8 @@
(format "Definition of ~a is not a mixin" (printable-key name))
name)]
[else entry])))
(define (get-member-type tenv type name)
(let* ([entry (get-type-entry tenv type)]
(define (get-member-type type name)
(let* ([entry (get-type-entry type)]
[mtype (find (lambda (m)
(tenv-key=? (tenv:member-name m) name))
(append (tenv:type-members entry)
@ -200,8 +206,8 @@
'Any
(printable-key (honu:type-iface-name type))))
name))))
(define (get-value-entry tenv name)
(let ([entry (get-tenv-entry tenv name)])
(define (get-value-entry name)
(let ([entry (get-lenv-entry name)])
(cond
[(not entry)
(raise-read-error-with-stx
@ -213,8 +219,9 @@
name)]
[else entry])))
(provide wrap-as-function extend-fenv)
(provide wrap-lenv extend-fenv)
(define (wrap-lenv) (wrap-as-function (current-lexical-environment)))
(define (wrap-as-function tenv)
(lambda (name)
(let ([entry (bound-identifier-mapping-get tenv name (lambda () #f))])