diff --git a/collects/honu/compile.ss b/collects/honu/compile.ss index 0ad33678b0..0ebe7955bc 100644 --- a/collects/honu/compile.ss +++ b/collects/honu/compile.ss @@ -19,7 +19,7 @@ (provide/contract [compile/defns (tenv? tenv? (listof honu:defn?) . -> . - (listof (syntax/c any/c)))] + (cons/c any/c (listof (syntax/c any/c))))] [compile/interaction ((tenv? tenv? diff --git a/collects/honu/private/compiler/translate-class-utils.ss b/collects/honu/private/compiler/translate-class-utils.ss index 100566e254..316f0db2f6 100644 --- a/collects/honu/private/compiler/translate-class-utils.ss +++ b/collects/honu/private/compiler/translate-class-utils.ss @@ -99,10 +99,9 @@ (define (translate-export in-super? export) (cons 'begin - (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))))) + (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)]) @@ -126,11 +125,9 @@ (honu:super-new-args super-new))))) (define (translate-inits 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)))) + (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)))))) @@ -139,21 +136,15 @@ (match member [(struct honu:init-field (stx name type value)) (if value - (at stx`(begin (honu:type ,(translate-type-for-syntax type)) - (init ([,(mangle-init-name name) ,(at-ctxt name)] + (at stx`(begin (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)])) + (at stx `(begin (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))))] + (at stx `(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))))])) + (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 a8e01e89be..aa6643dc9b 100644 --- a/collects/honu/private/compiler/translate-expression.ss +++ b/collects/honu/private/compiler/translate-expression.ss @@ -21,8 +21,7 @@ ;; 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)) - (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))))] + (translate-function stx #f formals (translate-expression body))] [(struct honu:call (stx func arg)) (match func [(struct honu:member (stx 'my _ name #t)) @@ -230,9 +229,7 @@ (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 (begin (honu:type ,@(map translate-type-for-syntax - (honu:binding-types b))) - ,body))))) + (at (honu:ast-stx b) `(,bound-names ,body)))) bindings) ,(translate-expression body)))] [(struct honu:seq (stx effects value)) diff --git a/collects/honu/private/compiler/translate-unwanted-types.ss b/collects/honu/private/compiler/translate-unwanted-types.ss new file mode 100644 index 0000000000..1cec33af20 --- /dev/null +++ b/collects/honu/private/compiler/translate-unwanted-types.ss @@ -0,0 +1,161 @@ +(module translate-unwanted-types mzscheme + + (require (lib "plt-match.ss") + "../../ast.ss" + "translate-utils.ss") + + (provide build-unwanted-type-syntax) + (define (build-unwanted-type-syntax defns) + (map build-unwanted-type-syntax-defn defns)) + + ;; since we're never going to run the result anyway, it doesn't matter + ;; how we build things -- no need to flatten. + (define (build-unwanted-type-syntax-defn defn) + (match defn + [(struct honu:bind-top (_ _ types value)) + (cons (build-unwanted-type-syntax-expression value) + (map translate-type-for-syntax types))] + [(struct honu:function (_ _ type formals body)) + (list (translate-type-for-syntax type) + (build-unwanted-type-syntax-expression body) + (map (lambda (f) + (translate-type-for-syntax (honu:formal-type f))) + formals))] + [(struct honu:iface (_ _ _ members)) + (map build-unwanted-type-syntax-member-decl members)] + [(struct honu:class (_ _ selftype _ _ inits members exports)) + (list (translate-type-for-syntax selftype) + (map (lambda (f) + (translate-type-for-syntax (honu:formal-type f))) + inits) + (map build-unwanted-type-syntax-member members) + (map (lambda (e) + (translate-type-for-syntax (honu:export-type e))) + exports))] + [(struct honu:mixin (_ _ selftype arg-type _ _ inits withs super-new + members-before members-after exports)) + (list (translate-type-for-syntax selftype) + (translate-type-for-syntax arg-type) + (map (lambda (f) + (translate-type-for-syntax (honu:formal-type f))) + inits) + (map (lambda (f) + (translate-type-for-syntax (honu:formal-type f))) + withs) + (map (lambda (a) + (build-unwanted-type-syntax-expression (honu:name-arg-value a))) + (honu:super-new-args super-new)) + (map build-unwanted-type-syntax-member members-before) + (map build-unwanted-type-syntax-member members-after) + (map (lambda (e) + (translate-type-for-syntax (honu:export-type e))) + exports))] + [(struct honu:subclass (_ _ _ _)) + '()])) + + (define (build-unwanted-type-syntax-member-decl member) + (match member + [(struct honu:field-decl (_ _ type)) + (translate-type-for-syntax type)] + [(struct honu:method-decl (_ _ type arg-types)) + (list (translate-type-for-syntax type) + (map translate-type-for-syntax arg-types))])) + + (define (build-unwanted-type-syntax-member member) + (match member + [(struct honu:init-field (_ _ type value)) + (list (translate-type-for-syntax type) + (if value (build-unwanted-type-syntax-expression value) '()))] + [(struct honu:field (_ _ type value)) + (list (translate-type-for-syntax type) + (build-unwanted-type-syntax-expression value))] + [(struct honu:method (_ _ type formals body)) + (list (translate-type-for-syntax type) + (map (lambda (f) + (translate-type-for-syntax (honu:formal-type f))) + formals) + (build-unwanted-type-syntax-expression body))])) + + (define (build-unwanted-type-syntax-expression expr) + (match expr + [(struct honu:lambda (_ type formals body)) + (list (translate-type-for-syntax type) + (map (lambda (f) + (translate-type-for-syntax (honu:formal-type f))) + formals) + (build-unwanted-type-syntax-expression body))] + [(struct honu:let (_ bindings body)) + (list (map (lambda (b) + (list (map translate-type-for-syntax (honu:binding-types b)) + (build-unwanted-type-syntax-expression (honu:binding-value b)))) + bindings) + (build-unwanted-type-syntax-expression body))] + [(struct honu:seq (_ effects result)) + (list (map (lambda (e) + (build-unwanted-type-syntax-expression e)) + effects) + (build-unwanted-type-syntax-expression result))] + [(struct honu:call (_ func arg)) + (list (build-unwanted-type-syntax-expression func) + (build-unwanted-type-syntax-expression arg))] + [(struct honu:assn (_ lhs rhs)) + (list (build-unwanted-type-syntax-expression lhs) + (build-unwanted-type-syntax-expression rhs))] + [(struct honu:return (_ body)) + (build-unwanted-type-syntax-expression body)] + [(struct honu:select (_ _ arg)) + (build-unwanted-type-syntax-expression arg)] + [(struct honu:tuple (_ args)) + (map build-unwanted-type-syntax-expression args)] + [(struct honu:member (_ obj _ _ _)) + (if (honu:expr? obj) + (build-unwanted-type-syntax-expression obj) + (list))] + [(struct honu:new (_ obj type args)) + (list (build-unwanted-type-syntax-expression obj) + (translate-type-for-syntax type) + (map (lambda (a) + (build-unwanted-type-syntax-expression (honu:name-arg-value a))) + args))] + ;; here are the two cases where the type already appears in the compiled code + [(struct honu:cast (_ obj _)) + (build-unwanted-type-syntax-expression obj)] + [(struct honu:isa (_ obj _)) + (build-unwanted-type-syntax-expression obj)] + [(struct honu:un-op (_ _ _ _ arg)) + (build-unwanted-type-syntax-expression arg)] + [(struct honu:bin-op (_ _ _ _ larg rarg)) + (list (build-unwanted-type-syntax-expression larg) + (build-unwanted-type-syntax-expression rarg))] + [(struct honu:if (_ cond then else)) + (list (build-unwanted-type-syntax-expression cond) + (build-unwanted-type-syntax-expression then) + (build-unwanted-type-syntax-expression else))] + [(struct honu:cond (_ clauses else)) + (list (map (lambda (c) + (list (build-unwanted-type-syntax-expression (honu:cond-clause-pred c)) + (build-unwanted-type-syntax-expression (honu:cond-clause-rhs c)))) + clauses) + (if else (build-unwanted-type-syntax-expression else) '()))] + [else '()])) + + ;; 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)) + (translate-iface-name type)] + [(struct honu:type-iface-top (stx)) + (translate-iface-name type)] + [(struct honu:type-prim (stx name)) + '()] + [(struct honu:type-func (stx arg ret)) + (list (real-translation arg) + (real-translation ret))] + [(struct honu:type-tuple (stx args)) + (map real-translation args)])) + (real-translation type)) + + ) \ No newline at end of file diff --git a/collects/honu/private/compiler/translate-utils.ss b/collects/honu/private/compiler/translate-utils.ss index a28091502d..2339be8a68 100644 --- a/collects/honu/private/compiler/translate-utils.ss +++ b/collects/honu/private/compiler/translate-utils.ss @@ -1,7 +1,6 @@ (module translate-utils mzscheme (require (all-except (lib "list.ss" "srfi" "1") any) - (lib "plt-match.ss") (lib "contract.ss") "../../ast.ss" "../../parameters.ss" @@ -135,23 +134,4 @@ `(begin (set! ,(at-ctxt name) ,arg) ,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 227723b754..8f4c434262 100644 --- a/collects/honu/private/compiler/translate.ss +++ b/collects/honu/private/compiler/translate.ss @@ -10,11 +10,12 @@ "translate-class-utils.ss" "translate-expression.ss" "translate-parameters.ss" + "translate-unwanted-types.ss" "translate-utils.ss") (provide/contract [translate ((listof honu:defn?) . -> . - (listof (syntax/c any/c)))] + (cons/c any/c (listof (syntax/c any/c))))] [translate-defn (honu:defn? . -> . (syntax/c any/c))]) @@ -22,7 +23,9 @@ (let loop ([defns-to-go defns] [syntaxes '()]) (cond - [(null? defns-to-go) (reverse syntaxes)] + [(null? defns-to-go) + (cons (build-unwanted-type-syntax defns) + (reverse syntaxes))] [(honu:mixin? (car defns-to-go)) (loop (cdr defns-to-go) syntaxes)] [(honu:subclass? (car defns-to-go)) @@ -51,38 +54,22 @@ (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 types value)) (let-values ([(bound-names body) (translate-binding-clause names (translate-expression value))]) - (at stx `(begin (honu:type ,@(map translate-type-for-syntax types)) - (define-values ,bound-names ,body))))] + (at stx `(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))))] + (translate-function stx name args (translate-expression body))] [(struct honu:iface (stx name supers members)) - (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))))] + (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-iface-member-names name))))] [(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) @@ -104,8 +91,6 @@ (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))) withs)) (inspect #f) ,(translate-inits inits) ,@(map translate-member members-before) diff --git a/collects/honu/tool.ss b/collects/honu/tool.ss index 4b4e52ad94..5c7852d661 100644 --- a/collects/honu/tool.ss +++ b/collects/honu/tool.ss @@ -138,8 +138,10 @@ (syntax-e #'type))] ;; if it wasn't either of those, this must have been from the definitions ;; window, so just eval it. - [exp - (old-current-eval (syntax-as-top #'exp))])))) + ;; + ;; well, remove the cruft I added to get Check Syntax to work first. + [(_ type-cruft stx ...) + (old-current-eval (syntax-as-top #'(begin stx ...)))])))) (namespace-attach-module n path) (namespace-require path))))) (define/public (render-value value settings port)