diff --git a/collects/honu/compile.ss b/collects/honu/compile.ss index ae0b074041..4181c06e31 100644 --- a/collects/honu/compile.ss +++ b/collects/honu/compile.ss @@ -5,13 +5,13 @@ (lib "plt-match.ss") "ast.ss" "honu-context.ss" + "parameters.ss" "readerr.ss" "tenv.ss" "tenv-utils.ss" "parsers/post-parsing.ss" "private/compiler/translate.ss" "private/compiler/translate-expression.ss" - "private/compiler/translate-utils.ss" "private/typechecker/type-utils.ss" "private/typechecker/typechecker.ss" "private/typechecker/typecheck-expression.ss") @@ -28,30 +28,33 @@ ((syntax/c any/c) (union honu:type? false/c)))]) (define (compile/defns tenv lenv pgm) - (let ([pgm (post-parse-program tenv (add-defns-to-tenv pgm tenv))]) - (let ([checked (typecheck tenv lenv pgm)]) - (parameterize ([current-compile-context honu-compile-context]) - (translate tenv checked))))) + (parameterize ([current-type-environment tenv] + [current-lexical-environment lenv]) + (let ([pgm (post-parse-program (add-defns-to-tenv pgm))]) + (let ([checked (typecheck pgm)]) + (parameterize ([current-compile-context honu-compile-context]) + (translate checked)))))) - (define (check-bound-names lenv names) + (define (check-bound-names names) (for-each (lambda (n) - (if (and n (bound-identifier-mapping-get lenv n (lambda () #f))) + (if (and n (get-lenv-entry n)) (raise-read-error-with-stx (format "~a already bound" (printable-key n)) n))) names)) (define (compile/interaction tenv lenv ast) - (match (post-parse-interaction tenv ast) - [(struct honu:bind-top (stx names _ value)) - (check-bound-names lenv names) - (let ([checked (typecheck-defn tenv lenv ast)]) - (parameterize ([current-compile-context honu-compile-context]) - (values (translate-defn tenv checked) #f)))] - [else - (let-values ([(checked type) (typecheck-expression tenv (lambda (n) #f) - (wrap-as-function lenv) (make-top-type #f) #f ast)]) - (parameterize ([current-compile-context honu-compile-context]) - (values (translate-expression tenv #f checked) type)))])) + (parameterize ([current-type-environment tenv] + [current-lexical-environment lenv]) + (match (post-parse-interaction ast) + [(struct honu:bind-top (stx names _ value)) + (check-bound-names names) + (let ([checked (typecheck-defn ast)]) + (parameterize ([current-compile-context honu-compile-context]) + (values (translate-defn checked) #f)))] + [else + (let-values ([(checked type) (typecheck-expression (wrap-lenv) (make-top-type #f) ast)]) + (parameterize ([current-compile-context honu-compile-context]) + (values (translate-expression #f checked) type)))]))) ) diff --git a/collects/honu/parameters.ss b/collects/honu/parameters.ss new file mode 100644 index 0000000000..3c655c8295 --- /dev/null +++ b/collects/honu/parameters.ss @@ -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)) + + ) \ No newline at end of file diff --git a/collects/honu/parsers/post-parsing.ss b/collects/honu/parsers/post-parsing.ss index a37c866b6e..ec6aae5626 100644 --- a/collects/honu/parsers/post-parsing.ss +++ b/collects/honu/parsers/post-parsing.ss @@ -4,6 +4,7 @@ (lib "plt-match.ss") (lib "struct.ss") "../ast.ss" + "../parameters.ss" "../readerr.ss" "../tenv.ss" "../utils.ss") @@ -33,15 +34,15 @@ ;;;; and so we no longer need to cover them. (provide post-parse-program post-parse-interaction) - (define (post-parse-program tenv defns) - (convert-slots (convert-static tenv (check-this (simplify-ast defns))))) + (define (post-parse-program defns) + (convert-slots (convert-static (check-this (simplify-ast defns))))) - (define (post-parse-interaction tenv ast) + (define (post-parse-interaction ast) (cond [(honu:expr? ast) (convert-static-expression (check-this-expression (simplify-expression ast) #f) '())] [(honu:bind-top? ast) - (convert-static-defn tenv (check-this-defn (simplify-defn ast)))])) + (convert-static-defn (check-this-defn (simplify-defn ast)))])) ; ; @@ -58,10 +59,10 @@ ; ; - (define (convert-static tenv defns) - (map (lambda (d) (convert-static-defn tenv d)) defns)) + (define (convert-static defns) + (map convert-static-defn defns)) - (define (convert-static-defn tenv defn) + (define (convert-static-defn defn) (match defn [(struct honu:iface (_ _ _ _)) defn] @@ -76,7 +77,7 @@ [(super-new) (convert-static-super-new super-new env)] [(env) - (extend-env-with-type-members tenv env arg-type)] + (extend-env-with-type-members env arg-type)] [(members-after _) (convert-static-members members-after env)]) (copy-struct honu:mixin defn @@ -90,8 +91,8 @@ [(struct honu:bind-top (_ _ _ _)) defn])) - (define (extend-env-with-type-members tenv env type) - (let ([type-entry (get-type-entry tenv type)]) + (define (extend-env-with-type-members env type) + (let ([type-entry (get-type-entry type)]) (fold (lambda (m e) (cons (tenv:member-name m) e)) env diff --git a/collects/honu/private/compiler/translate-class-utils.ss b/collects/honu/private/compiler/translate-class-utils.ss index b4593a6a03..664f424589 100644 --- a/collects/honu/private/compiler/translate-class-utils.ss +++ b/collects/honu/private/compiler/translate-class-utils.ss @@ -13,37 +13,37 @@ (define-struct comp:exp-bind (old new method?) #f) (provide translate-class-exports translate-subclass-exports) - (define (translate-class-exports tenv exports) - (let ([exports (filter-exports tenv (generate-exports tenv exports))]) + (define (translate-class-exports exports) + (let ([exports (filter-exports (generate-exports exports))]) (map (lambda (e) - (translate-export tenv #f #f e)) + (translate-export #f #f e)) exports))) - (define (translate-subclass-exports tenv super-types arg-type exports) - (let ([exports (filter-exports tenv (generate-exports tenv exports))]) + (define (translate-subclass-exports super-types arg-type exports) + (let ([exports (filter-exports (generate-exports exports))]) (map (lambda (e) (if (ormap (lambda (t) - (<:_P tenv t (comp:export-type e))) + (<:_P t (comp:export-type e))) super-types) - (translate-export tenv #t arg-type e) - (translate-export tenv #f arg-type e))) + (translate-export #t arg-type e) + (translate-export #f arg-type e))) exports))) - (define (generate-super-exports tenv type-entry comp-binds) + (define (generate-super-exports type-entry comp-binds) (let loop ([super-types (tenv:type-supers type-entry)] [super-comp-exps '()]) (if (null? super-types) super-comp-exps - (let ([super-entry (get-type-entry tenv (car super-types))]) + (let ([super-entry (get-type-entry (car super-types))]) (let loop2 ([super-members (append (tenv:type-members super-entry) (tenv:type-inherited super-entry))] [super-comp-binds '()]) (if (null? super-members) (loop (cdr super-types) (cons (make-comp:export #f (car super-types) super-comp-binds) - (append (generate-super-exports tenv super-entry comp-binds) + (append (generate-super-exports super-entry comp-binds) super-comp-exps))) (let ([matched (find (lambda (eb) (tenv-key=? (tenv:member-name (car super-members)) @@ -53,19 +53,19 @@ (cons matched super-comp-binds))))))))) - (define (generate-exports tenv exports) + (define (generate-exports exports) (let loop ([exports exports] [comp-exps '()]) (if (null? exports) comp-exps (let* ([export (car exports)] - [type-entry (get-type-entry tenv (honu:export-type export))]) + [type-entry (get-type-entry (honu:export-type export))]) (let loop2 ([exp-binds (honu:export-binds export)] [members (append (tenv:type-members type-entry) (tenv:type-inherited type-entry))] [comp-binds '()]) (if (null? exp-binds) - (let ([super-exports (generate-super-exports tenv type-entry comp-binds)]) + (let ([super-exports (generate-super-exports type-entry comp-binds)]) (loop (cdr exports) (cons (make-comp:export (honu:ast-stx export) (honu:export-type export) @@ -82,13 +82,13 @@ (honu:type-disp? (tenv:member-type matched))) comp-binds))))))))) - (define (filter-exports tenv exports) + (define (filter-exports exports) (let loop ([exports exports] [kept-exps '()]) (if (null? exports) kept-exps (let-values ([(matches non-matches) (partition (lambda (exp) - (type-equal? tenv + (type-equal? (comp:export-type (car exports)) (comp:export-type exp))) exports)]) @@ -97,31 +97,31 @@ (loop non-matches (cons exp-with-stx kept-exps)) (loop non-matches (cons (car exports) kept-exps)))))))) - (define (translate-export tenv in-super? arg-type export) + (define (translate-export in-super? arg-type export) (cons 'begin (map (lambda (b) - (translate-exp-bind tenv in-super? arg-type (comp:export-type export) b)) + (translate-exp-bind in-super? arg-type (comp:export-type export) b)) (comp:export-binds export)))) - (define (translate-exp-bind tenv in-super? arg-type type binding) + (define (translate-exp-bind in-super? arg-type type binding) (let ([right-defn (if in-super? 'define/override 'define/public)]) (match binding [(struct comp:exp-bind (old-name new-name #t)) (at #f `(,right-defn (,(translate-method-name type new-name) arg-tuple) - ,(translate-static-method tenv arg-type old-name 'arg-tuple)))] + ,(translate-static-method arg-type old-name 'arg-tuple)))] [(struct comp:exp-bind (old-name new-name #f)) (at #f `(begin (,right-defn (,(translate-field-getter-name type new-name) args) - ,(translate-static-field-getter tenv arg-type old-name)) + ,(translate-static-field-getter arg-type old-name)) (,right-defn (,(translate-field-setter-name type new-name) set-arg) - ,(translate-static-field-setter tenv arg-type old-name 'set-arg))))]))) + ,(translate-static-field-setter arg-type old-name 'set-arg))))]))) (provide translate-super-new translate-inits translate-member) - (define (translate-super-new tenv arg-type super-new) + (define (translate-super-new arg-type super-new) (at (honu:ast-stx super-new) (cons 'super-new (map (lambda (a) (list (at-ctxt (honu:name-arg-name a)) - (translate-expression tenv arg-type (honu:name-arg-value a)))) + (translate-expression arg-type (honu:name-arg-value a)))) (honu:super-new-args super-new))))) (define (translate-inits inits) @@ -132,20 +132,20 @@ (define (mangle-init-name name) (at name (string->symbol (string-append "init-" (symbol->string (syntax-e name)))))) - (define (translate-member tenv arg-type member) + (define (translate-member arg-type member) (match member [(struct honu:init-field (stx name _ value)) (if value `(begin (init ([,(mangle-init-name name) ,(at-ctxt name)] - ,(translate-expression tenv arg-type value))) + ,(translate-expression arg-type value))) (define ,(at-ctxt name) ,(mangle-init-name))) `(begin (init ([,(mangle-init-name name) ,(at-ctxt name)])) (define ,(at-ctxt name) ,(mangle-init-name name))))] [(struct honu:field (stx name _ value)) - `(define ,(at-ctxt name) ,(translate-expression tenv arg-type value))] + `(define ,(at-ctxt name) ,(translate-expression arg-type value))] [(struct honu:method (stx name _ formals body)) (translate-function stx name formals - (translate-expression tenv arg-type body))])) + (translate-expression arg-type body))])) ) diff --git a/collects/honu/private/compiler/translate-expression.ss b/collects/honu/private/compiler/translate-expression.ss index b8ce52ccbe..3be3cdbb31 100644 --- a/collects/honu/private/compiler/translate-expression.ss +++ b/collects/honu/private/compiler/translate-expression.ss @@ -8,10 +8,10 @@ "../typechecker/type-utils.ss" "translate-utils.ss") - (provide/contract [translate-expression (tenv? (union honu:type? false/c) honu:expr? + (provide/contract [translate-expression ((union honu:type? false/c) honu:expr? . -> . (syntax/c any/c))]) - (define (translate-expression tenv arg-type expr) + (define (translate-expression arg-type expr) (match expr [(struct honu:lit (stx _ value)) (at stx value)] @@ -20,54 +20,54 @@ [(struct honu:tuple (stx args)) ;; list is a bindable name in Honu, so... we use list*, which isn't. (at stx `(list* ,@(map (lambda (e) - (translate-expression tenv arg-type e)) + (translate-expression arg-type e)) args) ()))] [(struct honu:lambda (stx _ formals body)) - (translate-function stx #f formals (translate-expression tenv arg-type body))] + (translate-function stx #f formals (translate-expression arg-type body))] [(struct honu:call (stx func arg)) (match func [(struct honu:member (stx 'my _ name #t)) - (at stx (translate-static-method tenv arg-type name - (translate-expression tenv arg-type arg)))] + (at stx (translate-static-method arg-type name + (translate-expression arg-type arg)))] [(struct honu:member (stx obj elab name #t)) - (at stx `(honu:send ,(translate-expression tenv arg-type obj) + (at stx `(honu:send ,(translate-expression arg-type obj) ,(translate-method-name elab name) - ,(translate-expression tenv arg-type arg)))] + ,(translate-expression arg-type arg)))] [else - (at stx `(,(translate-expression tenv arg-type func) - ,(translate-expression tenv arg-type arg)))])] + (at stx `(,(translate-expression arg-type func) + ,(translate-expression arg-type arg)))])] [(struct honu:select (stx slot arg)) - (at stx `(list-ref ,(translate-expression tenv arg-type arg) + (at stx `(list-ref ,(translate-expression arg-type arg) (- ,slot 1)))] [(struct honu:if (stx test then else)) (if else - (at stx `(if ,(translate-expression tenv arg-type test) - ,(translate-expression tenv arg-type then) - ,(translate-expression tenv arg-type else))) - (at stx `(if ,(translate-expression tenv arg-type test) - ,(translate-expression tenv arg-type then) + (at stx `(if ,(translate-expression arg-type test) + ,(translate-expression arg-type then) + ,(translate-expression arg-type else))) + (at stx `(if ,(translate-expression arg-type test) + ,(translate-expression arg-type then) ,void-value)))] [(struct honu:cond (stx clauses else)) (if else (at stx `(cond ,@(map (lambda (c) - `(,(translate-expression tenv arg-type (honu:cond-clause-pred c)) - ,(translate-expression tenv arg-type (honu:cond-clause-rhs c)))) + `(,(translate-expression arg-type (honu:cond-clause-pred c)) + ,(translate-expression arg-type (honu:cond-clause-rhs c)))) clauses) - (else ,(translate-expression tenv arg-type else)))) + (else ,(translate-expression arg-type else)))) (at stx `(cond ,@(map (lambda (c) - `(,(translate-expression tenv arg-type (honu:cond-clause-pred c)) - ,(translate-expression tenv arg-type (honu:cond-clause-rhs c)))) + `(,(translate-expression arg-type (honu:cond-clause-pred c)) + ,(translate-expression arg-type (honu:cond-clause-rhs c)))) clauses) (else ,void-value))))] [(struct honu:un-op (stx op op-stx op-type arg)) (case op [(not) (at stx - `(,(at op-stx 'not) ,(translate-expression tenv arg-type arg)))] + `(,(at op-stx 'not) ,(translate-expression arg-type arg)))] [(minus) (at stx - `(,(at op-stx '-) ,(translate-expression tenv arg-type arg)))] + `(,(at op-stx '-) ,(translate-expression arg-type arg)))] [else (raise-read-error-with-stx "Haven't translated unary operator yet." op-stx)])] @@ -78,222 +78,222 @@ (eqv? (honu:type-prim-name op-type) 'string)) (at stx `(,(at op-stx 'string=?) - ,(translate-expression tenv arg-type larg) - ,(translate-expression tenv arg-type rarg))) + ,(translate-expression arg-type larg) + ,(translate-expression arg-type rarg))) (at stx `(,(at op-stx 'eqv?) - ,(translate-expression tenv arg-type larg) - ,(translate-expression tenv arg-type rarg))))] + ,(translate-expression arg-type larg) + ,(translate-expression arg-type rarg))))] [(neq) (if (and (honu:type-prim? op-type) (eqv? (honu:type-prim-name op-type) 'string)) (at stx `(,(at op-stx 'not) (,(at op-stx 'string=?) - ,(translate-expression tenv arg-type larg) - ,(translate-expression tenv arg-type rarg)))) + ,(translate-expression arg-type larg) + ,(translate-expression arg-type rarg)))) (at stx `(,(at op-stx 'not) (,(at op-stx 'eqv?) - ,(translate-expression tenv arg-type larg) - ,(translate-expression tenv arg-type rarg)))))] + ,(translate-expression arg-type larg) + ,(translate-expression arg-type rarg)))))] [(clseq) (at stx `(,(at op-stx 'equal?) - ,(translate-expression tenv arg-type larg) - ,(translate-expression tenv arg-type rarg)))] + ,(translate-expression arg-type larg) + ,(translate-expression arg-type rarg)))] [(and) (at stx `(,(at op-stx 'and) - ,(translate-expression tenv arg-type larg) - ,(translate-expression tenv arg-type rarg)))] + ,(translate-expression arg-type larg) + ,(translate-expression arg-type rarg)))] [(or) (at stx `(,(at op-stx 'or) - ,(translate-expression tenv arg-type larg) - ,(translate-expression tenv arg-type rarg)))] + ,(translate-expression arg-type larg) + ,(translate-expression arg-type rarg)))] [(lt) (case (honu:type-prim-name op-type) [(int float) (at stx `(,(at op-stx '<) - ,(translate-expression tenv arg-type larg) - ,(translate-expression tenv arg-type rarg)))] + ,(translate-expression arg-type larg) + ,(translate-expression arg-type rarg)))] [(string) (at stx `(,(at op-stx 'string) - ,(translate-expression tenv arg-type larg) - ,(translate-expression tenv arg-type rarg)))] + ,(translate-expression arg-type larg) + ,(translate-expression arg-type rarg)))] [(string) (at stx `(,(at op-stx 'string>?) - ,(translate-expression tenv arg-type larg) - ,(translate-expression tenv arg-type rarg)))] + ,(translate-expression arg-type larg) + ,(translate-expression arg-type rarg)))] [(char) (at stx `(,(at op-stx 'char>?) - ,(translate-expression tenv arg-type larg) - ,(translate-expression tenv arg-type rarg)))])] + ,(translate-expression arg-type larg) + ,(translate-expression arg-type rarg)))])] [(ge) (case (honu:type-prim-name op-type) [(int float) (at stx `(,(at op-stx '>=) - ,(translate-expression tenv arg-type larg) - ,(translate-expression tenv arg-type rarg)))] + ,(translate-expression arg-type larg) + ,(translate-expression arg-type rarg)))] [(string) (at stx `(,(at op-stx 'string>=?) - ,(translate-expression tenv arg-type larg) - ,(translate-expression tenv arg-type rarg)))] + ,(translate-expression arg-type larg) + ,(translate-expression arg-type rarg)))] [(char) (at stx `(,(at op-stx 'char>=?) - ,(translate-expression tenv arg-type larg) - ,(translate-expression tenv arg-type rarg)))])] + ,(translate-expression arg-type larg) + ,(translate-expression arg-type rarg)))])] [(plus) (case (honu:type-prim-name op-type) [(int float) (at stx `(,(at op-stx '+) - ,(translate-expression tenv arg-type larg) - ,(translate-expression tenv arg-type rarg)))] + ,(translate-expression arg-type larg) + ,(translate-expression arg-type rarg)))] [(string) (at stx `(,(at op-stx 'string-append) - ,(translate-expression tenv arg-type larg) - ,(translate-expression tenv arg-type rarg)))])] + ,(translate-expression arg-type larg) + ,(translate-expression arg-type rarg)))])] [(minus) (at stx `(,(at op-stx '-) - ,(translate-expression tenv arg-type larg) - ,(translate-expression tenv arg-type rarg)))] + ,(translate-expression arg-type larg) + ,(translate-expression arg-type rarg)))] [(times) (at stx `(,(at op-stx '*) - ,(translate-expression tenv arg-type larg) - ,(translate-expression tenv arg-type rarg)))] + ,(translate-expression arg-type larg) + ,(translate-expression arg-type rarg)))] [(div) (case (honu:type-prim-name op-type) [(int) (at stx `(,(at op-stx 'quotient) - ,(translate-expression tenv arg-type larg) - ,(translate-expression tenv arg-type rarg)))] + ,(translate-expression arg-type larg) + ,(translate-expression arg-type rarg)))] [(float) (at stx `(,(at op-stx '/) - ,(translate-expression tenv arg-type larg) - ,(translate-expression tenv arg-type rarg)))])] + ,(translate-expression arg-type larg) + ,(translate-expression arg-type rarg)))])] [(mod) (at stx `(,(at op-stx 'remainder) - ,(translate-expression tenv arg-type larg) - ,(translate-expression tenv arg-type rarg)))] + ,(translate-expression arg-type larg) + ,(translate-expression arg-type rarg)))] [else (raise-read-error-with-stx "Haven't translated binary operator yet." op-stx)])] [(struct honu:return (stx body)) (at stx - `(last-k ,(translate-expression tenv arg-type body)))] + `(last-k ,(translate-expression arg-type body)))] [(struct honu:let (stx bindings body)) (at stx `(let*-values ,(map (lambda (b) (let-values ([(bound-names body) (translate-binding-clause (honu:binding-names b) - (translate-expression tenv arg-type (honu:binding-value b)))]) + (translate-expression arg-type (honu:binding-value b)))]) ;; make sure to give the let binding the appropriate syntax, ;; otherwise errors will highlight the entire let expression. (at (honu:ast-stx b) `(,bound-names ,body)))) bindings) - ,(translate-expression tenv arg-type body)))] + ,(translate-expression arg-type body)))] [(struct honu:seq (stx effects value)) (at stx `(begin ,@(map (lambda (e) - (translate-expression tenv arg-type e)) + (translate-expression arg-type e)) effects) - ,(translate-expression tenv arg-type value)))] + ,(translate-expression arg-type value)))] [(struct honu:while (stx test body)) (at stx `(let loop () - (if ,(translate-expression tenv arg-type test) - (begin ,(translate-expression tenv arg-type body) (loop)) + (if ,(translate-expression arg-type test) + (begin ,(translate-expression arg-type body) (loop)) ,void-value)))] [(struct honu:assn (stx lhs rhs)) (match lhs [(struct honu:var (_ _)) - (at stx `(begin (set! ,(translate-expression tenv arg-type lhs) - ,(translate-expression tenv arg-type rhs)) + (at stx `(begin (set! ,(translate-expression arg-type lhs) + ,(translate-expression arg-type rhs)) ,void-value))] [(struct honu:member (mstx 'my _ name method?)) (if method? (raise-read-error-with-stx "Left-hand side of assignment cannot be a method name" mstx) - (at stx (translate-static-field-setter tenv arg-type name - (translate-expression tenv arg-type rhs))))] + (at stx (translate-static-field-setter arg-type name + (translate-expression arg-type rhs))))] [(struct honu:member (mstx obj elab name method?)) (if method? (raise-read-error-with-stx "Left-hand side of assignment cannot be a method name" mstx) - (at stx `(honu:send ,(translate-expression tenv arg-type obj) + (at stx `(honu:send ,(translate-expression arg-type obj) ,(translate-field-setter-name elab name) - ,(translate-expression tenv arg-type rhs))))] + ,(translate-expression arg-type rhs))))] [else (raise-read-error-with-stx "Left-hand side of assignment is invalid" stx)])] [(struct honu:member (stx 'my _ name method?)) (if method? - (at stx (translate-static-method tenv arg-type name)) - (at stx (translate-static-field-getter tenv arg-type name)))] + (at stx (translate-static-method arg-type name)) + (at stx (translate-static-field-getter arg-type name)))] [(struct honu:member (stx obj elab name method?)) (if method? (at stx `(lambda (args) - (honu:send ,(translate-expression tenv arg-type obj) + (honu:send ,(translate-expression arg-type obj) ,(translate-method-name elab name) args))) - (at stx `(honu:send ,(translate-expression tenv arg-type obj) + (at stx `(honu:send ,(translate-expression arg-type obj) ,(translate-field-getter-name elab name) ,void-value)))] [(struct honu:new (stx class _ args)) (at stx `(new ,(translate-class-name class) ,@(map (lambda (a) `(,(honu:name-arg-name a) - ,(translate-expression tenv arg-type (honu:name-arg-value a)))) + ,(translate-expression arg-type (honu:name-arg-value a)))) args)))] [(struct honu:cast (stx obj type)) - (at stx `(let ([cast-obj ,(translate-expression tenv arg-type obj)]) + (at stx `(let ([cast-obj ,(translate-expression arg-type obj)]) ;; you can always cast null to an interface type (if (or (is-a? cast-obj null%) (is-a? cast-obj ,(translate-iface-name type))) @@ -307,7 +307,7 @@ (string->symbol (substring class-string 0 (- (string-length class-string) 1)))) (quote ,(printable-type type))))))))] [(struct honu:isa (stx obj type)) - (at stx `(let ([cast-obj ,(translate-expression tenv arg-type obj)]) + (at stx `(let ([cast-obj ,(translate-expression arg-type obj)]) ;; null is a member of any interface type (or (is-a? cast-obj null%) (is-a? cast-obj ,(translate-iface-name type)))))] diff --git a/collects/honu/private/compiler/translate-utils.ss b/collects/honu/private/compiler/translate-utils.ss index 327963bc86..c1c1206323 100644 --- a/collects/honu/private/compiler/translate-utils.ss +++ b/collects/honu/private/compiler/translate-utils.ss @@ -3,11 +3,9 @@ (require (all-except (lib "list.ss" "srfi" "1") any) (lib "contract.ss") "../../ast.ss" + "../../parameters.ss" "../../tenv.ss") - (provide current-compile-context) - (define current-compile-context (make-parameter #f)) - (define stx-for-original-property (read-syntax #f (open-input-string "original"))) (provide/contract [at ((union (syntax/c any/c) false/c) @@ -93,9 +91,9 @@ "-set!")))) (provide translate-static-method translate-static-field-getter translate-static-field-setter) - (define (translate-static-method tenv arg-type name arg) + (define (translate-static-method arg-type name arg) (if arg-type - (let ([type-entry (get-type-entry tenv arg-type)]) + (let ([type-entry (get-type-entry arg-type)]) (if (s:member name (map tenv:member-name (append (tenv:type-members type-entry) (tenv:type-inherited type-entry))) @@ -111,9 +109,9 @@ `(,(at-ctxt name) ,arg) (at-ctxt name)))) - (define (translate-static-field-getter tenv arg-type name) + (define (translate-static-field-getter arg-type name) (if arg-type - (let ([type-entry (get-type-entry tenv arg-type)]) + (let ([type-entry (get-type-entry arg-type)]) (if (s:member name (map tenv:member-name (append (tenv:type-members type-entry) (tenv:type-inherited type-entry))) @@ -122,9 +120,9 @@ (at-ctxt name))) (at-ctxt name))) - (define (translate-static-field-setter tenv arg-type name arg) + (define (translate-static-field-setter arg-type name arg) (if arg-type - (let ([type-entry (get-type-entry tenv arg-type)]) + (let ([type-entry (get-type-entry arg-type)]) (if (s:member name (map tenv:member-name (append (tenv:type-members type-entry) (tenv:type-inherited type-entry))) diff --git a/collects/honu/private/compiler/translate.ss b/collects/honu/private/compiler/translate.ss index 74b73c86cb..796d4a199d 100644 --- a/collects/honu/private/compiler/translate.ss +++ b/collects/honu/private/compiler/translate.ss @@ -11,13 +11,13 @@ "translate-expression.ss" "translate-utils.ss") - (provide/contract [translate (tenv? (listof honu:defn?) + (provide/contract [translate ((listof honu:defn?) . -> . (listof (syntax/c any/c)))] - [translate-defn (tenv? honu:defn? + [translate-defn (honu:defn? . -> . (syntax/c any/c))]) - (define (translate tenv defns) + (define (translate defns) (let loop ([defns-to-go defns] [syntaxes '()]) (cond @@ -30,13 +30,13 @@ (tenv-key=? (honu:mixin-name d) (honu:subclass-mixin (car defns-to-go))))) defns)]) - (loop (cdr defns-to-go) (cons (translate-subclass tenv mixin (car defns-to-go)) syntaxes)))] + (loop (cdr defns-to-go) (cons (translate-subclass mixin (car defns-to-go)) syntaxes)))] [else - (loop (cdr defns-to-go) (cons (translate-defn tenv (car defns-to-go)) syntaxes))]))) + (loop (cdr defns-to-go) (cons (translate-defn (car defns-to-go)) syntaxes))]))) - (define (translate-member-names tenv name) + (define (translate-member-names name) (let* ([iface (make-iface-type name name)] - [type-entry (get-type-entry tenv iface)]) + [type-entry (get-type-entry iface)]) (let loop ([members (append (tenv:type-members type-entry) (tenv:type-inherited type-entry))] [names '()]) (if (null? members) @@ -50,38 +50,38 @@ (cons (translate-field-getter-name iface (tenv:member-name (car members))) names)))))))) - (define (translate-defn tenv defn) + (define (translate-defn defn) (match defn [(struct honu:bind-top (stx names _ value)) - (let-values ([(bound-names body) (translate-binding-clause names (translate-expression tenv #f value))]) + (let-values ([(bound-names body) (translate-binding-clause names (translate-expression #f value))]) (at stx `(define-values ,bound-names ,body)))] [(struct honu:function (stx name _ args body)) - (translate-function stx name args (translate-expression tenv #f body))] + (translate-function stx name args (translate-expression #f body))] [(struct honu:iface (stx name supers members)) (at stx `(define ,(translate-iface-name (make-iface-type name name)) (interface ,(if (null? supers) (list (translate-iface-name (make-any-type #f))) (map translate-iface-name supers)) - ,@(translate-member-names tenv name))))] + ,@(translate-member-names name))))] [(struct honu:class (stx name _ _ impls inits members exports)) (at stx `(define ,(translate-class-name name) (class* object% ,(map translate-iface-name impls) (inspect #f) ,(translate-inits inits) ,@(map (lambda (m) - (translate-member tenv #f m)) members) - ,@(translate-class-exports tenv exports) - ,(translate-formatter tenv name members #f) + (translate-member #f m)) members) + ,@(translate-class-exports exports) + ,(translate-formatter name members #f) (super-new))))] [else (raise-read-error-with-stx "Haven't translated that type of definition yet." (honu:ast-stx defn))])) - (define (translate-subclass tenv mixin-defn defn) + (define (translate-subclass mixin-defn defn) (match (list mixin-defn defn) [(list (struct honu:mixin (mstx mname _ arg-type _ impls inits _ super-new members-before members-after exports)) (struct honu:subclass (stx name base mixin))) - (let* ([base-entry (get-class-entry tenv base)] + (let* ([base-entry (get-class-entry base)] [base-types (cons (tenv:class-sub-type base-entry) (tenv:class-impls base-entry))]) (at stx `(define ,(translate-class-name name) @@ -89,14 +89,14 @@ (inspect #f) ,(translate-inits inits) ,@(map (lambda (m) - (translate-member tenv arg-type m)) members-before) - ,(translate-super-new tenv arg-type super-new) + (translate-member arg-type m)) members-before) + ,(translate-super-new arg-type super-new) ,@(map (lambda (m) - (translate-member tenv arg-type m)) members-after) - ,@(translate-subclass-exports tenv base-types arg-type exports) - ,(translate-formatter tenv name (append members-before members-after) arg-type)))))])) + (translate-member arg-type m)) members-after) + ,@(translate-subclass-exports base-types arg-type exports) + ,(translate-formatter name (append members-before members-after) arg-type)))))])) - (define (translate-formatter tenv name members arg-type) + (define (translate-formatter name members arg-type) (let ([right-define (if arg-type 'define/override 'define/public)]) `(,right-define (format-class renderer indent print-fields?) (if print-fields? @@ -111,7 +111,7 @@ (if (not (honu:type-disp? (tenv:member-type m))) (tenv:member-name m) #f)) - (tenv:type-members (get-type-entry tenv arg-type))) + (tenv:type-members (get-type-entry arg-type))) '())] ;; how much more do we want the members indented? Let's try 2 spaces more. [indent-delta 2]) @@ -119,7 +119,7 @@ (null? printable-smembers)) '("") (fold-right (lambda (m l) - (list* "\n" (translate-super-member-formatter tenv arg-type m indent-delta) l)) + (list* "\n" (translate-super-member-formatter arg-type m indent-delta) l)) (fold-right (lambda (m l) (list* "\n" (translate-member-formatter m indent-delta) l)) '("\n" (make-string indent #\space)) @@ -137,11 +137,11 @@ ;; the 3 is for " = " (renderer ,name (+ indent ,(+ indent-delta (string-length (symbol->string (syntax-e name))) 3)))))) - (define (translate-super-member-formatter tenv arg-type name indent-delta) + (define (translate-super-member-formatter arg-type name indent-delta) `(format "~a~a = ~a;" (make-string (+ indent ,indent-delta) #\space) (quote ,(syntax-e name)) ;; as before, the 3 is for " = " - (renderer ,(translate-static-field-getter tenv arg-type name) + (renderer ,(translate-static-field-getter arg-type name) (+ indent ,(+ indent-delta (string-length (symbol->string (syntax-e name))) 3))))) ) \ No newline at end of file diff --git a/collects/honu/private/typechecker/type-utils.ss b/collects/honu/private/typechecker/type-utils.ss index 68698b1812..d6c3abc30b 100644 --- a/collects/honu/private/typechecker/type-utils.ss +++ b/collects/honu/private/typechecker/type-utils.ss @@ -82,7 +82,7 @@ "null"])) (provide type-valid?) - (define (type-valid? tenv t) + (define (type-valid? t) (match t [(struct honu:type-iface-top (_)) #t] [(struct honu:type-prim (stx name)) @@ -92,22 +92,22 @@ (format "Unexpected primitive type ~a" name) stx)])] [(struct honu:type-iface (stx name)) - (let ([tentry (get-tenv-entry tenv name)]) + (let ([tentry (get-tenv-entry name)]) (and tentry (tenv:type? tentry)))] [(struct honu:type-tuple (_ args)) (andmap (lambda (t) - (type-valid? tenv t)) + (type-valid? t)) args)] [(struct honu:type-func (_ arg ret)) - (and (type-valid? tenv arg) - (type-valid? tenv ret))] + (and (type-valid? arg) + (type-valid? ret))] [(struct honu:type-disp (_ disp arg ret)) - (and (type-valid? tenv disp) - (type-valid? tenv arg) - (type-valid? tenv ret))])) + (and (type-valid? disp) + (type-valid? arg) + (type-valid? ret))])) (provide type-equal?) - (define (type-equal? tenv t1 t2) + (define (type-equal? t1 t2) (cond ;; first all the easy ones [(and (honu:type-top? t1) @@ -135,13 +135,13 @@ ;; function, dispatch types are equal if their component types are. [(and (honu:type-func? t1) (honu:type-func? t2)) - (and (type-equal? tenv (honu:type-func-arg t1) (honu:type-func-arg t2)) - (type-equal? tenv (honu:type-func-ret t1) (honu:type-func-ret t2)))] + (and (type-equal? (honu:type-func-arg t1) (honu:type-func-arg t2)) + (type-equal? (honu:type-func-ret t1) (honu:type-func-ret t2)))] [(and (honu:type-disp? t1) (honu:type-disp? t2)) - (and (type-equal? tenv (honu:type-disp-disp t1) (honu:type-disp-disp t2)) - (type-equal? tenv (honu:type-disp-arg t1) (honu:type-disp-arg t2)) - (type-equal? tenv (honu:type-disp-ret t1) (honu:type-disp-ret t2)))] + (and (type-equal? (honu:type-disp-disp t1) (honu:type-disp-disp t2)) + (type-equal? (honu:type-disp-arg t1) (honu:type-disp-arg t2)) + (type-equal? (honu:type-disp-ret t1) (honu:type-disp-ret t2)))] ;; tuple types are equal if they have the same number of components and ;; their components are pairwise equal [(and (honu:type-tuple? t1) @@ -150,7 +150,7 @@ [t2-args (honu:type-tuple-args t2)]) (and (= (length t1-args) (length t2-args)) (andmap (lambda (t1 t2) - (type-equal? tenv t1 t2)) + (type-equal? t1 t2)) t1-args t2-args)))] ;; for select types, they must be the same type on the same slot ;; (should we even get here?) @@ -169,8 +169,8 @@ #'Any])) ;; is t1 a _direct_ subtype of t2? - (define (Subtype_P tenv t1 t2) - (let ([type-entry (get-type-entry tenv t1)]) + (define (Subtype_P t1 t2) + (let ([type-entry (get-type-entry t1)]) (match type-entry [(struct tenv:type (_ supers _ _)) (let ([super-names (map get-type-name supers)]) @@ -178,10 +178,10 @@ ;; is t1 a (ref-trans-closed) subtype of t2? (provide <:_P) - (define (<:_P tenv t1 t2) + (define (<:_P t1 t2) (cond ;; if t1 = t2, t1 <:_P t2 - [(type-equal? tenv t1 t2) + [(type-equal? t1 t2) #t] ;; if t1 is the bottom of the type lattice, then it trivially holds [(honu:type-bot? t1) @@ -197,15 +197,15 @@ [(and (honu:type-func? t1) (honu:type-func? t2)) ;; the arg is contravariant and the ret is covariant - (and (<:_P tenv (honu:type-func-arg t2) (honu:type-func-arg t1)) - (<:_P tenv (honu:type-func-ret t1) (honu:type-func-ret t2)))] + (and (<:_P (honu:type-func-arg t2) (honu:type-func-arg t1)) + (<:_P (honu:type-func-ret t1) (honu:type-func-ret t2)))] ;; for dispatch types... [(and (honu:type-disp? t1) (honu:type-disp? t2)) ;; dispatch args must be co-, regular args contra-, and ret co- - (and (<:_P tenv (honu:type-disp-disp t1) (honu:type-disp-disp t2)) - (<:_P tenv (honu:type-disp-arg t2) (honu:type-disp-arg t1)) - (<:_P tenv (honu:type-disp-ret t1) (honu:type-disp-ret t2)))] + (and (<:_P (honu:type-disp-disp t1) (honu:type-disp-disp t2)) + (<:_P (honu:type-disp-arg t2) (honu:type-disp-arg t1)) + (<:_P (honu:type-disp-ret t1) (honu:type-disp-ret t2)))] ;; for tuple types... [(and (honu:type-tuple? t1) (honu:type-tuple? t2)) @@ -215,7 +215,7 @@ (and (= (length t1-args) (length t2-args)) ;; and each component must be a subtype (covariantly) (andmap (lambda (t1 t2) - (<:_P tenv t1 t2)) + (<:_P t1 t2)) t1-args t2-args)))] ;; for a select statement (s, t), we have that a tuple type (t_1 ... t_n) is <:_P t if ;; if t_s <:_P t. @@ -225,12 +225,12 @@ [t1-args (honu:type-tuple-args t1)]) (and (<= t2-slot (length t1-args)) ;; we have to subtract one from t2-slot because list-ref is zero-based - (<:_P tenv (list-ref t1-args (- t2-slot 1)) (honu:type-select-type t2))))] + (<:_P (list-ref t1-args (- t2-slot 1)) (honu:type-select-type t2))))] ;; not sure if this is necessary. Hmm. [(and (honu:type-select? t1) (honu:type-select? t2)) (and (= (honu:type-select-slot t1) (honu:type-select-slot t2)) - (<:_P tenv (honu:type-select-type t1) (honu:type-select-type t2)))] + (<:_P (honu:type-select-type t1) (honu:type-select-type t2)))] ;; the bottom of the iface lattice is <:_P either the iface-top or ;; any iface [(and (honu:type-iface-bot? t1) @@ -244,14 +244,14 @@ ;; if two (non-equal) iface types... [(and (honu:type-iface? t1) (honu:type-iface? t2)) - (if (Subtype_P tenv t1 t2) + (if (Subtype_P t1 t2) ;; return true if it's a direct subtype relation #t - (let ([type-entry (get-type-entry tenv t1)]) + (let ([type-entry (get-type-entry t1)]) ;; if any of the direct supertypes of t1 is a subtype of t2, ;; then t1 is also (ormap (lambda (t) - (<:_P tenv t t2)) + (<:_P t t2)) (tenv:type-supers type-entry))))] [else #f])) diff --git a/collects/honu/private/typechecker/typecheck-class-utils.ss b/collects/honu/private/typechecker/typecheck-class-utils.ss index 51e110529f..c9cd01de7f 100644 --- a/collects/honu/private/typechecker/typecheck-class-utils.ss +++ b/collects/honu/private/typechecker/typecheck-class-utils.ss @@ -8,16 +8,17 @@ "../../tenv.ss" "../../utils.ss" "typecheck-expression.ss" + "typecheck-parameters.ss" "type-utils.ss") (provide extend-cenv-with-type-members typecheck-members typecheck-supernew typecheck-exports) - (define (typecheck-exports tenv cenv selftype init-impls exports) + (define (typecheck-exports cenv selftype init-impls exports) (let loop ([impls init-impls] [exports exports]) (cond [(and (null? exports) (null? impls)) - (if (not (s:member selftype init-impls (lambda (t1 t2) (type-equal? tenv t1 t2)))) + (if (not (s:member selftype init-impls (lambda (t1 t2) (type-equal? t1 t2)))) (raise-read-error-with-stx (format "No export statement for self type ~a" (printable-type selftype)) @@ -31,21 +32,21 @@ (printable-type (car impls))) (honu:ast-stx (car impls)))] [(null? impls) - (if (s:member selftype init-impls (lambda (t1 t2) (type-equal? tenv t1 t2))) + (if (s:member selftype init-impls (lambda (t1 t2) (type-equal? t1 t2))) (raise-read-error-with-stx (format "Extra export statement for unimplemented type ~a" (printable-type (honu:export-type (car exports)))) (honu:ast-stx (car exports))) (let-values ([(matched non-matches) (partition-first (lambda (e) - (type-equal? tenv (honu:export-type e) selftype)) + (type-equal? (honu:export-type e) selftype)) exports)]) (if (not matched) (raise-read-error-with-stx (format "No export statement for self type ~a" (printable-type selftype)) (honu:ast-stx selftype)) - (let ([type-entry (get-type-entry tenv selftype)]) - (typecheck-export tenv cenv type-entry matched) + (let ([type-entry (get-type-entry selftype)]) + (typecheck-export cenv type-entry matched) (if (not (null? non-matches)) (raise-read-error-with-stx (format "Extra export statement for unimplemented type ~a" @@ -54,19 +55,19 @@ (void))))))] [else (let-values ([(matched non-matches) (partition-first (lambda (t) - (type-equal? tenv (honu:export-type (car exports)) t)) + (type-equal? (honu:export-type (car exports)) t)) impls)]) (if (not matched) (raise-read-error-with-stx (format "Extra export statement for unimplemented type ~a" (honu:export-type (car exports))) (honu:ast-stx (car exports))) - (let* ([type-entry (get-type-entry tenv matched)] + (let* ([type-entry (get-type-entry matched)] [export (car exports)]) - (typecheck-export tenv cenv type-entry export) + (typecheck-export cenv type-entry export) (loop non-matches (cdr exports)))))]))) - (define (typecheck-export tenv cenv type-entry export) + (define (typecheck-export cenv type-entry export) ;; make sure to use both defined members and inherited members here (let loop ([type-members (append (tenv:type-members type-entry) (tenv:type-inherited type-entry))] [export-binds (honu:export-binds export)]) @@ -106,7 +107,7 @@ (honu:exp-bind-new (car export-binds)))] ;; if it's a method, then allow exporting a subtype [(honu:type-disp? (tenv:member-type matched)) - (if (<:_P tenv cenv-entry (tenv:member-type matched)) + (if (<:_P cenv-entry (tenv:member-type matched)) (loop non-matches (cdr export-binds)) (raise-read-error-with-stx (format "Exported static member ~a has type ~a which is not a subtype of ~a's type ~a" @@ -117,7 +118,7 @@ (honu:exp-bind-old (car export-binds))))] ;; for fields, we just do invariance until we get read-only fields [else - (if (type-equal? tenv cenv-entry (tenv:member-type matched)) + (if (type-equal? cenv-entry (tenv:member-type matched)) (loop non-matches (cdr export-binds)) (raise-read-error-with-stx (format "Exported static member ~a has type ~a which is not the same type as ~a's type ~a" @@ -129,8 +130,8 @@ - (define (extend-cenv-with-type-members tenv cenv type) - (let ([type-entry (get-type-entry tenv type)]) + (define (extend-cenv-with-type-members cenv type) + (let ([type-entry (get-type-entry type)]) (fold (lambda (m e) (extend-fenv (tenv:member-name m) (tenv:member-type m) @@ -138,7 +139,7 @@ cenv (tenv:type-members type-entry)))) - (define (typecheck-supernew tenv cenv lenv withs supernew) + (define (typecheck-supernew cenv lenv withs supernew) (let loop ([withs withs] [args (honu:super-new-args supernew)] [checked-args '()]) @@ -168,10 +169,10 @@ (printable-key (honu:name-arg-name (car args)))) (honu:name-arg-name (car args))) (let ([first-arg (car args)]) - (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv - (honu:formal-type matched) - (honu:formal-type matched) - (honu:name-arg-value first-arg))]) + (let-values ([(e1 t1) (parameterize ([current-class-environment cenv]) + (typecheck-expression lenv + (honu:formal-type matched) + (honu:name-arg-value first-arg)))]) (loop non-matches (cdr args) (cons (copy-struct honu:name-arg first-arg @@ -179,7 +180,7 @@ checked-args))))))]))) - (define (typecheck-members tenv cenv lenv selftype members) + (define (typecheck-members cenv lenv selftype members) (let loop ([members members] [cenv cenv] [ret '()]) @@ -188,7 +189,7 @@ (values (reverse ret) cenv)] [(or (honu:init-field? (car members)) (honu:field? (car members))) - (let ([member (typecheck-member tenv cenv lenv selftype (car members))]) + (let ([member (typecheck-member cenv lenv selftype (car members))]) (loop (cdr members) (extend-fenv (get-class-member-name (car members)) (get-class-member-type selftype (car members)) @@ -207,48 +208,51 @@ ;; I only through the reverse in to keep the order the same. ;; it doesn't really matter. (append (reverse (map (lambda (m) - (typecheck-member tenv cenv lenv selftype m)) + (typecheck-member cenv lenv selftype m)) methods)) ret))))]))) - (define (typecheck-member tenv cenv lenv selftype member) + (define (typecheck-member cenv lenv selftype member) (match member [(struct honu:init-field (stx name type value)) - (if (not (type-valid? tenv type)) + (if (not (type-valid? type)) (raise-read-error-with-stx "Type of init field is undefined" (honu:ast-stx type))) (if value - (let-values ([(e1 t1) (typecheck-expression tenv cenv (extend-fenv #'this selftype lenv) type #f value)]) + (let-values ([(e1 t1) (parameterize ([current-class-environment cenv]) + (typecheck-expression lenv type value))]) (copy-struct honu:init-field member [honu:init-field-value e1])) member)] [(struct honu:field (stx name type value)) - (if (not (type-valid? tenv type)) + (if (not (type-valid? type)) (raise-read-error-with-stx "Type of field is undefined" (honu:ast-stx type))) - (let-values ([(e1 t1) (typecheck-expression tenv cenv (extend-fenv #'this selftype lenv) type #f value)]) + (let-values ([(e1 t1) (parameterize ([current-class-environment cenv]) + (typecheck-expression cenv lenv type value))]) (copy-struct honu:field member [honu:field-value e1]))] [(struct honu:method (stx name type args body)) - (if (not (type-valid? tenv type)) + (if (not (type-valid? type)) (raise-read-error-with-stx "Return type of method is undefined" (honu:ast-stx type))) (for-each (lambda (t) - (if (not (type-valid? tenv t)) + (if (not (type-valid? t)) (raise-read-error-with-stx "Type of method argument is undefined" (honu:ast-stx t)))) (map honu:formal-type args)) - (let-values ([(e1 t1) (typecheck-expression tenv cenv (fold (lambda (arg fenv) - (extend-fenv (honu:formal-name arg) - (honu:formal-type arg) - fenv)) - (extend-fenv #'this selftype lenv) - args) - type type body)]) + (let-values ([(e1 t1) (parameterize ([current-class-environment cenv] + [current-return-type type]) + (typecheck-expression (fold (lambda (arg fenv) + (extend-fenv (honu:formal-name arg) + (honu:formal-type arg) + fenv)) + lenv args) + type body))]) (copy-struct honu:method member [honu:method-body e1]))])) diff --git a/collects/honu/private/typechecker/typecheck-expression.ss b/collects/honu/private/typechecker/typecheck-expression.ss index 64cbf4057d..13ca2d9e18 100644 --- a/collects/honu/private/typechecker/typecheck-expression.ss +++ b/collects/honu/private/typechecker/typecheck-expression.ss @@ -8,39 +8,30 @@ "../../readerr.ss" "../../tenv.ss" "../../utils.ss" + "typecheck-parameters.ss" "type-utils.ss") - (provide/contract [typecheck-expression ((tenv? - ((syntax/c symbol?) . -> . (union honu:type? false/c)) - ((syntax/c symbol?) . -> . (union honu:type? false/c)) - (union honu:type? false/c) + (provide/contract [typecheck-expression ((((syntax/c symbol?) . -> . (union honu:type? false/c)) (union honu:type? false/c) honu:expr?) . ->* . (honu:expr? honu:type?))]) - ;; tenv : tenv? - ;; interface/class/mixin environment - ;; cenv : ((syntax/c symbol?) . -> . (union honu:type false/c)) - ;; static environment inside of a class or mixin definition - ;; (i.e. for my.) ;; lenv : ((syntax/c symbol?) . -> . (union honu:type false/c)) ;; lexical environment (includes top-level bindings and ;; binding for #'this if inside class or mixin) ;; ctype : (union honu:type? false/c) ;; type of context for expression - ;; rtype : (union honu:type? false/c) - ;; return type for method/function ;; expr : honu:expr? ;; expression to typecheck - (define (typecheck-expression tenv cenv lenv ctype rtype expr) + (define (typecheck-expression lenv ctype expr) (match expr [(struct honu:this (stx)) (cond [(lenv #'this) => (lambda (t) - (if (<:_P tenv t ctype) + (if (<:_P t ctype) (values expr t) (raise-honu-type-error stx ctype t)))] [else (raise-read-error-with-stx @@ -52,7 +43,7 @@ ;; a) (>= (length args) n) ;; b) (type-equal? (list-ref args (- n 1)) t) ;; c) (list-ref args m) <:_P (type-top) for all m =/= n (vacuously true) - (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-honu:type-select stx slot ctype) rtype arg)]) + (let-values ([(e1 t1) (typecheck-expression lenv (make-honu:type-select stx slot ctype) arg)]) (if (not (honu:type-tuple? t1)) (raise-read-error-with-stx "Tried to use select with non-tuple expression" stx)) (let ([etype (list-ref (honu:type-tuple-args t1) (- slot 1))]) @@ -62,7 +53,7 @@ [(struct honu:var (stx name)) (cond [(lenv name) => (lambda (t) - (if (<:_P tenv t ctype) + (if (<:_P t ctype) (values expr t) (raise-honu-type-error stx ctype t)))] [else (raise-read-error-with-stx @@ -70,44 +61,44 @@ stx)])] [(struct honu:assn (stx lhs rhs)) ;; the context type for the lhs is a vacuous one. - (let*-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-top-type (honu:ast-stx lhs)) rtype lhs)] - [(e2 t2) (typecheck-expression tenv cenv lenv t1 rtype rhs)]) + (let*-values ([(e1 t1) (typecheck-expression lenv (make-top-type (honu:ast-stx lhs)) lhs)] + [(e2 t2) (typecheck-expression lenv t1 rhs)]) (let ([void-type (make-void-type stx)]) - (if (<:_P tenv void-type ctype) + (if (<:_P void-type ctype) (values (copy-struct honu:assn expr [honu:assn-lhs e1] [honu:assn-rhs e2]) void-type) (raise-honu-type-error stx ctype void-type))))] [(struct honu:call (stx func arg)) - (let*-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-func-type (honu:ast-stx func) + (let*-values ([(e1 t1) (typecheck-expression lenv (make-func-type (honu:ast-stx func) (make-bottom-type (honu:ast-stx func)) - ctype) rtype func)] - [(e2 t2) (typecheck-expression tenv cenv lenv (honu:type-func-arg t1) rtype arg)]) + ctype) func)] + [(e2 t2) (typecheck-expression lenv (honu:type-func-arg t1) arg)]) (let ([ret-type (honu:type-func-ret t1)]) - (if (<:_P tenv ret-type ctype) + (if (<:_P ret-type ctype) (values (copy-struct honu:call expr [honu:call-func e1] [honu:call-arg e2]) ret-type) (raise-honu-type-error stx ctype ret-type))))] [(struct honu:lit (stx type value)) - (if (<:_P tenv type ctype) + (if (<:_P type ctype) (values expr type) (raise-honu-type-error stx ctype type))] [(struct honu:un-op (stx op op-stx _ arg)) (case op [(not) - (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-bool-type (honu:ast-stx arg)) rtype arg)]) + (let-values ([(e1 t1) (typecheck-expression lenv (make-bool-type (honu:ast-stx arg)) arg)]) (let ([ret-type (make-bool-type stx)]) - (if (<:_P tenv ret-type ctype) + (if (<:_P ret-type ctype) (values (copy-struct honu:un-op expr [honu:un-op-op-type t1] [honu:un-op-arg e1]) ret-type) (raise-honu-type-error stx ctype ret-type))))] [(minus) - (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-top-type (honu:ast-stx arg)) rtype arg)]) + (let-values ([(e1 t1) (typecheck-expression lenv (make-top-type (honu:ast-stx arg)) arg)]) (if (not (honu:type-prim? t1)) (raise-read-error-with-stx "Invalid type for argument to unary minus" @@ -119,7 +110,7 @@ (format "Argument to unary minus must be int or float type, got ~a" (printable-type t1)) (honu:ast-stx arg))])]) - (if (<:_P tenv ret-type ctype) + (if (<:_P ret-type ctype) (values (copy-struct honu:un-op expr [honu:un-op-op-type t1] [honu:un-op-arg e1]) @@ -133,10 +124,10 @@ (case op ;; binary boolean operators [(or and) - (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-bool-type (honu:ast-stx larg)) rtype larg)] - [(e2 t2) (typecheck-expression tenv cenv lenv (make-bool-type (honu:ast-stx rarg)) rtype rarg)]) + (let-values ([(e1 t1) (typecheck-expression lenv (make-bool-type (honu:ast-stx larg)) larg)] + [(e2 t2) (typecheck-expression lenv (make-bool-type (honu:ast-stx rarg)) rarg)]) (let ([ret-type (make-bool-type stx)]) - (if (<:_P tenv ret-type ctype) + (if (<:_P ret-type ctype) (values (copy-struct honu:bin-op expr [honu:bin-op-op-type (make-bool-type (honu:ast-stx larg))] [honu:bin-op-larg e1] @@ -144,10 +135,10 @@ ret-type) (raise-honu-type-error stx ctype ret-type))))] [(clseq) - (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-any-type (honu:ast-stx larg)) rtype larg)] - [(e2 t2) (typecheck-expression tenv cenv lenv (make-any-type (honu:ast-stx rarg)) rtype rarg)]) + (let-values ([(e1 t1) (typecheck-expression lenv (make-any-type (honu:ast-stx larg)) larg)] + [(e2 t2) (typecheck-expression lenv (make-any-type (honu:ast-stx rarg)) rarg)]) (let ([ret-type (make-bool-type stx)]) - (if (<:_P tenv ret-type ctype) + (if (<:_P ret-type ctype) (values (copy-struct honu:bin-op expr [honu:bin-op-op-type (make-any-type (honu:ast-stx larg))] [honu:bin-op-larg e1] @@ -155,15 +146,15 @@ ret-type) (raise-honu-type-error stx ctype ret-type))))] [(equal neq) - (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-top-type (honu:ast-stx larg)) rtype larg)] - [(e2 t2) (typecheck-expression tenv cenv lenv (make-top-type (honu:ast-stx rarg)) rtype rarg)]) + (let-values ([(e1 t1) (typecheck-expression lenv (make-top-type (honu:ast-stx larg)) larg)] + [(e2 t2) (typecheck-expression lenv (make-top-type (honu:ast-stx rarg)) rarg)]) (let ([ret-type (make-bool-type stx)] [arg-type (cond - [(and (<:_P tenv t1 (make-any-type (honu:ast-stx larg))) - (<:_P tenv t2 (make-any-type (honu:ast-stx rarg)))) + [(and (<:_P t1 (make-any-type (honu:ast-stx larg))) + (<:_P t2 (make-any-type (honu:ast-stx rarg)))) (make-any-type (honu:ast-stx larg))] - [(check-prim-types-for-binop stx tenv t1 t2) => (lambda (t) t)])]) - (if (<:_P tenv ret-type ctype) + [(check-prim-types-for-binop stx t1 t2) => (lambda (t) t)])]) + (if (<:_P ret-type ctype) (values (copy-struct honu:bin-op expr [honu:bin-op-op-type arg-type] [honu:bin-op-larg e1] @@ -171,11 +162,11 @@ ret-type) (raise-honu-type-error stx ctype ret-type))))] [(le lt ge gt) - (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-top-type (honu:ast-stx larg)) rtype larg)] - [(e2 t2) (typecheck-expression tenv cenv lenv (make-top-type (honu:ast-stx rarg)) rtype rarg)]) + (let-values ([(e1 t1) (typecheck-expression lenv (make-top-type (honu:ast-stx larg)) larg)] + [(e2 t2) (typecheck-expression lenv (make-top-type (honu:ast-stx rarg)) rarg)]) (let ([ret-type (make-bool-type stx)] - [arg-type (check-prim-types-for-binop stx tenv t1 t2)]) - (if (<:_P tenv ret-type ctype) + [arg-type (check-prim-types-for-binop stx t1 t2)]) + (if (<:_P ret-type ctype) (values (copy-struct honu:bin-op expr [honu:bin-op-op-type arg-type] [honu:bin-op-larg e1] @@ -183,12 +174,12 @@ ret-type) (raise-honu-type-error stx ctype ret-type))))] [(plus) - (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-top-type (honu:ast-stx larg)) rtype larg)] - [(e2 t2) (typecheck-expression tenv cenv lenv (make-top-type (honu:ast-stx rarg)) rtype rarg)]) - (let ([arg-type (check-prim-types-for-binop stx tenv t1 t2)]) + (let-values ([(e1 t1) (typecheck-expression lenv (make-top-type (honu:ast-stx larg)) larg)] + [(e2 t2) (typecheck-expression lenv (make-top-type (honu:ast-stx rarg)) rarg)]) + (let ([arg-type (check-prim-types-for-binop stx t1 t2)]) (case (honu:type-prim-name arg-type) [(int float string) - (if (<:_P tenv arg-type ctype) + (if (<:_P arg-type ctype) (values (copy-struct honu:bin-op expr [honu:bin-op-op-type arg-type] [honu:bin-op-larg e1] @@ -199,12 +190,12 @@ "The plus operator requires both arguments to be of type int, type float, or type string" stx)])))] [(minus times div) - (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-top-type (honu:ast-stx larg)) rtype larg)] - [(e2 t2) (typecheck-expression tenv cenv lenv (make-top-type (honu:ast-stx rarg)) rtype rarg)]) - (let ([arg-type (check-prim-types-for-binop stx tenv t1 t2)]) + (let-values ([(e1 t1) (typecheck-expression lenv (make-top-type (honu:ast-stx larg)) larg)] + [(e2 t2) (typecheck-expression lenv (make-top-type (honu:ast-stx rarg)) rarg)]) + (let ([arg-type (check-prim-types-for-binop stx t1 t2)]) (case (honu:type-prim-name arg-type) [(int float) - (if (<:_P tenv arg-type ctype) + (if (<:_P arg-type ctype) (values (copy-struct honu:bin-op expr [honu:bin-op-op-type arg-type] [honu:bin-op-larg e1] @@ -215,10 +206,10 @@ "Arithmetic operator requires both arguments to be of type int or type float" stx)])))] [(mod) - (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-int-type (honu:ast-stx larg)) rtype larg)] - [(e2 t2) (typecheck-expression tenv cenv lenv (make-int-type (honu:ast-stx rarg)) rtype rarg)]) + (let-values ([(e1 t1) (typecheck-expression lenv (make-int-type (honu:ast-stx larg)) larg)] + [(e2 t2) (typecheck-expression lenv (make-int-type (honu:ast-stx rarg)) rarg)]) (let ([ret-type (make-int-type stx)]) - (if (<:_P tenv ret-type ctype) + (if (<:_P ret-type ctype) (values (copy-struct honu:bin-op expr [honu:bin-op-op-type (make-int-type (honu:ast-stx larg))] [honu:bin-op-larg e1] @@ -236,19 +227,20 @@ (honu:formal-type f) e)) lenv args)]) - (let-values ([(body _) (typecheck-expression tenv cenv body-lenv ret-type ret-type body)]) + (let-values ([(body _) (parameterize ([current-return-type ret-type]) + (typecheck-expression body-lenv ret-type body))]) ;; we also have the lambda's return type be what was explicitly annotated instead of what we got back (let ([lam-type (make-func-type stx (make-tuple-type stx (map honu:formal-type args)) ret-type)]) - (if (<:_P tenv lam-type ctype) + (if (<:_P lam-type ctype) (values (copy-struct honu:lambda expr [honu:lambda-body body]) lam-type) (raise-honu-type-error stx ctype lam-type)))))] [(struct honu:if (stx test then else)) (if else - (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-bool-type (honu:ast-stx test)) rtype test)] - [(e2 t2) (typecheck-expression tenv cenv lenv ctype rtype then)] - [(e3 t3) (typecheck-expression tenv cenv lenv ctype rtype else)]) + (let-values ([(e1 t1) (typecheck-expression lenv (make-bool-type (honu:ast-stx test)) test)] + [(e2 t2) (typecheck-expression lenv ctype then)] + [(e3 t3) (typecheck-expression lenv ctype else)]) ;; this should work, but I get the following: ;; -- context expected 1 value, received 2 values: # # ;; with the arrow going from values -> cond, so I'm going to rewrite as a nested-if for now. @@ -266,13 +258,13 @@ ;; [honu:if-else e3]) ;; ctype)] ;; if there was no ctype, then we require either t2 <: t3 or t3 <: t2, and we'll pick the supertype. - [(<:_P tenv t2 t3) + [(<:_P t2 t3) (values (copy-struct honu:if expr [honu:if-cond e1] [honu:if-then e2] [honu:if-else e3]) t3)] - [(<:_P tenv t3 t2) + [(<:_P t3 t2) (values (copy-struct honu:if expr [honu:if-cond e1] [honu:if-then e2] @@ -284,10 +276,10 @@ "Branches of if statement are of unrelated types" stx)])) ;; if else is #f, there was no else branch, so the then branch must be of void type. - (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-bool-type (honu:ast-stx test)) rtype test)] - [(e2 t2) (typecheck-expression tenv cenv lenv (make-void-type (honu:ast-stx then)) rtype then)]) + (let-values ([(e1 t1) (typecheck-expression lenv (make-bool-type (honu:ast-stx test)) test)] + [(e2 t2) (typecheck-expression lenv (make-void-type (honu:ast-stx then)) then)]) (let ([ret-type (make-void-type stx)]) - (if (<:_P tenv ret-type ctype) + (if (<:_P ret-type ctype) (values (copy-struct honu:if expr [honu:if-cond e1] [honu:if-then e2]) @@ -296,46 +288,48 @@ "Found if expression without else branch in non-void context" stx)))))] [(struct honu:cast (stx obj type)) - (if (not (type-valid? tenv type)) + (if (not (type-valid? type)) (raise-read-error-with-stx "Type argument of cast is not a valid type" (honu:ast-stx type))) - (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-any-type (honu:ast-stx obj)) rtype obj)]) - (if (<:_P tenv type ctype) + (let-values ([(e1 t1) (typecheck-expression lenv (make-any-type (honu:ast-stx obj)) obj)]) + (if (<:_P type ctype) (values (copy-struct honu:cast expr [honu:cast-obj e1]) type) (raise-honu-type-error stx ctype type)))] [(struct honu:isa (stx obj type)) - (if (not (type-valid? tenv type)) + (if (not (type-valid? type)) (raise-read-error-with-stx "Type argument of isa is not a valid type" (honu:ast-stx type))) - (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-any-type (honu:ast-stx obj)) rtype obj)]) + (let-values ([(e1 t1) (typecheck-expression lenv (make-any-type (honu:ast-stx obj)) obj)]) (let ([ret-type (make-bool-type stx)]) - (if (<:_P tenv ret-type ctype) + (if (<:_P ret-type ctype) (values (copy-struct honu:isa expr [honu:isa-obj e1]) ret-type) (raise-honu-type-error stx ctype ret-type))))] [(struct honu:member (stx 'my _ name _)) (cond - [(cenv name) => (lambda (t) - (if (honu:type-disp? t) - (let ([fun-type (make-func-type (honu:ast-stx t) (honu:type-disp-arg t) (honu:type-disp-ret t))]) - (if (<:_P tenv fun-type ctype) - (values (copy-struct honu:member expr - [honu:member-method? #t]) - fun-type) - (raise-honu-type-error stx ctype fun-type))) - (if (<:_P tenv t ctype) - (values expr t) - (raise-honu-type-error stx ctype t))))] + [((current-class-environment) name) + => + (lambda (t) + (if (honu:type-disp? t) + (let ([fun-type (make-func-type (honu:ast-stx t) (honu:type-disp-arg t) (honu:type-disp-ret t))]) + (if (<:_P fun-type ctype) + (values (copy-struct honu:member expr + [honu:member-method? #t]) + fun-type) + (raise-honu-type-error stx ctype fun-type))) + (if (<:_P t ctype) + (values expr t) + (raise-honu-type-error stx ctype t))))] [else (raise-read-error-with-stx (format "Static member ~a not found" (syntax-e name)) stx)])] [(struct honu:member (stx obj _ name _)) - (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-any-type (honu:ast-stx obj)) rtype obj)]) + (let-values ([(e1 t1) (typecheck-expression lenv (make-any-type (honu:ast-stx obj)) obj)]) ;; if obj was something like error or return, which do not give us a valid type for ;; getting the appropriate member... (if (honu:type-bot? t1) @@ -347,11 +341,11 @@ (raise-read-error-with-stx "Null has no fields or methods" stx)) - (let ([t (get-member-type tenv t1 name)]) + (let ([t (get-member-type t1 name)]) (cond [(honu:type-disp? t) (let ([fun-type (make-func-type (honu:ast-stx t) (honu:type-disp-arg t) (honu:type-disp-ret t))]) - (if (<:_P tenv fun-type ctype) + (if (<:_P fun-type ctype) (values (copy-struct honu:member expr [honu:member-obj e1] [honu:member-elab t1] @@ -359,7 +353,7 @@ fun-type) (raise-honu-type-error stx ctype fun-type)))] [t - (if (<:_P tenv t ctype) + (if (<:_P t ctype) (values (copy-struct honu:member expr [honu:member-obj e1] [honu:member-elab t1]) @@ -369,10 +363,10 @@ (format "Member ~a not found in type ~a" (syntax-e name) (printable-type t1)) stx)])))] [(struct honu:new (stx class type args)) - (let ([class-entry (get-class-entry tenv class)] + (let ([class-entry (get-class-entry class)] [new-type (if type type ctype)]) ;; the following can only be triggered if the type annontation isn't a type - (if (and type (not (type-valid? tenv type))) + (if (and type (not (type-valid? type))) (raise-read-error-with-stx (format "Type annotation ~a on new statement is not a valid type" (printable-type new-type)) (honu:ast-stx new-type))) @@ -381,34 +375,34 @@ (raise-read-error-with-stx "type of instantiation must be explicitly annotated" stx)) - (if (not (<:_P tenv new-type (make-any-type stx))) + (if (not (<:_P new-type (make-any-type stx))) (raise-read-error-with-stx (format "new statement appears in context of non-interface type ~a" (printable-type new-type)) stx)) ;; the class must implement a subtype of the type we're instantiating it at (if (not (ormap (lambda (t) - (<:_P tenv t new-type)) + (<:_P t new-type)) (tenv:class-impls class-entry))) (raise-read-error-with-stx (format "class ~a does not implement a subtype of type ~a" (printable-key class) (printable-type new-type)) stx)) - (let ([args (check-inits tenv stx (lambda (e t) - (typecheck-expression tenv cenv lenv t rtype e)) + (let ([args (check-inits stx (lambda (e t) + (typecheck-expression lenv t e)) (tenv:class-inits class-entry) args)]) - (if (<:_P tenv new-type ctype) + (if (<:_P new-type ctype) (values (copy-struct honu:new expr [honu:new-type new-type] [honu:new-args args]) new-type) (raise-honu-type-error stx ctype new-type))))] [(struct honu:while (stx cond body)) - (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-bool-type (honu:ast-stx cond)) rtype cond)] - [(e2 t2) (typecheck-expression tenv cenv lenv (make-void-type (honu:ast-stx body)) rtype body)]) + (let-values ([(e1 t1) (typecheck-expression lenv (make-bool-type (honu:ast-stx cond)) cond)] + [(e2 t2) (typecheck-expression lenv (make-void-type (honu:ast-stx body)) body)]) (let ([ret-type (make-void-type stx)]) - (if (<:_P tenv ret-type ctype) + (if (<:_P ret-type ctype) (values (copy-struct honu:while expr [honu:while-cond e1] [honu:while-body e2]) @@ -417,9 +411,9 @@ [(struct honu:cond (stx clauses else)) (if else (let-values ([(clauses types) (map-two-values (lambda (c) - (typecheck-cond-clause tenv cenv lenv ctype rtype c)) + (typecheck-cond-clause lenv ctype c)) clauses)] - [(else etype) (typecheck-expression tenv cenv lenv ctype rtype else)]) + [(else etype) (typecheck-expression lenv ctype else)]) (cond ;; if ctype exists, just use it ;; @@ -429,7 +423,7 @@ ;; [honu:cond-clauses clauses]) ;; ctype)] ;; otherwise find the most super type of all the branches - [(pick-super-type-from-list tenv (cons etype types)) + [(pick-super-type-from-list (cons etype types)) => (lambda (t) (values (copy-struct honu:cond expr @@ -443,11 +437,11 @@ stx)])) ;; if else is #f, there was no else branch, so the cond clauses must be of void type. (let-values ([(clauses types) (map-two-values (lambda (c) - (typecheck-cond-clause tenv cenv lenv - (make-void-type (honu:ast-stx c)) rtype c)) + (typecheck-cond-clause lenv + (make-void-type (honu:ast-stx c)) c)) clauses)]) (let ([ret-type (make-void-type stx)]) - (if (<:_P tenv ret-type ctype) + (if (<:_P ret-type ctype) (values (copy-struct honu:cond expr [honu:cond-clauses clauses]) ret-type) @@ -458,9 +452,9 @@ ;; returns don't return to their context, but to the context of the method or function call in which ;; they were invoked. Because of this a) rtype must not be #f (else we're not in a method or function ;; body) and b) the type of a return statement is the bottom type (same as error). - (if rtype + (if (current-return-type) ;; we use rtype as the context type here, since that's the type that needs to be returned. - (let-values ([(e1 _) (typecheck-expression tenv cenv lenv rtype rtype body)]) + (let-values ([(e1 _) (typecheck-expression lenv (current-return-type) body)]) ;; we don't need to check (bottom-type) <:_P ctype, because that's vacuously true. (values (copy-struct honu:return expr [honu:return-body e1]) @@ -480,7 +474,7 @@ (length (honu:type-tuple-args ctype))) stx)) (let-values ([(vals types) (map-two-values (lambda (e t) - (typecheck-expression tenv cenv lenv t rtype e)) + (typecheck-expression lenv t e)) vals (honu:type-tuple-args ctype))]) (values (copy-struct honu:tuple expr [honu:tuple-vals vals]) @@ -494,7 +488,7 @@ (length vals)) stx)) (let-values ([(vals types) (map-two-values (lambda (e t) - (typecheck-expression tenv cenv lenv t rtype e)) + (typecheck-expression lenv t e)) vals (gen-top-except-for (length vals) (honu:type-select-slot ctype) (honu:type-select-type ctype)))]) @@ -506,8 +500,8 @@ ;; we have no knowledge about what's wanted, we just check each component with ctype. [(honu:type-top? ctype) (let-values ([(vals types) (map-two-values (lambda (e) - (typecheck-expression tenv cenv lenv - (make-top-type (honu:ast-stx e)) rtype e)) + (typecheck-expression lenv + (make-top-type (honu:ast-stx e)) e)) vals)]) (values (copy-struct honu:tuple expr [honu:tuple-vals vals]) @@ -517,19 +511,19 @@ stx)])] [(struct honu:let (_ bindings body)) (let*-values ([(bindings lenv) (map-and-fold (lambda (bind lenv) - (typecheck-binding tenv cenv lenv rtype bind)) + (typecheck-binding lenv bind)) lenv bindings)] - [(e1 t1) (typecheck-expression tenv cenv lenv ctype rtype body)]) + [(e1 t1) (typecheck-expression lenv ctype body)]) (values (copy-struct honu:let expr [honu:let-bindings bindings] [honu:let-body e1]) t1))] [(struct honu:seq (_ effects value)) (let-values ([(effects _) (map-two-values (lambda (e) - (typecheck-expression tenv cenv lenv (make-void-type (honu:ast-stx e)) rtype e)) + (typecheck-expression lenv (make-void-type (honu:ast-stx e)) e)) effects)] - [(e1 t1) (typecheck-expression tenv cenv lenv ctype rtype value)]) + [(e1 t1) (typecheck-expression lenv ctype value)]) (values (copy-struct honu:seq expr [honu:seq-effects effects] [honu:seq-value e1]) @@ -538,18 +532,18 @@ ;; bindings have no ctype because they're always in the void type context ;; they return the elaborated binding and a new environment extended with the ;; type of the bound variable. - (define (typecheck-binding tenv cenv lenv rtype binding) + (define (typecheck-binding lenv binding) (match binding [(struct honu:binding (stx names types value)) (for-each (lambda (n t) (if (and (not (and (not n) (honu:type-top? t))) - (not (type-valid? tenv t))) + (not (type-valid? t))) (raise-read-error-with-stx "Type of locally bound variable is undefined" (honu:ast-stx t)))) names types) - (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-tuple-type (honu:ast-stx value) types) rtype value)]) + (let-values ([(e1 t1) (typecheck-expression lenv (make-tuple-type (honu:ast-stx value) types) value)]) (values (copy-struct honu:binding binding [honu:binding-value e1]) (fold (lambda (name type lenv) @@ -558,17 +552,17 @@ lenv)) lenv names types)))])) - (define (typecheck-cond-clause tenv cenv lenv ctype rtype clause) + (define (typecheck-cond-clause lenv ctype clause) (match clause [(struct honu:cond-clause (stx pred rhs)) - (let-values ([(e1 t1) (typecheck-expression tenv cenv lenv (make-bool-type (honu:ast-stx pred)) rtype pred)] - [(e2 t2) (typecheck-expression tenv cenv lenv ctype rtype rhs)]) + (let-values ([(e1 t1) (typecheck-expression lenv (make-bool-type (honu:ast-stx pred)) pred)] + [(e2 t2) (typecheck-expression lenv ctype rhs)]) (values (copy-struct honu:cond-clause clause [honu:cond-clause-pred e1] [honu:cond-clause-rhs e2]) t2))])) - (define (check-prim-types-for-binop stx tenv t1 t2) + (define (check-prim-types-for-binop stx t1 t2) (cond [(and (honu:type-bot? t1) (honu:type-prim? t2)) @@ -578,7 +572,7 @@ t1] [(and (honu:type-prim? t1) (honu:type-prim? t2) - (type-equal? tenv t1 t2)) + (type-equal? t1 t2)) t1] [else (raise-read-error-with-stx @@ -587,7 +581,7 @@ (printable-type t2)) stx)])) - (define (check-inits tenv stx type-fun inits new-args) + (define (check-inits stx type-fun inits new-args) (let-values ([(new-args remaining-inits) (map-and-fold (lambda (arg inits) (let*-values ([(init remaining-inits) @@ -625,19 +619,19 @@ ;; assumes a non-empty list - (define (pick-super-type-from-list tenv ts) + (define (pick-super-type-from-list ts) (define (pick-super-type-with-acc ts t) (cond ;; t is a super-type of all the other branches [(andmap (lambda (t2) - (<:_P tenv t2 t)) + (<:_P t2 t)) ts) t] ;; if there's a type t2 in ts that is not equal to t ;; but t <:_P t2, then recur with t2 instead. [(find (lambda (t2) - (and (not (type-equal? tenv t t2)) - (<:_P tenv t t2))) + (and (not (type-equal? t t2)) + (<:_P t t2))) ts) => (lambda (t) diff --git a/collects/honu/private/typechecker/typecheck-parameters.ss b/collects/honu/private/typechecker/typecheck-parameters.ss new file mode 100644 index 0000000000..1dfabc88d4 --- /dev/null +++ b/collects/honu/private/typechecker/typecheck-parameters.ss @@ -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.) + + (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)) + + ) \ No newline at end of file diff --git a/collects/honu/private/typechecker/typechecker.ss b/collects/honu/private/typechecker/typechecker.ss index 7e175c49ec..096472e7c4 100644 --- a/collects/honu/private/typechecker/typechecker.ss +++ b/collects/honu/private/typechecker/typechecker.ss @@ -10,21 +10,16 @@ "../../utils.ss" "typecheck-class-utils.ss" "typecheck-expression.ss" + "typecheck-parameters.ss" "type-utils.ss") - (provide/contract [typecheck (tenv? - tenv? - (listof honu:defn?) + (provide/contract [typecheck ((listof honu:defn?) . -> . (listof honu:defn?))] - [typecheck-defn (tenv? - tenv? - honu:defn? + [typecheck-defn (honu:defn? . -> . honu:defn?)]) - ;; since lenv is a hashtable and thus will be mutated, we don't need to return it from - ;; typecheck or typecheck-defn. - (define (typecheck tenv lenv defns) + (define (typecheck defns) (let loop ([defns defns] [results '()]) (cond @@ -33,19 +28,19 @@ ;; (i.e. if they are no intervening non-function definitions) [(honu:function? (car defns)) (let-values ([(funcs remaining) (span honu:function? defns)]) - (loop remaining (append (typecheck-functions tenv lenv funcs) results)))] - [else (loop (cdr defns) (cons (typecheck-defn tenv lenv (car defns)) results))]))) + (loop remaining (append (typecheck-functions funcs) results)))] + [else (loop (cdr defns) (cons (typecheck-defn (car defns)) results))]))) - (define (typecheck-functions tenv lenv funcs) + (define (typecheck-functions funcs) (define (check-function-type func) (match func [(struct honu:function (stx name type args body)) - (if (not (type-valid? tenv type)) + (if (not (type-valid? type)) (raise-read-error-with-stx "Return type of function is undefined" (honu:ast-stx type))) (for-each (lambda (t) - (if (not (type-valid? tenv t)) + (if (not (type-valid? t)) (raise-read-error-with-stx "Type of function argument is undefined" (honu:ast-stx type)))) @@ -54,9 +49,8 @@ ;; first we add the functions to the lexical environment so that when we typecheck ;; the bodies, they'll be in scope. (for-each (lambda (f) - (extend-tenv (honu:function-name f) - (make-tenv:value (honu:ast-stx f) (check-function-type f)) - lenv)) + (extend-lenv (honu:function-name f) + (make-tenv:value (honu:ast-stx f) (check-function-type f)))) funcs) (let loop ([funcs funcs] [new-funcs '()]) @@ -66,61 +60,60 @@ new-funcs (match (car funcs) [(struct honu:function (stx name type args body)) - (let-values ([(e1 t1) (typecheck-expression tenv (lambda (name) #f) - (fold (lambda (a e) - (extend-fenv (honu:formal-name a) - (honu:formal-type a) - e)) - (wrap-as-function lenv) - args) - type type body)]) + (let-values ([(e1 t1) (parameterize ([current-return-type type]) + (typecheck-expression (fold (lambda (a e) + (extend-fenv (honu:formal-name a) + (honu:formal-type a) + e)) + (wrap-lenv) + args) + type body))]) (loop (cdr funcs) (cons (copy-struct honu:function (car funcs) [honu:function-body e1]) new-funcs)))])))) - (define (typecheck-defn tenv lenv defn) + (define (typecheck-defn defn) (match defn [(struct honu:bind-top (stx names types value)) (for-each (lambda (n t) (if (and (not (and (not n) (honu:type-top? t))) - (not (type-valid? tenv t))) + (not (type-valid? t))) (raise-read-error-with-stx "Type of top-level bound variable is undefined" (honu:ast-stx t)))) names types) - (let-values ([(e1 t1) (typecheck-expression tenv (lambda (name) #f) (wrap-as-function lenv) - (make-tuple-type stx types) #f value)]) + (let-values ([(e1 t1) (typecheck-expression (wrap-lenv) (make-tuple-type stx types) value)]) (for-each (lambda (n t) - (if n (extend-tenv n (make-tenv:value stx t) lenv))) + (if n (extend-lenv n (make-tenv:value stx t)))) names types) (copy-struct honu:bind-top defn [honu:bind-top-value e1]))] [(struct honu:iface (stx name supers members)) (for-each (lambda (t) - (if (not (type-valid? tenv t)) + (if (not (type-valid? t)) (raise-read-error-with-stx "No definition for supertype" (honu:ast-stx t)))) supers) (for-each (lambda (m) - (typecheck-member-decl tenv m)) + (typecheck-member-decl m)) members) defn] [(struct honu:class (stx name type final? impls inits members exports)) - (if (not (type-valid? tenv type)) + (if (not (type-valid? type)) (raise-read-error-with-stx "Self-type of class is undefined" (honu:ast-stx type))) (for-each (lambda (t) - (if (not (type-valid? tenv t)) + (if (not (type-valid? t)) (raise-read-error-with-stx "Implemented type is undefined" (honu:ast-stx type)))) impls) (for-each (lambda (t) - (if (not (type-valid? tenv t)) + (if (not (type-valid? t)) (raise-read-error-with-stx "Type of init slot is undefined" (honu:ast-stx type)))) @@ -131,34 +124,35 @@ e)) (lambda (n) #f) inits)]) - (let-values ([(members cenv) (typecheck-members tenv cenv (wrap-as-function lenv) type members)]) - (typecheck-exports tenv cenv type impls exports) + (let*-values ([(lenv) (extend-fenv #'this type (wrap-lenv))] + [(members cenv) (typecheck-members cenv lenv type members)]) + (typecheck-exports cenv type impls exports) (copy-struct honu:class defn [honu:class-members members])))] [(struct honu:mixin (stx name type arg-type final? impls inits withs supernew members-before members-after exports)) - (if (not (type-valid? tenv arg-type)) + (if (not (type-valid? arg-type)) (raise-read-error-with-stx "Argument type of mixin is undefined" (honu:ast-stx arg-type))) - (if (not (type-valid? tenv type)) + (if (not (type-valid? type)) (raise-read-error-with-stx "Result type of mixin is undefined" (honu:ast-stx type))) (for-each (lambda (t) - (if (not (type-valid? tenv t)) + (if (not (type-valid? t)) (raise-read-error-with-stx "Implemented type is undefined" (honu:ast-stx type)))) impls) (for-each (lambda (t) - (if (not (type-valid? tenv t)) + (if (not (type-valid? t)) (raise-read-error-with-stx "Type of init slot is undefined" (honu:ast-stx type)))) (map honu:formal-type inits)) (for-each (lambda (t) - (if (not (type-valid? tenv t)) + (if (not (type-valid? t)) (raise-read-error-with-stx "Type of expected init slot is undefined" (honu:ast-stx type)))) @@ -169,11 +163,12 @@ e)) (lambda (n) #f) inits)]) - (let*-values ([(members-before cenv) (typecheck-members tenv cenv (wrap-as-function lenv) type members-before)] - [(supernew) (typecheck-supernew tenv cenv (wrap-as-function lenv) withs supernew)] - [(cenv) (extend-cenv-with-type-members tenv cenv arg-type)] - [(members-after cenv) (typecheck-members tenv cenv (wrap-as-function lenv) type members-after)]) - (typecheck-exports tenv cenv type impls exports) + (let*-values ([(lenv) (extend-fenv #'this type (wrap-lenv))] + [(members-before cenv) (typecheck-members cenv lenv type members-before)] + [(supernew) (typecheck-supernew cenv lenv withs supernew)] + [(cenv) (extend-cenv-with-type-members cenv arg-type)] + [(members-after cenv) (typecheck-members cenv lenv type members-after)]) + (typecheck-exports cenv type impls exports) (copy-struct honu:mixin defn [honu:mixin-members-before members-before] [honu:mixin-super-new supernew] @@ -186,20 +181,20 @@ "Haven't typechecked that type of definition yet." (honu:ast-stx defn))])) - (define (typecheck-member-decl tenv member) + (define (typecheck-member-decl member) (match member [(struct honu:field-decl (stx name type)) - (if (not (type-valid? tenv type)) + (if (not (type-valid? type)) (raise-read-error-with-stx "Type of field is undefined" stx))] [(struct honu:method-decl (stx name type args)) - (if (not (type-valid? tenv type)) + (if (not (type-valid? type)) (raise-read-error-with-stx "Return type of method is undefined" (honu:ast-stx type))) (for-each (lambda (t) - (if (not (type-valid? tenv t)) + (if (not (type-valid? t)) (raise-read-error-with-stx "Type of method argument is undefined" (honu:ast-stx type)))) diff --git a/collects/honu/tenv-utils.ss b/collects/honu/tenv-utils.ss index f2cab373c2..cec2d0de4e 100644 --- a/collects/honu/tenv-utils.ss +++ b/collects/honu/tenv-utils.ss @@ -2,6 +2,7 @@ (require "readerr.ss" "ast.ss" + "parameters.ss" "tenv.ss" "private/typechecker/type-utils.ss" (lib "plt-match.ss") @@ -96,7 +97,7 @@ class-name))))) (provide add-defns-to-tenv add-defn-to-tenv) - (define (add-defns-to-tenv defns tenv) + (define (add-defns-to-tenv defns) (let loop ([defns defns] [skipped '()] [changed? #f] @@ -125,10 +126,10 @@ ;; if we went through all the supers with them being defined, ;; then we can add this type as well. [(null? supers) - (loop (cdr defns) skipped #t (cons (add-defn-to-tenv (car defns) tenv) new-defns))] + (loop (cdr defns) skipped #t (cons (add-defn-to-tenv (car defns)) new-defns))] ;; if there is an entry, we check to make sure it's a type, and ;; if it is, then we continue looping in the inner loop - [(get-tenv-entry tenv (car supers)) + [(get-tenv-entry (car supers)) => (lambda (e) (if (not (tenv:type? e)) @@ -144,7 +145,7 @@ ;; their entries, so we just run them through as we hit them. [(or (honu:class? (car defns)) (honu:mixin? (car defns))) - (loop (cdr defns) skipped #t (cons (add-defn-to-tenv (car defns) tenv) new-defns))] + (loop (cdr defns) skipped #t (cons (add-defn-to-tenv (car defns)) new-defns))] ;; for structs, we will get back a list of two things: the new type ;; and the new class definition, so append those onto new-defns [(honu:struct? (car defns)) @@ -154,19 +155,19 @@ (make-struct-type-decls inits members))] [new-class (make-honu:class stx name type final? (cons type impls) inits members (cons (make-struct-export type inits members (list)) exports))]) - (loop (cdr defns) skipped #t (cons (add-defn-to-tenv new-class tenv) - (cons (add-defn-to-tenv new-iface tenv) new-defns))))])] + (loop (cdr defns) skipped #t (cons (add-defn-to-tenv new-class) + (cons (add-defn-to-tenv new-iface) new-defns))))])] ;; for subclasses, we check to make sure the base (and its self-type) and ;; the mixin (and its arg-type) are in the tenv. If not, skip it. ;; Give appropriate errors for each thing that can go wrong. [(honu:subclass? (car defns)) - (let* ([base (get-tenv-entry tenv (honu:subclass-base (car defns)))] + (let* ([base (get-tenv-entry (honu:subclass-base (car defns)))] [selftype (if (and base (tenv:class? base)) - (get-tenv-entry tenv (honu:type-iface-name (tenv:class-sub-type base))) + (get-tenv-entry (honu:type-iface-name (tenv:class-sub-type base))) #f)] - [mixin (get-tenv-entry tenv (honu:subclass-mixin (car defns)))] + [mixin (get-tenv-entry (honu:subclass-mixin (car defns)))] [argtype (if (and mixin (tenv:mixin? mixin)) - (get-tenv-entry tenv (honu:type-iface-name (tenv:mixin-arg-type mixin))) + (get-tenv-entry (honu:type-iface-name (tenv:mixin-arg-type mixin))) #f)]) (cond [(and base (not (tenv:class? base))) @@ -194,7 +195,7 @@ base)) ;; if the base's selftype does not match the mixin's argtype, ;; we cannot apply the mixin to the base. - (if (not (<:_P tenv (tenv:class-sub-type base) (tenv:mixin-arg-type mixin))) + (if (not (<:_P (tenv:class-sub-type base) (tenv:mixin-arg-type mixin))) (raise-read-error-with-stx (format "Class ~a (~a) is not of an appropriate type (~a) for mixin ~a" (printable-key (honu:subclass-base (car defns))) @@ -202,7 +203,7 @@ (printable-type (tenv:mixin-arg-type mixin)) (printable-key (honu:subclass-mixin (car defns)))) (honu:subclass-base (car defns)))) - (loop (cdr defns) skipped #t (cons (add-defn-to-tenv (car defns) tenv) new-defns))] + (loop (cdr defns) skipped #t (cons (add-defn-to-tenv (car defns)) new-defns))] ;; if we get here, we cannot yet make the entry for this subclass, ;; so skip it. [else @@ -214,7 +215,7 @@ (match (car defns) [(struct honu:substruct (stx name type base arg-type final? impls inits withs super-new members-before members-after exports)) - (let ([argtype (get-tenv-entry tenv (honu:type-iface-name arg-type))]) + (let ([argtype (get-tenv-entry (honu:type-iface-name arg-type))]) (cond [(and argtype (not (tenv:type? argtype))) (raise-read-error-with-stx @@ -235,13 +236,13 @@ (tenv:type-members argtype)) exports))] [new-sclass (make-honu:subclass stx name base mixin-name)]) - (loop (cons new-sclass (cdr defns)) skipped #t (cons (add-defn-to-tenv new-mixin tenv) - (cons (add-defn-to-tenv new-iface tenv) new-defns))))] + (loop (cons new-sclass (cdr defns)) skipped #t (cons (add-defn-to-tenv new-mixin) + (cons (add-defn-to-tenv new-iface) new-defns))))] [else (loop (cdr defns) (cons (car defns) skipped) changed? new-defns)]))])]))) - (define (check-super-for-members tenv name members super-name) - (match (get-tenv-entry tenv super-name) + (define (check-super-for-members name members super-name) + (match (get-tenv-entry super-name) [(struct tenv:type (_ _ super-members super-inherited)) ;; here we make sure to use both defined members and inherited members (let loop ([super-members (append super-members super-inherited)] @@ -261,7 +262,7 @@ ;; if we eventually allow co-/contra-variance here, this is where ;; we'd do it. (if (honu:type-disp? (tenv:member-type (car super-members))) - (if (<:_P tenv (tenv:member-type m) (tenv:member-type (car super-members))) + (if (<:_P (tenv:member-type m) (tenv:member-type (car super-members))) (loop (cdr super-members) inherited) (raise-read-error-with-stx (format "Type ~a defines member ~a with type ~a, is not a subtype of type ~a as defined in supertype ~a" @@ -272,7 +273,7 @@ (printable-key super-name)) (tenv:member-stx m))) ;; this handles mutable fields -- we don't have immutable fields yet - (if (type-equal? tenv (tenv:member-type m) (tenv:member-type (car super-members))) + (if (type-equal? (tenv:member-type m) (tenv:member-type (car super-members))) (loop (cdr super-members) inherited) (raise-read-error-with-stx (format "Type ~a defines member ~a with type ~a, was defined with type ~a in supertype ~a" @@ -297,7 +298,7 @@ (honu:type-disp-ret member-type))]) member))) - (define (type-equal-modulo-disp? tenv t1 t2) + (define (type-equal-modulo-disp? t1 t2) (let ([t1 (if (honu:type-disp? t1) (make-func-type (honu:ast-stx t1) (honu:type-disp-arg t1) @@ -308,9 +309,9 @@ (honu:type-disp-arg t2) (honu:type-disp-ret t2)) t2)]) - (type-equal? tenv t1 t2))) + (type-equal? t1 t2))) - (define (check-and-remove-duplicate-members tenv subtype inherited-members) + (define (check-and-remove-duplicate-members subtype inherited-members) (let loop ([inherited-members inherited-members] [unique-members '()]) (if (null? inherited-members) @@ -331,8 +332,7 @@ ;; (modulo the dispatch arguments of methods) ;; ;; doesn't matter which we keep, so we'll just keep the first one that matched. - [(type-equal-modulo-disp? tenv - (tenv:member-type current-member) + [(type-equal-modulo-disp? (tenv:member-type current-member) (tenv:member-type (cdr (car matching-members)))) (loop2 (cdr matching-members))] [else @@ -346,7 +346,7 @@ (printable-type (tenv:member-type (cdr (car matching-members))))) subtype)]))))))) - (define (add-defn-to-tenv defn tenv) + (define (add-defn-to-tenv defn) (match defn ;; for types, we need to recur over our supertypes, make sure that we don't have any definitions that countermand ;; those in our super classes (which will also make sure that our superclass definitions are consistent), and @@ -358,25 +358,23 @@ ;; we have to do this because members of the type can refer to the type itself. ;; this is only for <:_P checks. (extend-tenv name - (make-tenv:type src-stx supers '() '()) - tenv) + (make-tenv:type src-stx supers '() '())) (let* ([tenv-members (convert-members (make-iface-type name name) members)] [inherited-decls - (apply append (map (lambda (n) (check-super-for-members tenv name tenv-members n)) + (apply append (map (lambda (n) (check-super-for-members name tenv-members n)) (map honu:type-iface-name supers)))] [unique-inherited ;; remove duplicate entries for the same member name, making sure they match. - (check-and-remove-duplicate-members tenv name inherited-decls)]) + (check-and-remove-duplicate-members name inherited-decls)]) (extend-tenv-without-checking name - (make-tenv:type src-stx supers tenv-members unique-inherited) - tenv) + (make-tenv:type src-stx supers tenv-members unique-inherited)) defn)] ;; for classes and mixins, just add a new appropriate entry. [(struct honu:class (src-stx name t f? impls inits defns _)) (extend-tenv name (make-tenv:class src-stx t impls (get-inits inits defns) - f? #f) tenv) + f? #f)) defn] [(struct honu:mixin (src-stx name type arg-type final? impls inits withs _ defns-before defns-after _)) @@ -384,13 +382,13 @@ (get-inits inits (append defns-before defns-after)) - withs final?) tenv) + withs final?)) defn] ;; all the heavy lifting of subclasses is in generate-subclass-tenv, ;; which does things like make sure that the withs of the mixin are satisfied ;; by the base, collects all the inits needed for the resulting class, etc. [(struct honu:subclass (src-stx name base mixin)) - (extend-tenv name (generate-subclass-tenv defn tenv) tenv) + (extend-tenv name (generate-subclass-tenv defn)) defn])) (define (convert-members iface members) @@ -429,10 +427,10 @@ #t))) init-fields)))) - (define (generate-subclass-tenv defn tenv) - (let ([base (get-class-entry tenv (honu:subclass-base defn))] - [mixin (get-mixin-entry tenv (honu:subclass-mixin defn))]) - (let ([new-inits (remove-used-inits tenv defn + (define (generate-subclass-tenv defn) + (let ([base (get-class-entry (honu:subclass-base defn))] + [mixin (get-mixin-entry (honu:subclass-mixin defn))]) + (let ([new-inits (remove-used-inits defn (tenv:class-inits base) (tenv:mixin-withs mixin))]) (make-tenv:class (honu:ast-stx defn) @@ -443,7 +441,7 @@ (tenv:mixin-final? mixin) (honu:subclass-base defn))))) - (define (remove-used-inits tenv defn old-inits withs) + (define (remove-used-inits defn old-inits withs) (let loop ([old-inits old-inits] [withs withs] [new-inits '()]) @@ -460,7 +458,7 @@ (tenv-key=? (honu:formal-name w) (tenv:init-name curr))) withs)]) (if index - (if (<:_P tenv (honu:formal-type (list-ref withs index)) (tenv:init-type curr)) + (if (<:_P (honu:formal-type (list-ref withs index)) (tenv:init-type curr)) (loop (cdr old-inits) (append (take withs index) (drop withs (+ index 1))) @@ -474,7 +472,9 @@ withs (cons curr new-inits))))))) - (provide display-lenv display-tenv) + (provide display-lenv display-current-lenv display-tenv display-current-tenv) + (define (display-current-lenv) + (display-lenv (current-lexical-environment))) (define (display-lenv lenv) (tenv-for-each lenv (lambda (k v) @@ -482,6 +482,8 @@ (printable-key k) (printable-type (tenv:value-type v))))))) + (define (display-current-tenv) + (display-lenv (current-type-environment))) (define (display-tenv tenv) (tenv-for-each tenv (lambda (k v) diff --git a/collects/honu/tenv.ss b/collects/honu/tenv.ss index 3887e6273e..b26341d9f9 100644 --- a/collects/honu/tenv.ss +++ b/collects/honu/tenv.ss @@ -4,6 +4,7 @@ (lib "boundmap.ss" "syntax") (lib "contract.ss") "ast.ss" + "parameters.ss" "readerr.ss") (provide (struct tenv:entry (stx)) @@ -99,22 +100,24 @@ (provide/contract [empty-tenv (-> tenv?)] [get-builtin-lenv (-> tenv?)] - [extend-tenv (identifier? tenv:entry? tenv? . -> . void?)] - [extend-tenv-without-checking (identifier? tenv:entry? tenv? . -> . void?)] - [create-tenv ((listof identifier?) - (listof tenv:entry?) - . -> . - tenv?)]) + [extend-tenv (identifier? tenv:entry? . -> . void?)] + [extend-lenv (identifier? tenv:value? . -> . void?)] + [extend-tenv-without-checking (identifier? tenv:entry? . -> . void?)]) + (define (empty-tenv) (make-bound-identifier-mapping)) (define (get-builtin-lenv) - (let ([tenv (empty-tenv)]) - (for-each (lambda (n t) - (extend-tenv n (make-tenv:value #f t) tenv)) - (map car builtin-list) - (map cdr builtin-list)) - tenv)) - (define (extend-tenv key val tenv) - (if (get-tenv-entry tenv key) + (create-tenv (map car builtin-list) + (map (lambda (p) + (make-tenv:value (car p) (cdr p))) builtin-list))) + (define (extend-tenv key val) + (extend-tenv/checks key val (current-type-environment))) + (define (extend-lenv key val) + (extend-tenv/checks key val (current-lexical-environment))) + (define (extend-tenv-without-checking key val) + (extend-tenv/no-checks key val (current-type-environment))) + + (define (extend-tenv/checks key val tenv) + (if (bound-identifier-mapping-get tenv key (lambda () #f)) (if (eqv? (string-ref (symbol->string (printable-key key)) 0) #\$) (raise-read-error-with-stx (format "~a already bound by a subclass or substruct" @@ -124,33 +127,36 @@ (format "~a already bound by top-level definition" (printable-key key)) key)) (bound-identifier-mapping-put! tenv key val))) - (define (extend-tenv-without-checking key val tenv) + (define (extend-tenv/no-checks key val tenv) (bound-identifier-mapping-put! tenv key val)) (define (create-tenv keys vals) (let ((table (empty-tenv))) - (begin (for-each extend-tenv table keys vals) + (begin (for-each (lambda (k v) + (extend-tenv/checks k v table)) + keys vals) table))) ;; only use this if you a) don't want an error or b) don't know what you should get. - (provide/contract [get-tenv-entry (tenv? identifier? . -> . (union tenv:entry? false/c))]) - (define (get-tenv-entry tenv key) - (bound-identifier-mapping-get tenv key (lambda () #f))) + (provide/contract [get-tenv-entry (identifier? . -> . (union tenv:entry? false/c))] + [get-lenv-entry (identifier? . -> . (union tenv:entry? false/c))]) + (define (get-tenv-entry key) + (bound-identifier-mapping-get (current-type-environment) key (lambda () #f))) + (define (get-lenv-entry key) + (bound-identifier-mapping-get (current-lexical-environment) key (lambda () #f))) - (provide/contract [get-type-entry (tenv? - (union honu:type-iface? + (provide/contract [get-type-entry ((union honu:type-iface? honu:type-iface-top?) . -> . tenv:type?)] - [get-class-entry (tenv? identifier? . -> . tenv:class?)] - [get-mixin-entry (tenv? identifier? . -> . tenv:mixin?)] - [get-member-type (tenv? - (union honu:type-iface? + [get-class-entry (identifier? . -> . tenv:class?)] + [get-mixin-entry (identifier? . -> . tenv:mixin?)] + [get-member-type ((union honu:type-iface? honu:type-iface-top?) identifier? . -> . honu:type?)] - [get-value-entry (tenv? identifier? . -> . tenv:value?)]) - (define (get-type-entry tenv type) + [get-value-entry (identifier? . -> . tenv:value?)]) + (define (get-type-entry type) (if (honu:type-iface-top? type) (make-tenv:type #f (list) (list) (list)) (let* ([name (honu:type-iface-name type)] - [entry (get-tenv-entry tenv name)]) + [entry (get-tenv-entry name)]) (cond [(not entry) (raise-read-error-with-stx @@ -161,8 +167,8 @@ (format "Definition of ~a is not a type" (printable-key name)) name)] [else entry])))) - (define (get-class-entry tenv name) - (let ([entry (get-tenv-entry tenv name)]) + (define (get-class-entry name) + (let ([entry (get-tenv-entry name)]) (cond [(not entry) (raise-read-error-with-stx @@ -173,8 +179,8 @@ (format "Definition of ~a is not a class" (printable-key name)) name)] [else entry]))) - (define (get-mixin-entry tenv name) - (let ([entry (get-tenv-entry tenv name)]) + (define (get-mixin-entry name) + (let ([entry (get-tenv-entry name)]) (cond [(not entry) (raise-read-error-with-stx @@ -185,8 +191,8 @@ (format "Definition of ~a is not a mixin" (printable-key name)) name)] [else entry]))) - (define (get-member-type tenv type name) - (let* ([entry (get-type-entry tenv type)] + (define (get-member-type type name) + (let* ([entry (get-type-entry type)] [mtype (find (lambda (m) (tenv-key=? (tenv:member-name m) name)) (append (tenv:type-members entry) @@ -200,8 +206,8 @@ 'Any (printable-key (honu:type-iface-name type)))) name)))) - (define (get-value-entry tenv name) - (let ([entry (get-tenv-entry tenv name)]) + (define (get-value-entry name) + (let ([entry (get-lenv-entry name)]) (cond [(not entry) (raise-read-error-with-stx @@ -213,8 +219,9 @@ name)] [else entry]))) - (provide wrap-as-function extend-fenv) + (provide wrap-lenv extend-fenv) + (define (wrap-lenv) (wrap-as-function (current-lexical-environment))) (define (wrap-as-function tenv) (lambda (name) (let ([entry (bound-identifier-mapping-get tenv name (lambda () #f))])