diff --git a/collects/honu/base.ss b/collects/honu/base.ss index 10883e9929..8868c777fa 100644 --- a/collects/honu/base.ss +++ b/collects/honu/base.ss @@ -9,6 +9,13 @@ (error "Attempt to access member of null") (send obj msg arg ...))])) + ;; We just use this so that Check Syntax correctly matches up + ;; types that don't appear otherwise. Yes, this is a hack. + ;; For obvious reasons, this can't just be a macro that ignores + ;; its arguments, but must instead be a _function_ that ignores them. + (define (honu:type . types) + (void)) + (define null% (class object% (inspect #f) diff --git a/collects/honu/private/compiler/translate-class-utils.ss b/collects/honu/private/compiler/translate-class-utils.ss index 21a43e6999..100566e254 100644 --- a/collects/honu/private/compiler/translate-class-utils.ss +++ b/collects/honu/private/compiler/translate-class-utils.ss @@ -99,9 +99,10 @@ (define (translate-export in-super? export) (cons 'begin - (map (lambda (b) - (translate-exp-bind in-super? (comp:export-type export) b)) - (comp:export-binds export)))) + (cons `(honu:type ,(translate-type-for-syntax (comp:export-type export))) + (map (lambda (b) + (translate-exp-bind in-super? (comp:export-type export) b)) + (comp:export-binds export))))) (define (translate-exp-bind in-super? type binding) (let ([right-defn (if in-super? 'define/override 'define/public)]) @@ -125,27 +126,34 @@ (honu:super-new-args super-new))))) (define (translate-inits inits) - (cons 'init (map (lambda (i) - (at-ctxt (honu:formal-name i))) - inits))) + `(begin + (honu:type ,@(map (lambda (i) (translate-type-for-syntax (honu:formal-type i))) inits)) + ,(cons 'init (map (lambda (i) + (at-ctxt (honu:formal-name i))) + inits)))) (define (mangle-init-name name) (at name (string->symbol (string-append "init-" (symbol->string (syntax-e name)))))) (define (translate-member member) (match member - [(struct honu:init-field (stx name _ value)) + [(struct honu:init-field (stx name type value)) (if value - `(begin (init ([,(mangle-init-name name) ,(at-ctxt name)] - ,(translate-expression 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 value))] - [(struct honu:method (stx name _ formals body)) - (translate-function stx name formals - (translate-expression body))])) + (at stx`(begin (honu:type ,(translate-type-for-syntax type)) + (init ([,(mangle-init-name name) ,(at-ctxt name)] + ,(translate-expression value))) + (define ,(at-ctxt name) ,(mangle-init-name)))) + (at stx `(begin (honu:type ,(translate-type-for-syntax type)) + (init ([,(mangle-init-name name) ,(at-ctxt name)])) + (define ,(at-ctxt name) ,(mangle-init-name name)))))] + [(struct honu:field (stx name type value)) + (at stx `(begin (honu:type ,(translate-type-for-syntax type)) + (define ,(at-ctxt name) ,(translate-expression value))))] + [(struct honu:method (stx name type formals body)) + (at stx `(begin (honu:type ,(translate-type-for-syntax type)) + (honu:type ,@(map (lambda (f) (translate-type-for-syntax (honu:formal-type f))) formals)) + ,(translate-function stx name formals + (translate-expression body))))])) ) diff --git a/collects/honu/private/compiler/translate-expression.ss b/collects/honu/private/compiler/translate-expression.ss index aa6643dc9b..a8e01e89be 100644 --- a/collects/honu/private/compiler/translate-expression.ss +++ b/collects/honu/private/compiler/translate-expression.ss @@ -21,7 +21,8 @@ ;; list is a bindable name in Honu, so... we use list*, which isn't. (at stx `(list* ,@(map translate-expression args) ()))] [(struct honu:lambda (stx _ formals body)) - (translate-function stx #f formals (translate-expression body))] + (at stx `(begin (honu:type ,@(map (lambda (f) (translate-type-for-syntax (honu:formal-type f))) formals)) + ,(translate-function stx #f formals (translate-expression body))))] [(struct honu:call (stx func arg)) (match func [(struct honu:member (stx 'my _ name #t)) @@ -229,7 +230,9 @@ (translate-expression (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)))) + (at (honu:ast-stx b) `(,bound-names (begin (honu:type ,@(map translate-type-for-syntax + (honu:binding-types b))) + ,body))))) bindings) ,(translate-expression body)))] [(struct honu:seq (stx effects value)) diff --git a/collects/honu/private/compiler/translate-utils.ss b/collects/honu/private/compiler/translate-utils.ss index b6338922e0..a28091502d 100644 --- a/collects/honu/private/compiler/translate-utils.ss +++ b/collects/honu/private/compiler/translate-utils.ss @@ -1,6 +1,7 @@ (module translate-utils mzscheme (require (all-except (lib "list.ss" "srfi" "1") any) + (lib "plt-match.ss") (lib "contract.ss") "../../ast.ss" "../../parameters.ss" @@ -67,7 +68,7 @@ translate-field-getter-name translate-field-setter-name) (define (translate-iface-name type) (let ([name (if (honu:type-iface-top? type) - (datum->syntax-object #f 'Any #f) + (datum->syntax-object #f 'Any (honu:ast-stx type)) (honu:type-iface-name type))]) (at name (string->symbol (string-append (symbol->string (syntax-e name)) "<%>"))))) @@ -132,6 +133,25 @@ `(begin (set! ,(at-ctxt name) ,arg) ,void-value))) `(begin (set! ,(at-ctxt name) ,arg) - ,void-value))) + ,void-value))) + + ;; Yes, this is just part of the hack that gives us Check Syntax-correctness on all the types that + ;; are not otherwise used in the compiled code. + (provide translate-type-for-syntax) + (define (translate-type-for-syntax type) + (define (real-translation type) + (match type + [(struct honu:type-iface (stx name)) + (list (translate-iface-name type))] + [(struct honu:type-iface-top (stx)) + (list (translate-iface-name type))] + [(struct honu:type-prim (stx name)) + '()] + [(struct honu:type-func (stx arg ret)) + (append (real-translation arg) + (real-translation ret))] + [(struct honu:type-tuple (stx args)) + (apply append (map real-translation args))])) + `(list* ,@(real-translation type) '())) ) diff --git a/collects/honu/private/compiler/translate.ss b/collects/honu/private/compiler/translate.ss index 83a6d03ecb..cf1e018aca 100644 --- a/collects/honu/private/compiler/translate.ss +++ b/collects/honu/private/compiler/translate.ss @@ -35,7 +35,7 @@ [else (loop (cdr defns-to-go) (cons (translate-defn (car defns-to-go)) syntaxes))]))) - (define (translate-member-names name) + (define (translate-iface-member-names name) (let* ([iface (make-iface-type name name)] [type-entry (get-type-entry iface)]) (let loop ([members (append (tenv:type-members type-entry) (tenv:type-inherited type-entry))] @@ -50,23 +50,39 @@ (cons (translate-field-setter-name iface (tenv:member-name (car members))) (cons (translate-field-getter-name iface (tenv:member-name (car members))) names)))))))) - + + (define (translate-iface-member-types members) + (define (get-member-type-list m) + (match m + [(struct honu:field-decl (_ _ type)) + (list (translate-type-for-syntax type))] + [(struct honu:method-decl (_ _ type arg-types)) + (cons (translate-type-for-syntax type) + (map translate-type-for-syntax arg-types))])) + (apply append (map get-member-type-list members))) + (define (translate-defn defn) (match defn - [(struct honu:bind-top (stx names _ value)) + [(struct honu:bind-top (stx names types value)) (let-values ([(bound-names body) (translate-binding-clause names (translate-expression value))]) - (at stx `(define-values ,bound-names ,body)))] - [(struct honu:function (stx name _ args body)) - (translate-function stx name args (translate-expression body))] + (at stx `(begin (honu:type ,@(map translate-type-for-syntax types)) + (define-values ,bound-names ,body))))] + [(struct honu:function (stx name type args body)) + (at stx `(begin (honu:type ,(translate-type-for-syntax type)) + (honu:type ,@(map (lambda (a) (translate-type-for-syntax (honu:formal-type a))) args)) + ,(translate-function stx name args (translate-expression 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 name))))] - [(struct honu:class (stx name _ _ impls inits members exports)) + (at stx `(begin + (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-iface-member-names name))) + (honu:type ,@(translate-iface-member-types members))))] + [(struct honu:class (stx name selftype _ impls inits members exports)) (at stx `(define ,(translate-class-name name) (class* object% ,(map translate-iface-name impls) + (honu:type ,(translate-type-for-syntax selftype)) (inspect #f) ,(translate-inits inits) ,@(map translate-member members) @@ -80,7 +96,7 @@ (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)) + [(list (struct honu:mixin (mstx mname selftype arg-type _ impls inits withs super-new members-before members-after exports)) (struct honu:subclass (stx name base mixin))) (parameterize ([current-mixin-argument-type arg-type]) (let* ([base-entry (get-class-entry base)] @@ -88,6 +104,8 @@ (tenv:class-impls base-entry))]) (at stx `(define ,(translate-class-name name) (class* ,(translate-class-name base) ,(map translate-iface-name impls) + (honu:type ,(translate-type-for-syntax selftype)) + (honu:type ,@(map (lambda (w) (translate-type-for-syntax (honu:formal-type w))))) (inspect #f) ,(translate-inits inits) ,@(map translate-member members-before)