From cc8ee7ac3ace8b8aad85a89c5cce0dc06afadb56 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 4 Jul 2005 20:13:47 +0000 Subject: [PATCH] merging 326:329 from branches/sstrickl This fixes up the fact that is-a? should work different for Honu classes than MzScheme ones (since Honu classes do not automatically implement the interfaces their superclass did). I also did some parameterization in the translate module (outside the already existing current-compile-context). svn: r330 --- collects/honu/base.ss | 1 + collects/honu/compile.ss | 2 +- .../private/compiler/translate-class-utils.ss | 32 +-- .../private/compiler/translate-expression.ss | 208 +++++++++--------- .../private/compiler/translate-parameters.ss | 7 + .../honu/private/compiler/translate-utils.ss | 29 +-- collects/honu/private/compiler/translate.ss | 111 +++++----- .../honu/private/typechecker/type-utils.ss | 6 + collects/honu/tool.ss | 7 +- 9 files changed, 208 insertions(+), 195 deletions(-) create mode 100644 collects/honu/private/compiler/translate-parameters.ss diff --git a/collects/honu/base.ss b/collects/honu/base.ss index fa0d7153d1..10883e9929 100644 --- a/collects/honu/base.ss +++ b/collects/honu/base.ss @@ -79,5 +79,6 @@ [else (string-ref s i)]))) (provide (all-from mzscheme) + (rename ormap mz:ormap) (all-from (lib "class.ss")) (all-defined))) diff --git a/collects/honu/compile.ss b/collects/honu/compile.ss index 4181c06e31..0ad33678b0 100644 --- a/collects/honu/compile.ss +++ b/collects/honu/compile.ss @@ -55,6 +55,6 @@ [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)))]))) + (values (translate-expression checked) type)))]))) ) diff --git a/collects/honu/private/compiler/translate-class-utils.ss b/collects/honu/private/compiler/translate-class-utils.ss index 664f424589..21a43e6999 100644 --- a/collects/honu/private/compiler/translate-class-utils.ss +++ b/collects/honu/private/compiler/translate-class-utils.ss @@ -16,17 +16,17 @@ (define (translate-class-exports exports) (let ([exports (filter-exports (generate-exports exports))]) (map (lambda (e) - (translate-export #f #f e)) + (translate-export #f e)) exports))) - (define (translate-subclass-exports super-types arg-type exports) + (define (translate-subclass-exports super-types exports) (let ([exports (filter-exports (generate-exports exports))]) (map (lambda (e) (if (ormap (lambda (t) (<:_P t (comp:export-type e))) super-types) - (translate-export #t arg-type e) - (translate-export #f arg-type e))) + (translate-export #t e) + (translate-export #f e))) 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 in-super? arg-type export) + (define (translate-export in-super? export) (cons 'begin (map (lambda (b) - (translate-exp-bind in-super? arg-type (comp:export-type export) b)) + (translate-exp-bind in-super? (comp:export-type export) b)) (comp:export-binds export)))) - (define (translate-exp-bind in-super? arg-type type binding) + (define (translate-exp-bind in-super? 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 arg-type old-name 'arg-tuple)))] + ,(translate-static-method 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 arg-type old-name)) + ,(translate-static-field-getter old-name)) (,right-defn (,(translate-field-setter-name type new-name) set-arg) - ,(translate-static-field-setter arg-type old-name 'set-arg))))]))) + ,(translate-static-field-setter old-name 'set-arg))))]))) (provide translate-super-new translate-inits translate-member) - (define (translate-super-new arg-type super-new) + (define (translate-super-new super-new) (at (honu:ast-stx super-new) (cons 'super-new (map (lambda (a) (list (at-ctxt (honu:name-arg-name a)) - (translate-expression arg-type (honu:name-arg-value a)))) + (translate-expression (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 arg-type member) + (define (translate-member member) (match member [(struct honu:init-field (stx name _ value)) (if value `(begin (init ([,(mangle-init-name name) ,(at-ctxt name)] - ,(translate-expression arg-type value))) + ,(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 arg-type value))] + `(define ,(at-ctxt name) ,(translate-expression value))] [(struct honu:method (stx name _ formals body)) (translate-function stx name formals - (translate-expression arg-type body))])) + (translate-expression body))])) ) diff --git a/collects/honu/private/compiler/translate-expression.ss b/collects/honu/private/compiler/translate-expression.ss index 3be3cdbb31..aa6643dc9b 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 ((union honu:type? false/c) honu:expr? + (provide/contract [translate-expression (honu:expr? . -> . (syntax/c any/c))]) - (define (translate-expression arg-type expr) + (define (translate-expression expr) (match expr [(struct honu:lit (stx _ value)) (at stx value)] @@ -19,55 +19,51 @@ (at-ctxt name)] [(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 arg-type e)) - args) - ()))] + (at stx `(list* ,@(map translate-expression args) ()))] [(struct honu:lambda (stx _ formals body)) - (translate-function stx #f formals (translate-expression arg-type body))] + (translate-function stx #f formals (translate-expression body))] [(struct honu:call (stx func arg)) (match func [(struct honu:member (stx 'my _ name #t)) - (at stx (translate-static-method arg-type name - (translate-expression arg-type arg)))] + (at stx (translate-static-method name (translate-expression arg)))] [(struct honu:member (stx obj elab name #t)) - (at stx `(honu:send ,(translate-expression arg-type obj) + (at stx `(honu:send ,(translate-expression obj) ,(translate-method-name elab name) - ,(translate-expression arg-type arg)))] + ,(translate-expression arg)))] [else - (at stx `(,(translate-expression arg-type func) - ,(translate-expression arg-type arg)))])] + (at stx `(,(translate-expression func) + ,(translate-expression arg)))])] [(struct honu:select (stx slot arg)) - (at stx `(list-ref ,(translate-expression arg-type arg) + (at stx `(list-ref ,(translate-expression arg) (- ,slot 1)))] [(struct honu:if (stx test then else)) (if else - (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) + (at stx `(if ,(translate-expression test) + ,(translate-expression then) + ,(translate-expression else))) + (at stx `(if ,(translate-expression test) + ,(translate-expression then) ,void-value)))] [(struct honu:cond (stx clauses else)) (if else (at stx `(cond ,@(map (lambda (c) - `(,(translate-expression arg-type (honu:cond-clause-pred c)) - ,(translate-expression arg-type (honu:cond-clause-rhs c)))) + `(,(translate-expression (honu:cond-clause-pred c)) + ,(translate-expression (honu:cond-clause-rhs c)))) clauses) - (else ,(translate-expression arg-type else)))) + (else ,(translate-expression else)))) (at stx `(cond ,@(map (lambda (c) - `(,(translate-expression arg-type (honu:cond-clause-pred c)) - ,(translate-expression arg-type (honu:cond-clause-rhs c)))) + `(,(translate-expression (honu:cond-clause-pred c)) + ,(translate-expression (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 arg-type arg)))] + `(,(at op-stx 'not) ,(translate-expression arg)))] [(minus) (at stx - `(,(at op-stx '-) ,(translate-expression arg-type arg)))] + `(,(at op-stx '-) ,(translate-expression arg)))] [else (raise-read-error-with-stx "Haven't translated unary operator yet." op-stx)])] @@ -78,239 +74,231 @@ (eqv? (honu:type-prim-name op-type) 'string)) (at stx `(,(at op-stx 'string=?) - ,(translate-expression arg-type larg) - ,(translate-expression arg-type rarg))) + ,(translate-expression larg) + ,(translate-expression rarg))) (at stx `(,(at op-stx 'eqv?) - ,(translate-expression arg-type larg) - ,(translate-expression arg-type rarg))))] + ,(translate-expression larg) + ,(translate-expression 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 arg-type larg) - ,(translate-expression arg-type rarg)))) + ,(translate-expression larg) + ,(translate-expression rarg)))) (at stx `(,(at op-stx 'not) (,(at op-stx 'eqv?) - ,(translate-expression arg-type larg) - ,(translate-expression arg-type rarg)))))] + ,(translate-expression larg) + ,(translate-expression rarg)))))] [(clseq) (at stx `(,(at op-stx 'equal?) - ,(translate-expression arg-type larg) - ,(translate-expression arg-type rarg)))] + ,(translate-expression larg) + ,(translate-expression rarg)))] [(and) (at stx `(,(at op-stx 'and) - ,(translate-expression arg-type larg) - ,(translate-expression arg-type rarg)))] + ,(translate-expression larg) + ,(translate-expression rarg)))] [(or) (at stx `(,(at op-stx 'or) - ,(translate-expression arg-type larg) - ,(translate-expression arg-type rarg)))] + ,(translate-expression larg) + ,(translate-expression rarg)))] [(lt) (case (honu:type-prim-name op-type) [(int float) (at stx `(,(at op-stx '<) - ,(translate-expression arg-type larg) - ,(translate-expression arg-type rarg)))] + ,(translate-expression larg) + ,(translate-expression rarg)))] [(string) (at stx `(,(at op-stx 'string) - ,(translate-expression arg-type larg) - ,(translate-expression arg-type rarg)))] + ,(translate-expression larg) + ,(translate-expression rarg)))] [(string) (at stx `(,(at op-stx 'string>?) - ,(translate-expression arg-type larg) - ,(translate-expression arg-type rarg)))] + ,(translate-expression larg) + ,(translate-expression rarg)))] [(char) (at stx `(,(at op-stx 'char>?) - ,(translate-expression arg-type larg) - ,(translate-expression arg-type rarg)))])] + ,(translate-expression larg) + ,(translate-expression rarg)))])] [(ge) (case (honu:type-prim-name op-type) [(int float) (at stx `(,(at op-stx '>=) - ,(translate-expression arg-type larg) - ,(translate-expression arg-type rarg)))] + ,(translate-expression larg) + ,(translate-expression rarg)))] [(string) (at stx `(,(at op-stx 'string>=?) - ,(translate-expression arg-type larg) - ,(translate-expression arg-type rarg)))] + ,(translate-expression larg) + ,(translate-expression rarg)))] [(char) (at stx `(,(at op-stx 'char>=?) - ,(translate-expression arg-type larg) - ,(translate-expression arg-type rarg)))])] + ,(translate-expression larg) + ,(translate-expression rarg)))])] [(plus) (case (honu:type-prim-name op-type) [(int float) (at stx `(,(at op-stx '+) - ,(translate-expression arg-type larg) - ,(translate-expression arg-type rarg)))] + ,(translate-expression larg) + ,(translate-expression rarg)))] [(string) (at stx `(,(at op-stx 'string-append) - ,(translate-expression arg-type larg) - ,(translate-expression arg-type rarg)))])] + ,(translate-expression larg) + ,(translate-expression rarg)))])] [(minus) (at stx `(,(at op-stx '-) - ,(translate-expression arg-type larg) - ,(translate-expression arg-type rarg)))] + ,(translate-expression larg) + ,(translate-expression rarg)))] [(times) (at stx `(,(at op-stx '*) - ,(translate-expression arg-type larg) - ,(translate-expression arg-type rarg)))] + ,(translate-expression larg) + ,(translate-expression rarg)))] [(div) (case (honu:type-prim-name op-type) [(int) (at stx `(,(at op-stx 'quotient) - ,(translate-expression arg-type larg) - ,(translate-expression arg-type rarg)))] + ,(translate-expression larg) + ,(translate-expression rarg)))] [(float) (at stx `(,(at op-stx '/) - ,(translate-expression arg-type larg) - ,(translate-expression arg-type rarg)))])] + ,(translate-expression larg) + ,(translate-expression rarg)))])] [(mod) (at stx `(,(at op-stx 'remainder) - ,(translate-expression arg-type larg) - ,(translate-expression arg-type rarg)))] + ,(translate-expression larg) + ,(translate-expression 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 arg-type body)))] + `(last-k ,(translate-expression 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 arg-type (honu:binding-value b)))]) + (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)))) bindings) - ,(translate-expression arg-type body)))] + ,(translate-expression body)))] [(struct honu:seq (stx effects value)) (at stx - `(begin ,@(map (lambda (e) - (translate-expression arg-type e)) - effects) - ,(translate-expression arg-type value)))] + `(begin ,@(map translate-expression effects) + ,(translate-expression value)))] [(struct honu:while (stx test body)) (at stx `(let loop () - (if ,(translate-expression arg-type test) - (begin ,(translate-expression arg-type body) (loop)) + (if ,(translate-expression test) + (begin ,(translate-expression body) (loop)) ,void-value)))] [(struct honu:assn (stx lhs rhs)) (match lhs [(struct honu:var (_ _)) - (at stx `(begin (set! ,(translate-expression arg-type lhs) - ,(translate-expression arg-type rhs)) + (at stx `(begin (set! ,(translate-expression lhs) + ,(translate-expression 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 arg-type name - (translate-expression arg-type rhs))))] + (at stx (translate-static-field-setter name (translate-expression 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 arg-type obj) + (at stx `(honu:send ,(translate-expression obj) ,(translate-field-setter-name elab name) - ,(translate-expression arg-type rhs))))] + ,(translate-expression 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 arg-type name)) - (at stx (translate-static-field-getter arg-type name)))] + (at stx (translate-static-method name)) + (at stx (translate-static-field-getter name)))] [(struct honu:member (stx obj elab name method?)) (if method? (at stx `(lambda (args) - (honu:send ,(translate-expression arg-type obj) + (honu:send ,(translate-expression obj) ,(translate-method-name elab name) args))) - (at stx `(honu:send ,(translate-expression arg-type obj) + (at stx `(honu:send ,(translate-expression 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 arg-type (honu:name-arg-value a)))) + ,(translate-expression (honu:name-arg-value a)))) args)))] [(struct honu:cast (stx obj type)) - (at stx `(let ([cast-obj ,(translate-expression arg-type obj)]) + (at stx `(let ([cast-obj ,(translate-expression 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))) + (honu:send cast-obj implements? ,(translate-iface-name type))) cast-obj - ;; we can use object-info and class-info since we always set (inspect #f) - ;; we have to do that for the moment anyway for "extensional" class equality. - (let*-values ([(class dc-1) (object-info cast-obj)] - [(class-name dc-1 dc-2 dc-3 dc-4 dc-5 dc-6) (class-info class)]) - (error (format "Class ~a does not implement ~a" - (let ([class-string (symbol->string class-name)]) - (string->symbol (substring class-string 0 (- (string-length class-string) 1)))) - (quote ,(printable-type type))))))))] + (error (format "Class ~a does not implement ~a" + (honu:send cast-obj format-class-name) + (quote ,(syntax-e (iface-name type))))))))] [(struct honu:isa (stx obj type)) - (at stx `(let ([cast-obj ,(translate-expression arg-type obj)]) + (at stx `(let ([cast-obj ,(translate-expression obj)]) ;; null is a member of any interface type (or (is-a? cast-obj null%) - (is-a? cast-obj ,(translate-iface-name type)))))] + (honu:send cast-obj implements? ,(translate-iface-name type)))))] [(struct honu:this (stx)) (at stx 'this)] [else (raise-read-error-with-stx diff --git a/collects/honu/private/compiler/translate-parameters.ss b/collects/honu/private/compiler/translate-parameters.ss new file mode 100644 index 0000000000..72c69404ad --- /dev/null +++ b/collects/honu/private/compiler/translate-parameters.ss @@ -0,0 +1,7 @@ +(module translate-parameters mzscheme + + (provide (all-defined)) + + (define current-mixin-argument-type (make-parameter #f)) + + ) \ 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 c1c1206323..b6338922e0 100644 --- a/collects/honu/private/compiler/translate-utils.ss +++ b/collects/honu/private/compiler/translate-utils.ss @@ -4,7 +4,8 @@ (lib "contract.ss") "../../ast.ss" "../../parameters.ss" - "../../tenv.ss") + "../../tenv.ss" + "translate-parameters.ss") (define stx-for-original-property (read-syntax #f (open-input-string "original"))) @@ -91,17 +92,17 @@ "-set!")))) (provide translate-static-method translate-static-field-getter translate-static-field-setter) - (define (translate-static-method arg-type name arg) - (if arg-type - (let ([type-entry (get-type-entry arg-type)]) + (define (translate-static-method name arg) + (if (current-mixin-argument-type) + (let ([type-entry (get-type-entry (current-mixin-argument-type))]) (if (s:member name (map tenv:member-name (append (tenv:type-members type-entry) (tenv:type-inherited type-entry))) tenv-key=?) (if arg - `(super ,(translate-method-name arg-type name) ,arg) + `(super ,(translate-method-name (current-mixin-argument-type) name) ,arg) `(lambda (arg-tuple) - (super ,(translate-method-name arg-type name) arg-tuple))) + (super ,(translate-method-name (current-mixin-argument-type) name) arg-tuple))) (if arg `(,(at-ctxt name) ,arg) (at-ctxt name)))) @@ -109,25 +110,25 @@ `(,(at-ctxt name) ,arg) (at-ctxt name)))) - (define (translate-static-field-getter arg-type name) - (if arg-type - (let ([type-entry (get-type-entry arg-type)]) + (define (translate-static-field-getter name) + (if (current-mixin-argument-type) + (let ([type-entry (get-type-entry (current-mixin-argument-type))]) (if (s:member name (map tenv:member-name (append (tenv:type-members type-entry) (tenv:type-inherited type-entry))) tenv-key=?) - `(super ,(translate-field-getter-name arg-type name) ,void-value) + `(super ,(translate-field-getter-name (current-mixin-argument-type) name) ,void-value) (at-ctxt name))) (at-ctxt name))) - (define (translate-static-field-setter arg-type name arg) - (if arg-type - (let ([type-entry (get-type-entry arg-type)]) + (define (translate-static-field-setter name arg) + (if (current-mixin-argument-type) + (let ([type-entry (get-type-entry (current-mixin-argument-type))]) (if (s:member name (map tenv:member-name (append (tenv:type-members type-entry) (tenv:type-inherited type-entry))) tenv-key=?) - `(super ,(translate-field-setter-name arg-type name) ,arg) + `(super ,(translate-field-setter-name (current-mixin-argument-type) name) ,arg) `(begin (set! ,(at-ctxt name) ,arg) ,void-value))) `(begin (set! ,(at-ctxt name) ,arg) diff --git a/collects/honu/private/compiler/translate.ss b/collects/honu/private/compiler/translate.ss index 796d4a199d..83a6d03ecb 100644 --- a/collects/honu/private/compiler/translate.ss +++ b/collects/honu/private/compiler/translate.ss @@ -9,6 +9,7 @@ "../typechecker/type-utils.ss" "translate-class-utils.ss" "translate-expression.ss" + "translate-parameters.ss" "translate-utils.ss") (provide/contract [translate ((listof honu:defn?) @@ -53,10 +54,10 @@ (define (translate-defn defn) (match defn [(struct honu:bind-top (stx names _ value)) - (let-values ([(bound-names body) (translate-binding-clause names (translate-expression #f 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 #f body))] + (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) @@ -68,10 +69,10 @@ (class* object% ,(map translate-iface-name impls) (inspect #f) ,(translate-inits inits) - ,@(map (lambda (m) - (translate-member #f m)) members) + ,@(map translate-member members) ,@(translate-class-exports exports) - ,(translate-formatter name members #f) + ,(translate-impl-method impls) + ,(translate-formatter name members) (super-new))))] [else (raise-read-error-with-stx "Haven't translated that type of definition yet." @@ -81,51 +82,59 @@ (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 base)] - [base-types (cons (tenv:class-sub-type base-entry) - (tenv:class-impls base-entry))]) - (at stx `(define ,(translate-class-name name) - (class* ,(translate-class-name base) ,(map translate-iface-name impls) - (inspect #f) - ,(translate-inits inits) - ,@(map (lambda (m) - (translate-member arg-type m)) members-before) - ,(translate-super-new arg-type super-new) - ,@(map (lambda (m) - (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)))))])) + (parameterize ([current-mixin-argument-type arg-type]) + (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) + (class* ,(translate-class-name base) ,(map translate-iface-name impls) + (inspect #f) + ,(translate-inits inits) + ,@(map translate-member members-before) + ,(translate-super-new super-new) + ,@(map translate-member members-after) + ,@(translate-subclass-exports base-types exports) + ,(translate-impl-method impls) + ,(translate-formatter name (append members-before members-after)))))))])) + + (define (translate-impl-method impls) + (let ([right-define (if (current-mixin-argument-type) 'define/override 'define/public)]) + `(,right-define (implements? iface) + (mz:ormap (lambda (i) + (interface-extension? i iface)) + (list* ,@(map translate-iface-name impls) '()))))) - (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? - (format "~a {~a}" - (quote ,(syntax-e name)) - ,(cons 'string-append - (let ([printable-members (filter (lambda (m) - (not (honu:method? m))) - members)] - [printable-smembers (if arg-type - (filter-map (lambda (m) - (if (not (honu:type-disp? (tenv:member-type m))) - (tenv:member-name m) - #f)) - (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]) - (if (and (null? printable-members) - (null? printable-smembers)) - '("") - (fold-right (lambda (m 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)) - printable-members) - printable-smembers))))) - (format "~a" (quote ,(syntax-e name))))))) + (define (translate-formatter name members) + (let ([right-define (if (current-mixin-argument-type) 'define/override 'define/public)]) + `(begin + (,right-define (format-class-name) + ,(format "~a" (syntax-e name))) + (,right-define (format-class renderer indent) + (format "~a {~a}" + (format-class-name) + ,(cons 'string-append + (let ([printable-members (filter (lambda (m) + (not (honu:method? m))) + members)] + [printable-smembers (if (current-mixin-argument-type) + (filter-map (lambda (m) + (if (not (honu:type-disp? (tenv:member-type m))) + (tenv:member-name m) + #f)) + (tenv:type-members (get-type-entry (current-mixin-argument-type)))) + '())] + ;; how much more do we want the members indented? Let's try 2 spaces more. + [indent-delta 2]) + (if (and (null? printable-members) + (null? printable-smembers)) + '("") + (fold-right (lambda (m l) + (list* "\n" (translate-super-member-formatter m indent-delta) l)) + (fold-right (lambda (m l) + (list* "\n" (translate-member-formatter m indent-delta) l)) + '("\n" (make-string indent #\space)) + printable-members) + printable-smembers))))))))) (define (translate-member-formatter member indent-delta) (let ([name (if (honu:field? member) @@ -137,11 +146,11 @@ ;; the 3 is for " = " (renderer ,name (+ indent ,(+ indent-delta (string-length (symbol->string (syntax-e name))) 3)))))) - (define (translate-super-member-formatter arg-type name indent-delta) + (define (translate-super-member-formatter 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 arg-type name) + (renderer ,(translate-static-field-getter 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 d6c3abc30b..43b541c8c4 100644 --- a/collects/honu/private/typechecker/type-utils.ss +++ b/collects/honu/private/typechecker/type-utils.ss @@ -255,6 +255,12 @@ (tenv:type-supers type-entry))))] [else #f])) + (provide iface-name) + (define (iface-name type) + (match type + [(struct honu:type-iface-top (_)) #'Any] + [(struct honu:type-iface (_ name)) name])) + (provide raise-honu-type-error) (define (raise-honu-type-error stx expected received) (raise-read-error-with-stx diff --git a/collects/honu/tool.ss b/collects/honu/tool.ss index a9e66e5e1e..ee7990f091 100644 --- a/collects/honu/tool.ss +++ b/collects/honu/tool.ss @@ -214,11 +214,12 @@ (cdr value)) ")"))] [(is-a? value null%) "null"] - [(object? value) (send value format-class + [(object? value) (if (eqv? (honu-settings-display-style settings) 'field) + (send value format-class (lambda (value at-top?) (format-honu-value value settings at-top?)) - indent - (eqv? (honu-settings-display-style settings) 'field))] + indent) + (send value format-class-name))] [else (format "~a" value)])) ;Set the Honu editing colors