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

29
collects/honu/compile.ss
View File

@ -5,13 +5,13 @@
(lib "plt-match.ss") (lib "plt-match.ss")
"ast.ss" "ast.ss"
"honu-context.ss" "honu-context.ss"
"parameters.ss"
"readerr.ss" "readerr.ss"
"tenv.ss" "tenv.ss"
"tenv-utils.ss" "tenv-utils.ss"
"parsers/post-parsing.ss" "parsers/post-parsing.ss"
"private/compiler/translate.ss" "private/compiler/translate.ss"
"private/compiler/translate-expression.ss" "private/compiler/translate-expression.ss"
"private/compiler/translate-utils.ss"
"private/typechecker/type-utils.ss" "private/typechecker/type-utils.ss"
"private/typechecker/typechecker.ss" "private/typechecker/typechecker.ss"
"private/typechecker/typecheck-expression.ss") "private/typechecker/typecheck-expression.ss")
@ -28,30 +28,33 @@
((syntax/c any/c) ((syntax/c any/c)
(union honu:type? false/c)))]) (union honu:type? false/c)))])
(define (compile/defns tenv lenv pgm) (define (compile/defns tenv lenv pgm)
(let ([pgm (post-parse-program tenv (add-defns-to-tenv pgm tenv))]) (parameterize ([current-type-environment tenv]
(let ([checked (typecheck tenv lenv pgm)]) [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]) (parameterize ([current-compile-context honu-compile-context])
(translate tenv checked))))) (translate checked))))))
(define (check-bound-names lenv names) (define (check-bound-names names)
(for-each (lambda (n) (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 (raise-read-error-with-stx
(format "~a already bound" (printable-key n)) (format "~a already bound" (printable-key n))
n))) n)))
names)) names))
(define (compile/interaction tenv lenv ast) (define (compile/interaction tenv lenv ast)
(match (post-parse-interaction tenv ast) (parameterize ([current-type-environment tenv]
[current-lexical-environment lenv])
(match (post-parse-interaction ast)
[(struct honu:bind-top (stx names _ value)) [(struct honu:bind-top (stx names _ value))
(check-bound-names lenv names) (check-bound-names names)
(let ([checked (typecheck-defn tenv lenv ast)]) (let ([checked (typecheck-defn ast)])
(parameterize ([current-compile-context honu-compile-context]) (parameterize ([current-compile-context honu-compile-context])
(values (translate-defn tenv checked) #f)))] (values (translate-defn checked) #f)))]
[else [else
(let-values ([(checked type) (typecheck-expression tenv (lambda (n) #f) (let-values ([(checked type) (typecheck-expression (wrap-lenv) (make-top-type #f) ast)])
(wrap-as-function lenv) (make-top-type #f) #f ast)])
(parameterize ([current-compile-context honu-compile-context]) (parameterize ([current-compile-context honu-compile-context])
(values (translate-expression tenv #f checked) type)))])) (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 "plt-match.ss")
(lib "struct.ss") (lib "struct.ss")
"../ast.ss" "../ast.ss"
"../parameters.ss"
"../readerr.ss" "../readerr.ss"
"../tenv.ss" "../tenv.ss"
"../utils.ss") "../utils.ss")
@ -33,15 +34,15 @@
;;;; and so we no longer need to cover them. ;;;; and so we no longer need to cover them.
(provide post-parse-program post-parse-interaction) (provide post-parse-program post-parse-interaction)
(define (post-parse-program tenv defns) (define (post-parse-program defns)
(convert-slots (convert-static tenv (check-this (simplify-ast defns))))) (convert-slots (convert-static (check-this (simplify-ast defns)))))
(define (post-parse-interaction tenv ast) (define (post-parse-interaction ast)
(cond (cond
[(honu:expr? ast) [(honu:expr? ast)
(convert-static-expression (check-this-expression (simplify-expression ast) #f) '())] (convert-static-expression (check-this-expression (simplify-expression ast) #f) '())]
[(honu:bind-top? ast) [(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) (define (convert-static defns)
(map (lambda (d) (convert-static-defn tenv d)) defns)) (map convert-static-defn defns))
(define (convert-static-defn tenv defn) (define (convert-static-defn defn)
(match defn (match defn
[(struct honu:iface (_ _ _ _)) [(struct honu:iface (_ _ _ _))
defn] defn]
@ -76,7 +77,7 @@
[(super-new) [(super-new)
(convert-static-super-new super-new env)] (convert-static-super-new super-new env)]
[(env) [(env)
(extend-env-with-type-members tenv env arg-type)] (extend-env-with-type-members env arg-type)]
[(members-after _) [(members-after _)
(convert-static-members members-after env)]) (convert-static-members members-after env)])
(copy-struct honu:mixin defn (copy-struct honu:mixin defn
@ -90,8 +91,8 @@
[(struct honu:bind-top (_ _ _ _)) [(struct honu:bind-top (_ _ _ _))
defn])) defn]))
(define (extend-env-with-type-members tenv env type) (define (extend-env-with-type-members env type)
(let ([type-entry (get-type-entry tenv type)]) (let ([type-entry (get-type-entry type)])
(fold (lambda (m e) (fold (lambda (m e)
(cons (tenv:member-name m) e)) (cons (tenv:member-name m) e))
env 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) (define-struct comp:exp-bind (old new method?) #f)
(provide translate-class-exports translate-subclass-exports) (provide translate-class-exports translate-subclass-exports)
(define (translate-class-exports tenv exports) (define (translate-class-exports exports)
(let ([exports (filter-exports tenv (generate-exports tenv exports))]) (let ([exports (filter-exports (generate-exports exports))])
(map (lambda (e) (map (lambda (e)
(translate-export tenv #f #f e)) (translate-export #f #f e))
exports))) exports)))
(define (translate-subclass-exports tenv super-types arg-type exports) (define (translate-subclass-exports super-types arg-type exports)
(let ([exports (filter-exports tenv (generate-exports tenv exports))]) (let ([exports (filter-exports (generate-exports exports))])
(map (lambda (e) (map (lambda (e)
(if (ormap (lambda (t) (if (ormap (lambda (t)
(<:_P tenv t (comp:export-type e))) (<:_P t (comp:export-type e)))
super-types) super-types)
(translate-export tenv #t arg-type e) (translate-export #t arg-type e)
(translate-export tenv #f arg-type e))) (translate-export #f arg-type e)))
exports))) 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)] (let loop ([super-types (tenv:type-supers type-entry)]
[super-comp-exps '()]) [super-comp-exps '()])
(if (null? super-types) (if (null? super-types)
super-comp-exps 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) (let loop2 ([super-members (append (tenv:type-members super-entry)
(tenv:type-inherited super-entry))] (tenv:type-inherited super-entry))]
[super-comp-binds '()]) [super-comp-binds '()])
(if (null? super-members) (if (null? super-members)
(loop (cdr super-types) (loop (cdr super-types)
(cons (make-comp:export #f (car super-types) super-comp-binds) (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))) super-comp-exps)))
(let ([matched (find (lambda (eb) (let ([matched (find (lambda (eb)
(tenv-key=? (tenv:member-name (car super-members)) (tenv-key=? (tenv:member-name (car super-members))
@ -53,19 +53,19 @@
(cons matched super-comp-binds))))))))) (cons matched super-comp-binds)))))))))
(define (generate-exports tenv exports) (define (generate-exports exports)
(let loop ([exports exports] (let loop ([exports exports]
[comp-exps '()]) [comp-exps '()])
(if (null? exports) (if (null? exports)
comp-exps comp-exps
(let* ([export (car exports)] (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)] (let loop2 ([exp-binds (honu:export-binds export)]
[members (append (tenv:type-members type-entry) [members (append (tenv:type-members type-entry)
(tenv:type-inherited type-entry))] (tenv:type-inherited type-entry))]
[comp-binds '()]) [comp-binds '()])
(if (null? exp-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) (loop (cdr exports)
(cons (make-comp:export (honu:ast-stx export) (cons (make-comp:export (honu:ast-stx export)
(honu:export-type export) (honu:export-type export)
@ -82,13 +82,13 @@
(honu:type-disp? (tenv:member-type matched))) (honu:type-disp? (tenv:member-type matched)))
comp-binds))))))))) comp-binds)))))))))
(define (filter-exports tenv exports) (define (filter-exports exports)
(let loop ([exports exports] (let loop ([exports exports]
[kept-exps '()]) [kept-exps '()])
(if (null? exports) (if (null? exports)
kept-exps kept-exps
(let-values ([(matches non-matches) (partition (lambda (exp) (let-values ([(matches non-matches) (partition (lambda (exp)
(type-equal? tenv (type-equal?
(comp:export-type (car exports)) (comp:export-type (car exports))
(comp:export-type exp))) (comp:export-type exp)))
exports)]) exports)])
@ -97,31 +97,31 @@
(loop non-matches (cons exp-with-stx kept-exps)) (loop non-matches (cons exp-with-stx kept-exps))
(loop non-matches (cons (car exports) 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 (cons 'begin
(map (lambda (b) (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)))) (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)]) (let ([right-defn (if in-super? 'define/override 'define/public)])
(match binding (match binding
[(struct comp:exp-bind (old-name new-name #t)) [(struct comp:exp-bind (old-name new-name #t))
(at #f `(,right-defn (,(translate-method-name type new-name) arg-tuple) (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)) [(struct comp:exp-bind (old-name new-name #f))
(at #f `(begin (at #f `(begin
(,right-defn (,(translate-field-getter-name type new-name) args) (,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) (,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) (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) (at (honu:ast-stx super-new)
(cons 'super-new (map (lambda (a) (cons 'super-new (map (lambda (a)
(list (at-ctxt (honu:name-arg-name 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))))) (honu:super-new-args super-new)))))
(define (translate-inits inits) (define (translate-inits inits)
@ -132,20 +132,20 @@
(define (mangle-init-name name) (define (mangle-init-name name)
(at name (string->symbol (string-append "init-" (symbol->string (syntax-e 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 (match member
[(struct honu:init-field (stx name _ value)) [(struct honu:init-field (stx name _ value))
(if value (if value
`(begin (init ([,(mangle-init-name name) ,(at-ctxt name)] `(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))) (define ,(at-ctxt name) ,(mangle-init-name)))
`(begin (init ([,(mangle-init-name name) ,(at-ctxt name)])) `(begin (init ([,(mangle-init-name name) ,(at-ctxt name)]))
(define ,(at-ctxt name) ,(mangle-init-name name))))] (define ,(at-ctxt name) ,(mangle-init-name name))))]
[(struct honu:field (stx name _ value)) [(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)) [(struct honu:method (stx name _ formals body))
(translate-function stx name formals (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" "../typechecker/type-utils.ss"
"translate-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))]) (syntax/c any/c))])
(define (translate-expression tenv arg-type expr) (define (translate-expression arg-type expr)
(match expr (match expr
[(struct honu:lit (stx _ value)) [(struct honu:lit (stx _ value))
(at stx value)] (at stx value)]
@ -20,54 +20,54 @@
[(struct honu:tuple (stx args)) [(struct honu:tuple (stx args))
;; list is a bindable name in Honu, so... we use list*, which isn't. ;; list is a bindable name in Honu, so... we use list*, which isn't.
(at stx `(list* ,@(map (lambda (e) (at stx `(list* ,@(map (lambda (e)
(translate-expression tenv arg-type e)) (translate-expression arg-type e))
args) args)
()))] ()))]
[(struct honu:lambda (stx _ formals body)) [(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)) [(struct honu:call (stx func arg))
(match func (match func
[(struct honu:member (stx 'my _ name #t)) [(struct honu:member (stx 'my _ name #t))
(at stx (translate-static-method tenv arg-type name (at stx (translate-static-method arg-type name
(translate-expression tenv arg-type arg)))] (translate-expression arg-type arg)))]
[(struct honu:member (stx obj elab name #t)) [(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-method-name elab name)
,(translate-expression tenv arg-type arg)))] ,(translate-expression arg-type arg)))]
[else [else
(at stx `(,(translate-expression tenv arg-type func) (at stx `(,(translate-expression arg-type func)
,(translate-expression tenv arg-type arg)))])] ,(translate-expression arg-type arg)))])]
[(struct honu:select (stx slot 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)))] (- ,slot 1)))]
[(struct honu:if (stx test then else)) [(struct honu:if (stx test then else))
(if else (if else
(at stx `(if ,(translate-expression tenv arg-type test) (at stx `(if ,(translate-expression arg-type test)
,(translate-expression tenv arg-type then) ,(translate-expression arg-type then)
,(translate-expression tenv arg-type else))) ,(translate-expression arg-type else)))
(at stx `(if ,(translate-expression tenv arg-type test) (at stx `(if ,(translate-expression arg-type test)
,(translate-expression tenv arg-type then) ,(translate-expression arg-type then)
,void-value)))] ,void-value)))]
[(struct honu:cond (stx clauses else)) [(struct honu:cond (stx clauses else))
(if else (if else
(at stx `(cond ,@(map (lambda (c) (at stx `(cond ,@(map (lambda (c)
`(,(translate-expression tenv arg-type (honu:cond-clause-pred c)) `(,(translate-expression arg-type (honu:cond-clause-pred c))
,(translate-expression tenv arg-type (honu:cond-clause-rhs c)))) ,(translate-expression arg-type (honu:cond-clause-rhs c))))
clauses) clauses)
(else ,(translate-expression tenv arg-type else)))) (else ,(translate-expression arg-type else))))
(at stx `(cond ,@(map (lambda (c) (at stx `(cond ,@(map (lambda (c)
`(,(translate-expression tenv arg-type (honu:cond-clause-pred c)) `(,(translate-expression arg-type (honu:cond-clause-pred c))
,(translate-expression tenv arg-type (honu:cond-clause-rhs c)))) ,(translate-expression arg-type (honu:cond-clause-rhs c))))
clauses) clauses)
(else ,void-value))))] (else ,void-value))))]
[(struct honu:un-op (stx op op-stx op-type arg)) [(struct honu:un-op (stx op op-stx op-type arg))
(case op (case op
[(not) [(not)
(at stx (at stx
`(,(at op-stx 'not) ,(translate-expression tenv arg-type arg)))] `(,(at op-stx 'not) ,(translate-expression arg-type arg)))]
[(minus) [(minus)
(at stx (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 [else (raise-read-error-with-stx
"Haven't translated unary operator yet." "Haven't translated unary operator yet."
op-stx)])] op-stx)])]
@ -78,222 +78,222 @@
(eqv? (honu:type-prim-name op-type) 'string)) (eqv? (honu:type-prim-name op-type) 'string))
(at stx (at stx
`(,(at op-stx 'string=?) `(,(at op-stx 'string=?)
,(translate-expression tenv arg-type larg) ,(translate-expression arg-type larg)
,(translate-expression tenv arg-type rarg))) ,(translate-expression arg-type rarg)))
(at stx (at stx
`(,(at op-stx 'eqv?) `(,(at op-stx 'eqv?)
,(translate-expression tenv arg-type larg) ,(translate-expression arg-type larg)
,(translate-expression tenv arg-type rarg))))] ,(translate-expression arg-type rarg))))]
[(neq) [(neq)
(if (and (honu:type-prim? op-type) (if (and (honu:type-prim? op-type)
(eqv? (honu:type-prim-name op-type) 'string)) (eqv? (honu:type-prim-name op-type) 'string))
(at stx (at stx
`(,(at op-stx 'not) `(,(at op-stx 'not)
(,(at op-stx 'string=?) (,(at op-stx 'string=?)
,(translate-expression tenv arg-type larg) ,(translate-expression arg-type larg)
,(translate-expression tenv arg-type rarg)))) ,(translate-expression arg-type rarg))))
(at stx (at stx
`(,(at op-stx 'not) `(,(at op-stx 'not)
(,(at op-stx 'eqv?) (,(at op-stx 'eqv?)
,(translate-expression tenv arg-type larg) ,(translate-expression arg-type larg)
,(translate-expression tenv arg-type rarg)))))] ,(translate-expression arg-type rarg)))))]
[(clseq) [(clseq)
(at stx (at stx
`(,(at op-stx 'equal?) `(,(at op-stx 'equal?)
,(translate-expression tenv arg-type larg) ,(translate-expression arg-type larg)
,(translate-expression tenv arg-type rarg)))] ,(translate-expression arg-type rarg)))]
[(and) [(and)
(at stx (at stx
`(,(at op-stx 'and) `(,(at op-stx 'and)
,(translate-expression tenv arg-type larg) ,(translate-expression arg-type larg)
,(translate-expression tenv arg-type rarg)))] ,(translate-expression arg-type rarg)))]
[(or) [(or)
(at stx (at stx
`(,(at op-stx 'or) `(,(at op-stx 'or)
,(translate-expression tenv arg-type larg) ,(translate-expression arg-type larg)
,(translate-expression tenv arg-type rarg)))] ,(translate-expression arg-type rarg)))]
[(lt) [(lt)
(case (honu:type-prim-name op-type) (case (honu:type-prim-name op-type)
[(int float) [(int float)
(at stx (at stx
`(,(at op-stx '<) `(,(at op-stx '<)
,(translate-expression tenv arg-type larg) ,(translate-expression arg-type larg)
,(translate-expression tenv arg-type rarg)))] ,(translate-expression arg-type rarg)))]
[(string) [(string)
(at stx (at stx
`(,(at op-stx 'string<?) `(,(at op-stx 'string<?)
,(translate-expression tenv arg-type larg) ,(translate-expression arg-type larg)
,(translate-expression tenv arg-type rarg)))] ,(translate-expression arg-type rarg)))]
[(char) [(char)
(at stx (at stx
`(,(at op-stx 'char<?) `(,(at op-stx 'char<?)
,(translate-expression tenv arg-type larg) ,(translate-expression arg-type larg)
,(translate-expression tenv arg-type rarg)))])] ,(translate-expression arg-type rarg)))])]
[(le) [(le)
(case (honu:type-prim-name op-type) (case (honu:type-prim-name op-type)
[(int float) [(int float)
(at stx (at stx
`(,(at op-stx '<=) `(,(at op-stx '<=)
,(translate-expression tenv arg-type larg) ,(translate-expression arg-type larg)
,(translate-expression tenv arg-type rarg)))] ,(translate-expression arg-type rarg)))]
[(string) [(string)
(at stx (at stx
`(,(at op-stx 'string<=?) `(,(at op-stx 'string<=?)
,(translate-expression tenv arg-type larg) ,(translate-expression arg-type larg)
,(translate-expression tenv arg-type rarg)))] ,(translate-expression arg-type rarg)))]
[(char) [(char)
(at stx (at stx
`(,(at op-stx 'char<=?) `(,(at op-stx 'char<=?)
,(translate-expression tenv arg-type larg) ,(translate-expression arg-type larg)
,(translate-expression tenv arg-type rarg)))])] ,(translate-expression arg-type rarg)))])]
[(gt) [(gt)
(case (honu:type-prim-name op-type) (case (honu:type-prim-name op-type)
[(int float) [(int float)
(at stx (at stx
`(,(at op-stx '>) `(,(at op-stx '>)
,(translate-expression tenv arg-type larg) ,(translate-expression arg-type larg)
,(translate-expression tenv arg-type rarg)))] ,(translate-expression arg-type rarg)))]
[(string) [(string)
(at stx (at stx
`(,(at op-stx 'string>?) `(,(at op-stx 'string>?)
,(translate-expression tenv arg-type larg) ,(translate-expression arg-type larg)
,(translate-expression tenv arg-type rarg)))] ,(translate-expression arg-type rarg)))]
[(char) [(char)
(at stx (at stx
`(,(at op-stx 'char>?) `(,(at op-stx 'char>?)
,(translate-expression tenv arg-type larg) ,(translate-expression arg-type larg)
,(translate-expression tenv arg-type rarg)))])] ,(translate-expression arg-type rarg)))])]
[(ge) [(ge)
(case (honu:type-prim-name op-type) (case (honu:type-prim-name op-type)
[(int float) [(int float)
(at stx (at stx
`(,(at op-stx '>=) `(,(at op-stx '>=)
,(translate-expression tenv arg-type larg) ,(translate-expression arg-type larg)
,(translate-expression tenv arg-type rarg)))] ,(translate-expression arg-type rarg)))]
[(string) [(string)
(at stx (at stx
`(,(at op-stx 'string>=?) `(,(at op-stx 'string>=?)
,(translate-expression tenv arg-type larg) ,(translate-expression arg-type larg)
,(translate-expression tenv arg-type rarg)))] ,(translate-expression arg-type rarg)))]
[(char) [(char)
(at stx (at stx
`(,(at op-stx 'char>=?) `(,(at op-stx 'char>=?)
,(translate-expression tenv arg-type larg) ,(translate-expression arg-type larg)
,(translate-expression tenv arg-type rarg)))])] ,(translate-expression arg-type rarg)))])]
[(plus) [(plus)
(case (honu:type-prim-name op-type) (case (honu:type-prim-name op-type)
[(int float) [(int float)
(at stx (at stx
`(,(at op-stx '+) `(,(at op-stx '+)
,(translate-expression tenv arg-type larg) ,(translate-expression arg-type larg)
,(translate-expression tenv arg-type rarg)))] ,(translate-expression arg-type rarg)))]
[(string) [(string)
(at stx (at stx
`(,(at op-stx 'string-append) `(,(at op-stx 'string-append)
,(translate-expression tenv arg-type larg) ,(translate-expression arg-type larg)
,(translate-expression tenv arg-type rarg)))])] ,(translate-expression arg-type rarg)))])]
[(minus) [(minus)
(at stx (at stx
`(,(at op-stx '-) `(,(at op-stx '-)
,(translate-expression tenv arg-type larg) ,(translate-expression arg-type larg)
,(translate-expression tenv arg-type rarg)))] ,(translate-expression arg-type rarg)))]
[(times) [(times)
(at stx (at stx
`(,(at op-stx '*) `(,(at op-stx '*)
,(translate-expression tenv arg-type larg) ,(translate-expression arg-type larg)
,(translate-expression tenv arg-type rarg)))] ,(translate-expression arg-type rarg)))]
[(div) [(div)
(case (honu:type-prim-name op-type) (case (honu:type-prim-name op-type)
[(int) [(int)
(at stx (at stx
`(,(at op-stx 'quotient) `(,(at op-stx 'quotient)
,(translate-expression tenv arg-type larg) ,(translate-expression arg-type larg)
,(translate-expression tenv arg-type rarg)))] ,(translate-expression arg-type rarg)))]
[(float) [(float)
(at stx (at stx
`(,(at op-stx '/) `(,(at op-stx '/)
,(translate-expression tenv arg-type larg) ,(translate-expression arg-type larg)
,(translate-expression tenv arg-type rarg)))])] ,(translate-expression arg-type rarg)))])]
[(mod) [(mod)
(at stx (at stx
`(,(at op-stx 'remainder) `(,(at op-stx 'remainder)
,(translate-expression tenv arg-type larg) ,(translate-expression arg-type larg)
,(translate-expression tenv arg-type rarg)))] ,(translate-expression arg-type rarg)))]
[else (raise-read-error-with-stx [else (raise-read-error-with-stx
"Haven't translated binary operator yet." "Haven't translated binary operator yet."
op-stx)])] op-stx)])]
[(struct honu:return (stx body)) [(struct honu:return (stx body))
(at stx (at stx
`(last-k ,(translate-expression tenv arg-type body)))] `(last-k ,(translate-expression arg-type body)))]
[(struct honu:let (stx bindings body)) [(struct honu:let (stx bindings body))
(at stx (at stx
`(let*-values ,(map (lambda (b) `(let*-values ,(map (lambda (b)
(let-values ([(bound-names body) (let-values ([(bound-names body)
(translate-binding-clause (honu:binding-names b) (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, ;; make sure to give the let binding the appropriate syntax,
;; otherwise errors will highlight the entire let expression. ;; otherwise errors will highlight the entire let expression.
(at (honu:ast-stx b) `(,bound-names ,body)))) (at (honu:ast-stx b) `(,bound-names ,body))))
bindings) bindings)
,(translate-expression tenv arg-type body)))] ,(translate-expression arg-type body)))]
[(struct honu:seq (stx effects value)) [(struct honu:seq (stx effects value))
(at stx (at stx
`(begin ,@(map (lambda (e) `(begin ,@(map (lambda (e)
(translate-expression tenv arg-type e)) (translate-expression arg-type e))
effects) effects)
,(translate-expression tenv arg-type value)))] ,(translate-expression arg-type value)))]
[(struct honu:while (stx test body)) [(struct honu:while (stx test body))
(at stx (at stx
`(let loop () `(let loop ()
(if ,(translate-expression tenv arg-type test) (if ,(translate-expression arg-type test)
(begin ,(translate-expression tenv arg-type body) (loop)) (begin ,(translate-expression arg-type body) (loop))
,void-value)))] ,void-value)))]
[(struct honu:assn (stx lhs rhs)) [(struct honu:assn (stx lhs rhs))
(match lhs (match lhs
[(struct honu:var (_ _)) [(struct honu:var (_ _))
(at stx `(begin (set! ,(translate-expression tenv arg-type lhs) (at stx `(begin (set! ,(translate-expression arg-type lhs)
,(translate-expression tenv arg-type rhs)) ,(translate-expression arg-type rhs))
,void-value))] ,void-value))]
[(struct honu:member (mstx 'my _ name method?)) [(struct honu:member (mstx 'my _ name method?))
(if method? (if method?
(raise-read-error-with-stx (raise-read-error-with-stx
"Left-hand side of assignment cannot be a method name" "Left-hand side of assignment cannot be a method name"
mstx) mstx)
(at stx (translate-static-field-setter tenv arg-type name (at stx (translate-static-field-setter arg-type name
(translate-expression tenv arg-type rhs))))] (translate-expression arg-type rhs))))]
[(struct honu:member (mstx obj elab name method?)) [(struct honu:member (mstx obj elab name method?))
(if method? (if method?
(raise-read-error-with-stx (raise-read-error-with-stx
"Left-hand side of assignment cannot be a method name" "Left-hand side of assignment cannot be a method name"
mstx) 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-field-setter-name elab name)
,(translate-expression tenv arg-type rhs))))] ,(translate-expression arg-type rhs))))]
[else [else
(raise-read-error-with-stx (raise-read-error-with-stx
"Left-hand side of assignment is invalid" "Left-hand side of assignment is invalid"
stx)])] stx)])]
[(struct honu:member (stx 'my _ name method?)) [(struct honu:member (stx 'my _ name method?))
(if method? (if method?
(at stx (translate-static-method tenv arg-type name)) (at stx (translate-static-method arg-type name))
(at stx (translate-static-field-getter tenv arg-type name)))] (at stx (translate-static-field-getter arg-type name)))]
[(struct honu:member (stx obj elab name method?)) [(struct honu:member (stx obj elab name method?))
(if method? (if method?
(at stx `(lambda (args) (at stx `(lambda (args)
(honu:send ,(translate-expression tenv arg-type obj) (honu:send ,(translate-expression arg-type obj)
,(translate-method-name elab name) ,(translate-method-name elab name)
args))) 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) ,(translate-field-getter-name elab name)
,void-value)))] ,void-value)))]
[(struct honu:new (stx class _ args)) [(struct honu:new (stx class _ args))
(at stx `(new ,(translate-class-name class) (at stx `(new ,(translate-class-name class)
,@(map (lambda (a) ,@(map (lambda (a)
`(,(honu:name-arg-name 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)))] args)))]
[(struct honu:cast (stx obj type)) [(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 ;; you can always cast null to an interface type
(if (or (is-a? cast-obj null%) (if (or (is-a? cast-obj null%)
(is-a? cast-obj ,(translate-iface-name type))) (is-a? cast-obj ,(translate-iface-name type)))
@ -307,7 +307,7 @@
(string->symbol (substring class-string 0 (- (string-length class-string) 1)))) (string->symbol (substring class-string 0 (- (string-length class-string) 1))))
(quote ,(printable-type type))))))))] (quote ,(printable-type type))))))))]
[(struct honu:isa (stx obj 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 ;; null is a member of any interface type
(or (is-a? cast-obj null%) (or (is-a? cast-obj null%)
(is-a? cast-obj ,(translate-iface-name type)))))] (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) (require (all-except (lib "list.ss" "srfi" "1") any)
(lib "contract.ss") (lib "contract.ss")
"../../ast.ss" "../../ast.ss"
"../../parameters.ss"
"../../tenv.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"))) (define stx-for-original-property (read-syntax #f (open-input-string "original")))
(provide/contract [at ((union (syntax/c any/c) false/c) (provide/contract [at ((union (syntax/c any/c) false/c)
@ -93,9 +91,9 @@
"-set!")))) "-set!"))))
(provide translate-static-method translate-static-field-getter translate-static-field-setter) (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 (if arg-type
(let ([type-entry (get-type-entry tenv arg-type)]) (let ([type-entry (get-type-entry arg-type)])
(if (s:member name (if (s:member name
(map tenv:member-name (append (tenv:type-members type-entry) (map tenv:member-name (append (tenv:type-members type-entry)
(tenv:type-inherited type-entry))) (tenv:type-inherited type-entry)))
@ -111,9 +109,9 @@
`(,(at-ctxt name) ,arg) `(,(at-ctxt name) ,arg)
(at-ctxt name)))) (at-ctxt name))))
(define (translate-static-field-getter tenv arg-type name) (define (translate-static-field-getter arg-type name)
(if arg-type (if arg-type
(let ([type-entry (get-type-entry tenv arg-type)]) (let ([type-entry (get-type-entry arg-type)])
(if (s:member name (if (s:member name
(map tenv:member-name (append (tenv:type-members type-entry) (map tenv:member-name (append (tenv:type-members type-entry)
(tenv:type-inherited type-entry))) (tenv:type-inherited type-entry)))
@ -122,9 +120,9 @@
(at-ctxt name))) (at-ctxt name)))
(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 (if arg-type
(let ([type-entry (get-type-entry tenv arg-type)]) (let ([type-entry (get-type-entry arg-type)])
(if (s:member name (if (s:member name
(map tenv:member-name (append (tenv:type-members type-entry) (map tenv:member-name (append (tenv:type-members type-entry)
(tenv:type-inherited type-entry))) (tenv:type-inherited type-entry)))

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

@ -11,13 +11,13 @@
"translate-expression.ss" "translate-expression.ss"
"translate-utils.ss") "translate-utils.ss")
(provide/contract [translate (tenv? (listof honu:defn?) (provide/contract [translate ((listof honu:defn?)
. -> . . -> .
(listof (syntax/c any/c)))] (listof (syntax/c any/c)))]
[translate-defn (tenv? honu:defn? [translate-defn (honu:defn?
. -> . . -> .
(syntax/c any/c))]) (syntax/c any/c))])
(define (translate tenv defns) (define (translate defns)
(let loop ([defns-to-go defns] (let loop ([defns-to-go defns]
[syntaxes '()]) [syntaxes '()])
(cond (cond
@ -30,13 +30,13 @@
(tenv-key=? (honu:mixin-name d) (tenv-key=? (honu:mixin-name d)
(honu:subclass-mixin (car defns-to-go))))) (honu:subclass-mixin (car defns-to-go)))))
defns)]) 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 [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)] (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))] (let loop ([members (append (tenv:type-members type-entry) (tenv:type-inherited type-entry))]
[names '()]) [names '()])
(if (null? members) (if (null? members)
@ -50,38 +50,38 @@
(cons (translate-field-getter-name iface (tenv:member-name (car members))) (cons (translate-field-getter-name iface (tenv:member-name (car members)))
names)))))))) names))))))))
(define (translate-defn tenv defn) (define (translate-defn defn)
(match defn (match defn
[(struct honu:bind-top (stx names _ value)) [(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)))] (at stx `(define-values ,bound-names ,body)))]
[(struct honu:function (stx name _ args 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)) [(struct honu:iface (stx name supers members))
(at stx `(define ,(translate-iface-name (make-iface-type name name)) (at stx `(define ,(translate-iface-name (make-iface-type name name))
(interface ,(if (null? supers) (interface ,(if (null? supers)
(list (translate-iface-name (make-any-type #f))) (list (translate-iface-name (make-any-type #f)))
(map translate-iface-name supers)) (map translate-iface-name supers))
,@(translate-member-names tenv name))))] ,@(translate-member-names name))))]
[(struct honu:class (stx name _ _ impls inits members exports)) [(struct honu:class (stx name _ _ impls inits members exports))
(at stx `(define ,(translate-class-name name) (at stx `(define ,(translate-class-name name)
(class* object% ,(map translate-iface-name impls) (class* object% ,(map translate-iface-name impls)
(inspect #f) (inspect #f)
,(translate-inits inits) ,(translate-inits inits)
,@(map (lambda (m) ,@(map (lambda (m)
(translate-member tenv #f m)) members) (translate-member #f m)) members)
,@(translate-class-exports tenv exports) ,@(translate-class-exports exports)
,(translate-formatter tenv name members #f) ,(translate-formatter name members #f)
(super-new))))] (super-new))))]
[else (raise-read-error-with-stx [else (raise-read-error-with-stx
"Haven't translated that type of definition yet." "Haven't translated that type of definition yet."
(honu:ast-stx defn))])) (honu:ast-stx defn))]))
(define (translate-subclass tenv mixin-defn defn) (define (translate-subclass mixin-defn defn)
(match (list 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)) [(list (struct honu:mixin (mstx mname _ arg-type _ impls inits _ super-new members-before members-after exports))
(struct honu:subclass (stx name base mixin))) (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) [base-types (cons (tenv:class-sub-type base-entry)
(tenv:class-impls base-entry))]) (tenv:class-impls base-entry))])
(at stx `(define ,(translate-class-name name) (at stx `(define ,(translate-class-name name)
@ -89,14 +89,14 @@
(inspect #f) (inspect #f)
,(translate-inits inits) ,(translate-inits inits)
,@(map (lambda (m) ,@(map (lambda (m)
(translate-member tenv arg-type m)) members-before) (translate-member arg-type m)) members-before)
,(translate-super-new tenv arg-type super-new) ,(translate-super-new arg-type super-new)
,@(map (lambda (m) ,@(map (lambda (m)
(translate-member tenv arg-type m)) members-after) (translate-member arg-type m)) members-after)
,@(translate-subclass-exports tenv base-types arg-type exports) ,@(translate-subclass-exports base-types arg-type exports)
,(translate-formatter tenv name (append members-before members-after) arg-type)))))])) ,(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)]) (let ([right-define (if arg-type 'define/override 'define/public)])
`(,right-define (format-class renderer indent print-fields?) `(,right-define (format-class renderer indent print-fields?)
(if print-fields? (if print-fields?
@ -111,7 +111,7 @@
(if (not (honu:type-disp? (tenv:member-type m))) (if (not (honu:type-disp? (tenv:member-type m)))
(tenv:member-name m) (tenv:member-name m)
#f)) #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. ;; how much more do we want the members indented? Let's try 2 spaces more.
[indent-delta 2]) [indent-delta 2])
@ -119,7 +119,7 @@
(null? printable-smembers)) (null? printable-smembers))
'("") '("")
(fold-right (lambda (m l) (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) (fold-right (lambda (m l)
(list* "\n" (translate-member-formatter m indent-delta) l)) (list* "\n" (translate-member-formatter m indent-delta) l))
'("\n" (make-string indent #\space)) '("\n" (make-string indent #\space))
@ -137,11 +137,11 @@
;; the 3 is for " = " ;; the 3 is for " = "
(renderer ,name (+ indent ,(+ indent-delta (string-length (symbol->string (syntax-e name))) 3)))))) (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;" `(format "~a~a = ~a;"
(make-string (+ indent ,indent-delta) #\space) (make-string (+ indent ,indent-delta) #\space)
(quote ,(syntax-e name)) (quote ,(syntax-e name))
;; as before, the 3 is for " = " ;; 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))))) (+ 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"])) "null"]))
(provide type-valid?) (provide type-valid?)
(define (type-valid? tenv t) (define (type-valid? t)
(match t (match t
[(struct honu:type-iface-top (_)) #t] [(struct honu:type-iface-top (_)) #t]
[(struct honu:type-prim (stx name)) [(struct honu:type-prim (stx name))
@ -92,22 +92,22 @@
(format "Unexpected primitive type ~a" name) (format "Unexpected primitive type ~a" name)
stx)])] stx)])]
[(struct honu:type-iface (stx name)) [(struct honu:type-iface (stx name))
(let ([tentry (get-tenv-entry tenv name)]) (let ([tentry (get-tenv-entry name)])
(and tentry (tenv:type? tentry)))] (and tentry (tenv:type? tentry)))]
[(struct honu:type-tuple (_ args)) [(struct honu:type-tuple (_ args))
(andmap (lambda (t) (andmap (lambda (t)
(type-valid? tenv t)) (type-valid? t))
args)] args)]
[(struct honu:type-func (_ arg ret)) [(struct honu:type-func (_ arg ret))
(and (type-valid? tenv arg) (and (type-valid? arg)
(type-valid? tenv ret))] (type-valid? ret))]
[(struct honu:type-disp (_ disp arg ret)) [(struct honu:type-disp (_ disp arg ret))
(and (type-valid? tenv disp) (and (type-valid? disp)
(type-valid? tenv arg) (type-valid? arg)
(type-valid? tenv ret))])) (type-valid? ret))]))
(provide type-equal?) (provide type-equal?)
(define (type-equal? tenv t1 t2) (define (type-equal? t1 t2)
(cond (cond
;; first all the easy ones ;; first all the easy ones
[(and (honu:type-top? t1) [(and (honu:type-top? t1)
@ -135,13 +135,13 @@
;; function, dispatch types are equal if their component types are. ;; function, dispatch types are equal if their component types are.
[(and (honu:type-func? t1) [(and (honu:type-func? t1)
(honu:type-func? t2)) (honu:type-func? t2))
(and (type-equal? tenv (honu:type-func-arg t1) (honu:type-func-arg t2)) (and (type-equal? (honu:type-func-arg t1) (honu:type-func-arg t2))
(type-equal? tenv (honu:type-func-ret t1) (honu:type-func-ret t2)))] (type-equal? (honu:type-func-ret t1) (honu:type-func-ret t2)))]
[(and (honu:type-disp? t1) [(and (honu:type-disp? t1)
(honu:type-disp? t2)) (honu:type-disp? t2))
(and (type-equal? tenv (honu:type-disp-disp t1) (honu:type-disp-disp t2)) (and (type-equal? (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? (honu:type-disp-arg t1) (honu:type-disp-arg t2))
(type-equal? tenv (honu:type-disp-ret t1) (honu:type-disp-ret 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 ;; tuple types are equal if they have the same number of components and
;; their components are pairwise equal ;; their components are pairwise equal
[(and (honu:type-tuple? t1) [(and (honu:type-tuple? t1)
@ -150,7 +150,7 @@
[t2-args (honu:type-tuple-args t2)]) [t2-args (honu:type-tuple-args t2)])
(and (= (length t1-args) (length t2-args)) (and (= (length t1-args) (length t2-args))
(andmap (lambda (t1 t2) (andmap (lambda (t1 t2)
(type-equal? tenv t1 t2)) (type-equal? t1 t2))
t1-args t2-args)))] t1-args t2-args)))]
;; for select types, they must be the same type on the same slot ;; for select types, they must be the same type on the same slot
;; (should we even get here?) ;; (should we even get here?)
@ -169,8 +169,8 @@
#'Any])) #'Any]))
;; is t1 a _direct_ subtype of t2? ;; is t1 a _direct_ subtype of t2?
(define (Subtype_P tenv t1 t2) (define (Subtype_P t1 t2)
(let ([type-entry (get-type-entry tenv t1)]) (let ([type-entry (get-type-entry t1)])
(match type-entry (match type-entry
[(struct tenv:type (_ supers _ _)) [(struct tenv:type (_ supers _ _))
(let ([super-names (map get-type-name supers)]) (let ([super-names (map get-type-name supers)])
@ -178,10 +178,10 @@
;; is t1 a (ref-trans-closed) subtype of t2? ;; is t1 a (ref-trans-closed) subtype of t2?
(provide <:_P) (provide <:_P)
(define (<:_P tenv t1 t2) (define (<:_P t1 t2)
(cond (cond
;; if t1 = t2, t1 <:_P t2 ;; if t1 = t2, t1 <:_P t2
[(type-equal? tenv t1 t2) [(type-equal? t1 t2)
#t] #t]
;; if t1 is the bottom of the type lattice, then it trivially holds ;; if t1 is the bottom of the type lattice, then it trivially holds
[(honu:type-bot? t1) [(honu:type-bot? t1)
@ -197,15 +197,15 @@
[(and (honu:type-func? t1) [(and (honu:type-func? t1)
(honu:type-func? t2)) (honu:type-func? t2))
;; the arg is contravariant and the ret is covariant ;; the arg is contravariant and the ret is covariant
(and (<:_P tenv (honu:type-func-arg t2) (honu:type-func-arg t1)) (and (<:_P (honu:type-func-arg t2) (honu:type-func-arg t1))
(<:_P tenv (honu:type-func-ret t1) (honu:type-func-ret t2)))] (<:_P (honu:type-func-ret t1) (honu:type-func-ret t2)))]
;; for dispatch types... ;; for dispatch types...
[(and (honu:type-disp? t1) [(and (honu:type-disp? t1)
(honu:type-disp? t2)) (honu:type-disp? t2))
;; dispatch args must be co-, regular args contra-, and ret co- ;; dispatch args must be co-, regular args contra-, and ret co-
(and (<:_P tenv (honu:type-disp-disp t1) (honu:type-disp-disp t2)) (and (<:_P (honu:type-disp-disp t1) (honu:type-disp-disp t2))
(<:_P tenv (honu:type-disp-arg t2) (honu:type-disp-arg t1)) (<:_P (honu:type-disp-arg t2) (honu:type-disp-arg t1))
(<:_P tenv (honu:type-disp-ret t1) (honu:type-disp-ret t2)))] (<:_P (honu:type-disp-ret t1) (honu:type-disp-ret t2)))]
;; for tuple types... ;; for tuple types...
[(and (honu:type-tuple? t1) [(and (honu:type-tuple? t1)
(honu:type-tuple? t2)) (honu:type-tuple? t2))
@ -215,7 +215,7 @@
(and (= (length t1-args) (length t2-args)) (and (= (length t1-args) (length t2-args))
;; and each component must be a subtype (covariantly) ;; and each component must be a subtype (covariantly)
(andmap (lambda (t1 t2) (andmap (lambda (t1 t2)
(<:_P tenv t1 t2)) (<:_P t1 t2))
t1-args t2-args)))] t1-args t2-args)))]
;; for a select statement (s, t), we have that a tuple type (t_1 ... t_n) is <:_P t if ;; 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. ;; if t_s <:_P t.
@ -225,12 +225,12 @@
[t1-args (honu:type-tuple-args t1)]) [t1-args (honu:type-tuple-args t1)])
(and (<= t2-slot (length t1-args)) (and (<= t2-slot (length t1-args))
;; we have to subtract one from t2-slot because list-ref is zero-based ;; 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. ;; not sure if this is necessary. Hmm.
[(and (honu:type-select? t1) [(and (honu:type-select? t1)
(honu:type-select? t2)) (honu:type-select? t2))
(and (= (honu:type-select-slot t1) (honu:type-select-slot 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 ;; the bottom of the iface lattice is <:_P either the iface-top or
;; any iface ;; any iface
[(and (honu:type-iface-bot? t1) [(and (honu:type-iface-bot? t1)
@ -244,14 +244,14 @@
;; if two (non-equal) iface types... ;; if two (non-equal) iface types...
[(and (honu:type-iface? t1) [(and (honu:type-iface? t1)
(honu:type-iface? t2)) (honu:type-iface? t2))
(if (Subtype_P tenv t1 t2) (if (Subtype_P t1 t2)
;; return true if it's a direct subtype relation ;; return true if it's a direct subtype relation
#t #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, ;; if any of the direct supertypes of t1 is a subtype of t2,
;; then t1 is also ;; then t1 is also
(ormap (lambda (t) (ormap (lambda (t)
(<:_P tenv t t2)) (<:_P t t2))
(tenv:type-supers type-entry))))] (tenv:type-supers type-entry))))]
[else #f])) [else #f]))

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

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

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

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

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

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

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

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

81
collects/honu/tenv.ss
View File

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