From 2feaff9d19f076a56f9d403b744434a02711b992 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Tue, 5 Jul 2005 01:25:46 +0000 Subject: [PATCH] Moving all the calculation for what needs to be dragged along kicking and screaming into its own file, and now we stick that stuff into its own little space at the front of what translate returns so that it's seen by Check Syntax, but we can drop it like a hot potato when it comes time to run the compiled code. svn: r340 --- collects/honu/compile.ss | 2 +- .../private/compiler/translate-class-utils.ss | 29 ++-- .../private/compiler/translate-expression.ss | 7 +- .../compiler/translate-unwanted-types.ss | 161 ++++++++++++++++++ .../honu/private/compiler/translate-utils.ss | 20 --- collects/honu/private/compiler/translate.ss | 39 ++--- collects/honu/tool.ss | 6 +- 7 files changed, 190 insertions(+), 74 deletions(-) create mode 100644 collects/honu/private/compiler/translate-unwanted-types.ss 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)