suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

merging 326:329 from branches/sstrickl

Browse Source 
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
This commit is contained in:
Stevie Strickland 2005-07-04 20:13:47 +00:00
parent 541cf4b7ad
commit cc8ee7ac3a
9 changed files with 208 additions and 195 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/honu/base.ss
View File

@ -79,5 +79,6 @@
[else (string-ref s i)]))) [else (string-ref s i)])))
(provide (all-from mzscheme) (provide (all-from mzscheme)
(rename ormap mz:ormap)
(all-from (lib "class.ss")) (all-from (lib "class.ss"))
(all-defined))) (all-defined)))

2
collects/honu/compile.ss
View File

@ -55,6 +55,6 @@
[else [else
(let-values ([(checked type) (typecheck-expression (wrap-lenv) (make-top-type #f) ast)]) (let-values ([(checked type) (typecheck-expression (wrap-lenv) (make-top-type #f) ast)])
(parameterize ([current-compile-context honu-compile-context]) (parameterize ([current-compile-context honu-compile-context])
(values (translate-expression #f checked) type)))]))) (values (translate-expression checked) type)))])))
) )

32
collects/honu/private/compiler/translate-class-utils.ss
View File

@ -16,17 +16,17 @@
(define (translate-class-exports exports) (define (translate-class-exports exports)
(let ([exports (filter-exports (generate-exports exports))]) (let ([exports (filter-exports (generate-exports exports))])
(map (lambda (e) (map (lambda (e)
(translate-export #f #f e)) (translate-export #f e))
exports))) exports)))
(define (translate-subclass-exports super-types arg-type exports) (define (translate-subclass-exports super-types exports)
(let ([exports (filter-exports (generate-exports exports))]) (let ([exports (filter-exports (generate-exports exports))])
(map (lambda (e) (map (lambda (e)
(if (ormap (lambda (t) (if (ormap (lambda (t)
(<:_P t (comp:export-type e))) (<:_P t (comp:export-type e)))
super-types) super-types)
(translate-export #t arg-type e) (translate-export #t e)
(translate-export #f arg-type e))) (translate-export #f e)))
exports))) exports)))
@ -97,31 +97,31 @@
(loop non-matches (cons exp-with-stx kept-exps)) (loop non-matches (cons exp-with-stx kept-exps))
(loop non-matches (cons (car exports) 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 (cons 'begin
(map (lambda (b) (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)))) (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)]) (let ([right-defn (if in-super? 'define/override 'define/public)])
(match binding (match binding
[(struct comp:exp-bind (old-name new-name #t)) [(struct comp:exp-bind (old-name new-name #t))
(at #f `(,right-defn (,(translate-method-name type new-name) arg-tuple) (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)) [(struct comp:exp-bind (old-name new-name #f))
(at #f `(begin (at #f `(begin
(,right-defn (,(translate-field-getter-name type new-name) args) (,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) (,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) (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) (at (honu:ast-stx super-new)
(cons 'super-new (map (lambda (a) (cons 'super-new (map (lambda (a)
(list (at-ctxt (honu:name-arg-name 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))))) (honu:super-new-args super-new)))))
(define (translate-inits inits) (define (translate-inits inits)
@ -132,20 +132,20 @@
(define (mangle-init-name name) (define (mangle-init-name name)
(at name (string->symbol (string-append "init-" (symbol->string (syntax-e 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 (match member
[(struct honu:init-field (stx name _ value)) [(struct honu:init-field (stx name _ value))
(if value (if value
`(begin (init ([,(mangle-init-name name) ,(at-ctxt name)] `(begin (init ([,(mangle-init-name name) ,(at-ctxt name)]
,(translate-expression arg-type value))) ,(translate-expression value)))
(define ,(at-ctxt name) ,(mangle-init-name))) (define ,(at-ctxt name) ,(mangle-init-name)))
`(begin (init ([,(mangle-init-name name) ,(at-ctxt name)])) `(begin (init ([,(mangle-init-name name) ,(at-ctxt name)]))
(define ,(at-ctxt name) ,(mangle-init-name name))))] (define ,(at-ctxt name) ,(mangle-init-name name))))]
[(struct honu:field (stx name _ value)) [(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)) [(struct honu:method (stx name _ formals body))
(translate-function stx name formals (translate-function stx name formals
(translate-expression arg-type body))])) (translate-expression body))]))
) )

208
collects/honu/private/compiler/translate-expression.ss
View File

@ -8,10 +8,10 @@
"../typechecker/type-utils.ss" "../typechecker/type-utils.ss"
"translate-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))]) (syntax/c any/c))])
(define (translate-expression arg-type expr) (define (translate-expression expr)
(match expr (match expr
[(struct honu:lit (stx _ value)) [(struct honu:lit (stx _ value))
(at stx value)] (at stx value)]
@ -19,55 +19,51 @@
(at-ctxt name)] (at-ctxt name)]
[(struct honu:tuple (stx args)) [(struct honu:tuple (stx args))
;; list is a bindable name in Honu, so... we use list*, which isn't. ;; list is a bindable name in Honu, so... we use list*, which isn't.
(at stx `(list* ,@(map (lambda (e) (at stx `(list* ,@(map translate-expression args) ()))]
(translate-expression arg-type e))
args)
()))]
[(struct honu:lambda (stx _ formals body)) [(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)) [(struct honu:call (stx func arg))
(match func (match func
[(struct honu:member (stx 'my _ name #t)) [(struct honu:member (stx 'my _ name #t))
(at stx (translate-static-method arg-type name (at stx (translate-static-method name (translate-expression arg)))]
(translate-expression arg-type arg)))]
[(struct honu:member (stx obj elab name #t)) [(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-method-name elab name)
,(translate-expression arg-type arg)))] ,(translate-expression arg)))]
[else [else
(at stx `(,(translate-expression arg-type func) (at stx `(,(translate-expression func)
,(translate-expression arg-type arg)))])] ,(translate-expression arg)))])]
[(struct honu:select (stx slot 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)))] (- ,slot 1)))]
[(struct honu:if (stx test then else)) [(struct honu:if (stx test then else))
(if else (if else
(at stx `(if ,(translate-expression arg-type test) (at stx `(if ,(translate-expression test)
,(translate-expression arg-type then) ,(translate-expression then)
,(translate-expression arg-type else))) ,(translate-expression else)))
(at stx `(if ,(translate-expression arg-type test) (at stx `(if ,(translate-expression test)
,(translate-expression arg-type then) ,(translate-expression then)
,void-value)))] ,void-value)))]
[(struct honu:cond (stx clauses else)) [(struct honu:cond (stx clauses else))
(if else (if else
(at stx `(cond ,@(map (lambda (c) (at stx `(cond ,@(map (lambda (c)
`(,(translate-expression arg-type (honu:cond-clause-pred c)) `(,(translate-expression (honu:cond-clause-pred c))
,(translate-expression arg-type (honu:cond-clause-rhs c)))) ,(translate-expression (honu:cond-clause-rhs c))))
clauses) clauses)
(else ,(translate-expression arg-type else)))) (else ,(translate-expression else))))
(at stx `(cond ,@(map (lambda (c) (at stx `(cond ,@(map (lambda (c)
`(,(translate-expression arg-type (honu:cond-clause-pred c)) `(,(translate-expression (honu:cond-clause-pred c))
,(translate-expression arg-type (honu:cond-clause-rhs c)))) ,(translate-expression (honu:cond-clause-rhs c))))
clauses) clauses)
(else ,void-value))))] (else ,void-value))))]
[(struct honu:un-op (stx op op-stx op-type arg)) [(struct honu:un-op (stx op op-stx op-type arg))
(case op (case op
[(not) [(not)
(at stx (at stx
`(,(at op-stx 'not) ,(translate-expression arg-type arg)))] `(,(at op-stx 'not) ,(translate-expression arg)))]
[(minus) [(minus)
(at stx (at stx
`(,(at op-stx '-) ,(translate-expression arg-type arg)))] `(,(at op-stx '-) ,(translate-expression arg)))]
[else (raise-read-error-with-stx [else (raise-read-error-with-stx
"Haven't translated unary operator yet." "Haven't translated unary operator yet."
op-stx)])] op-stx)])]
@ -78,239 +74,231 @@
(eqv? (honu:type-prim-name op-type) 'string)) (eqv? (honu:type-prim-name op-type) 'string))
(at stx (at stx
`(,(at op-stx 'string=?) `(,(at op-stx 'string=?)
,(translate-expression arg-type larg) ,(translate-expression larg)
,(translate-expression arg-type rarg))) ,(translate-expression rarg)))
(at stx (at stx
`(,(at op-stx 'eqv?) `(,(at op-stx 'eqv?)
,(translate-expression arg-type larg) ,(translate-expression larg)
,(translate-expression arg-type rarg))))] ,(translate-expression rarg))))]
[(neq) [(neq)
(if (and (honu:type-prim? op-type) (if (and (honu:type-prim? op-type)
(eqv? (honu:type-prim-name op-type) 'string)) (eqv? (honu:type-prim-name op-type) 'string))
(at stx (at stx
`(,(at op-stx 'not) `(,(at op-stx 'not)
(,(at op-stx 'string=?) (,(at op-stx 'string=?)
,(translate-expression arg-type larg) ,(translate-expression larg)
,(translate-expression arg-type rarg)))) ,(translate-expression rarg))))
(at stx (at stx
`(,(at op-stx 'not) `(,(at op-stx 'not)
(,(at op-stx 'eqv?) (,(at op-stx 'eqv?)
,(translate-expression arg-type larg) ,(translate-expression larg)
,(translate-expression arg-type rarg)))))] ,(translate-expression rarg)))))]
[(clseq) [(clseq)
(at stx (at stx
`(,(at op-stx 'equal?) `(,(at op-stx 'equal?)
,(translate-expression arg-type larg) ,(translate-expression larg)
,(translate-expression arg-type rarg)))] ,(translate-expression rarg)))]
[(and) [(and)
(at stx (at stx
`(,(at op-stx 'and) `(,(at op-stx 'and)
,(translate-expression arg-type larg) ,(translate-expression larg)
,(translate-expression arg-type rarg)))] ,(translate-expression rarg)))]
[(or) [(or)
(at stx (at stx
`(,(at op-stx 'or) `(,(at op-stx 'or)
,(translate-expression arg-type larg) ,(translate-expression larg)
,(translate-expression arg-type rarg)))] ,(translate-expression rarg)))]
[(lt) [(lt)
(case (honu:type-prim-name op-type) (case (honu:type-prim-name op-type)
[(int float) [(int float)
(at stx (at stx
`(,(at op-stx '<) `(,(at op-stx '<)
,(translate-expression arg-type larg) ,(translate-expression larg)
,(translate-expression arg-type rarg)))] ,(translate-expression rarg)))]
[(string) [(string)
(at stx (at stx
`(,(at op-stx 'string<?) `(,(at op-stx 'string<?)
,(translate-expression arg-type larg) ,(translate-expression larg)
,(translate-expression arg-type rarg)))] ,(translate-expression rarg)))]
[(char) [(char)
(at stx (at stx
`(,(at op-stx 'char<?) `(,(at op-stx 'char<?)
,(translate-expression arg-type larg) ,(translate-expression larg)
,(translate-expression arg-type rarg)))])] ,(translate-expression rarg)))])]
[(le) [(le)
(case (honu:type-prim-name op-type) (case (honu:type-prim-name op-type)
[(int float) [(int float)
(at stx (at stx
`(,(at op-stx '<=) `(,(at op-stx '<=)
,(translate-expression arg-type larg) ,(translate-expression larg)
,(translate-expression arg-type rarg)))] ,(translate-expression rarg)))]
[(string) [(string)
(at stx (at stx
`(,(at op-stx 'string<=?) `(,(at op-stx 'string<=?)
,(translate-expression arg-type larg) ,(translate-expression larg)
,(translate-expression arg-type rarg)))] ,(translate-expression rarg)))]
[(char) [(char)
(at stx (at stx
`(,(at op-stx 'char<=?) `(,(at op-stx 'char<=?)
,(translate-expression arg-type larg) ,(translate-expression larg)
,(translate-expression arg-type rarg)))])] ,(translate-expression rarg)))])]
[(gt) [(gt)
(case (honu:type-prim-name op-type) (case (honu:type-prim-name op-type)
[(int float) [(int float)
(at stx (at stx
`(,(at op-stx '>) `(,(at op-stx '>)
,(translate-expression arg-type larg) ,(translate-expression larg)
,(translate-expression arg-type rarg)))] ,(translate-expression rarg)))]
[(string) [(string)
(at stx (at stx
`(,(at op-stx 'string>?) `(,(at op-stx 'string>?)
,(translate-expression arg-type larg) ,(translate-expression larg)
,(translate-expression arg-type rarg)))] ,(translate-expression rarg)))]
[(char) [(char)
(at stx (at stx
`(,(at op-stx 'char>?) `(,(at op-stx 'char>?)
,(translate-expression arg-type larg) ,(translate-expression larg)
,(translate-expression arg-type rarg)))])] ,(translate-expression rarg)))])]
[(ge) [(ge)
(case (honu:type-prim-name op-type) (case (honu:type-prim-name op-type)
[(int float) [(int float)
(at stx (at stx
`(,(at op-stx '>=) `(,(at op-stx '>=)
,(translate-expression arg-type larg) ,(translate-expression larg)
,(translate-expression arg-type rarg)))] ,(translate-expression rarg)))]
[(string) [(string)
(at stx (at stx
`(,(at op-stx 'string>=?) `(,(at op-stx 'string>=?)
,(translate-expression arg-type larg) ,(translate-expression larg)
,(translate-expression arg-type rarg)))] ,(translate-expression rarg)))]
[(char) [(char)
(at stx (at stx
`(,(at op-stx 'char>=?) `(,(at op-stx 'char>=?)
,(translate-expression arg-type larg) ,(translate-expression larg)
,(translate-expression arg-type rarg)))])] ,(translate-expression rarg)))])]
[(plus) [(plus)
(case (honu:type-prim-name op-type) (case (honu:type-prim-name op-type)
[(int float) [(int float)
(at stx (at stx
`(,(at op-stx '+) `(,(at op-stx '+)
,(translate-expression arg-type larg) ,(translate-expression larg)
,(translate-expression arg-type rarg)))] ,(translate-expression rarg)))]
[(string) [(string)
(at stx (at stx
`(,(at op-stx 'string-append) `(,(at op-stx 'string-append)
,(translate-expression arg-type larg) ,(translate-expression larg)
,(translate-expression arg-type rarg)))])] ,(translate-expression rarg)))])]
[(minus) [(minus)
(at stx (at stx
`(,(at op-stx '-) `(,(at op-stx '-)
,(translate-expression arg-type larg) ,(translate-expression larg)
,(translate-expression arg-type rarg)))] ,(translate-expression rarg)))]
[(times) [(times)
(at stx (at stx
`(,(at op-stx '*) `(,(at op-stx '*)
,(translate-expression arg-type larg) ,(translate-expression larg)
,(translate-expression arg-type rarg)))] ,(translate-expression rarg)))]
[(div) [(div)
(case (honu:type-prim-name op-type) (case (honu:type-prim-name op-type)
[(int) [(int)
(at stx (at stx
`(,(at op-stx 'quotient) `(,(at op-stx 'quotient)
,(translate-expression arg-type larg) ,(translate-expression larg)
,(translate-expression arg-type rarg)))] ,(translate-expression rarg)))]
[(float) [(float)
(at stx (at stx
`(,(at op-stx '/) `(,(at op-stx '/)
,(translate-expression arg-type larg) ,(translate-expression larg)
,(translate-expression arg-type rarg)))])] ,(translate-expression rarg)))])]
[(mod) [(mod)
(at stx (at stx
`(,(at op-stx 'remainder) `(,(at op-stx 'remainder)
,(translate-expression arg-type larg) ,(translate-expression larg)
,(translate-expression arg-type rarg)))] ,(translate-expression rarg)))]
[else (raise-read-error-with-stx [else (raise-read-error-with-stx
"Haven't translated binary operator yet." "Haven't translated binary operator yet."
op-stx)])] op-stx)])]
[(struct honu:return (stx body)) [(struct honu:return (stx body))
(at stx (at stx
`(last-k ,(translate-expression arg-type body)))] `(last-k ,(translate-expression body)))]
[(struct honu:let (stx bindings body)) [(struct honu:let (stx bindings body))
(at stx (at stx
`(let*-values ,(map (lambda (b) `(let*-values ,(map (lambda (b)
(let-values ([(bound-names body) (let-values ([(bound-names body)
(translate-binding-clause (honu:binding-names b) (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, ;; make sure to give the let binding the appropriate syntax,
;; otherwise errors will highlight the entire let expression. ;; otherwise errors will highlight the entire let expression.
(at (honu:ast-stx b) `(,bound-names ,body)))) (at (honu:ast-stx b) `(,bound-names ,body))))
bindings) bindings)
,(translate-expression arg-type body)))] ,(translate-expression body)))]
[(struct honu:seq (stx effects value)) [(struct honu:seq (stx effects value))
(at stx (at stx
`(begin ,@(map (lambda (e) `(begin ,@(map translate-expression effects)
(translate-expression arg-type e)) ,(translate-expression value)))]
effects)
,(translate-expression arg-type value)))]
[(struct honu:while (stx test body)) [(struct honu:while (stx test body))
(at stx (at stx
`(let loop () `(let loop ()
(if ,(translate-expression arg-type test) (if ,(translate-expression test)
(begin ,(translate-expression arg-type body) (loop)) (begin ,(translate-expression body) (loop))
,void-value)))] ,void-value)))]
[(struct honu:assn (stx lhs rhs)) [(struct honu:assn (stx lhs rhs))
(match lhs (match lhs
[(struct honu:var (_ _)) [(struct honu:var (_ _))
(at stx `(begin (set! ,(translate-expression arg-type lhs) (at stx `(begin (set! ,(translate-expression lhs)
,(translate-expression arg-type rhs)) ,(translate-expression rhs))
,void-value))] ,void-value))]
[(struct honu:member (mstx 'my _ name method?)) [(struct honu:member (mstx 'my _ name method?))
(if method? (if method?
(raise-read-error-with-stx (raise-read-error-with-stx
"Left-hand side of assignment cannot be a method name" "Left-hand side of assignment cannot be a method name"
mstx) mstx)
(at stx (translate-static-field-setter arg-type name (at stx (translate-static-field-setter name (translate-expression rhs))))]
(translate-expression arg-type rhs))))]
[(struct honu:member (mstx obj elab name method?)) [(struct honu:member (mstx obj elab name method?))
(if method? (if method?
(raise-read-error-with-stx (raise-read-error-with-stx
"Left-hand side of assignment cannot be a method name" "Left-hand side of assignment cannot be a method name"
mstx) mstx)
(at stx `(honu:send ,(translate-expression arg-type obj) (at stx `(honu:send ,(translate-expression obj)
,(translate-field-setter-name elab name) ,(translate-field-setter-name elab name)
,(translate-expression arg-type rhs))))] ,(translate-expression rhs))))]
[else [else
(raise-read-error-with-stx (raise-read-error-with-stx
"Left-hand side of assignment is invalid" "Left-hand side of assignment is invalid"
stx)])] stx)])]
[(struct honu:member (stx 'my _ name method?)) [(struct honu:member (stx 'my _ name method?))
(if method? (if method?
(at stx (translate-static-method arg-type name)) (at stx (translate-static-method name))
(at stx (translate-static-field-getter arg-type name)))] (at stx (translate-static-field-getter name)))]
[(struct honu:member (stx obj elab name method?)) [(struct honu:member (stx obj elab name method?))
(if method? (if method?
(at stx `(lambda (args) (at stx `(lambda (args)
(honu:send ,(translate-expression arg-type obj) (honu:send ,(translate-expression obj)
,(translate-method-name elab name) ,(translate-method-name elab name)
args))) args)))
(at stx `(honu:send ,(translate-expression arg-type obj) (at stx `(honu:send ,(translate-expression obj)
,(translate-field-getter-name elab name) ,(translate-field-getter-name elab name)
,void-value)))] ,void-value)))]
[(struct honu:new (stx class _ args)) [(struct honu:new (stx class _ args))
(at stx `(new ,(translate-class-name class) (at stx `(new ,(translate-class-name class)
,@(map (lambda (a) ,@(map (lambda (a)
`(,(honu:name-arg-name a) `(,(honu:name-arg-name a)
,(translate-expression arg-type (honu:name-arg-value a)))) ,(translate-expression (honu:name-arg-value a))))
args)))] args)))]
[(struct honu:cast (stx obj type)) [(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 ;; you can always cast null to an interface type
(if (or (is-a? cast-obj null%) (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 cast-obj
;; we can use object-info and class-info since we always set (inspect #f) (error (format "Class ~a does not implement ~a"
;; we have to do that for the moment anyway for "extensional" class equality. (honu:send cast-obj format-class-name)
(let*-values ([(class dc-1) (object-info cast-obj)] (quote ,(syntax-e (iface-name type))))))))]
[(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))))))))]
[(struct honu:isa (stx obj 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 ;; null is a member of any interface type
(or (is-a? cast-obj null%) (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)) [(struct honu:this (stx))
(at stx 'this)] (at stx 'this)]
[else (raise-read-error-with-stx [else (raise-read-error-with-stx

7
collects/honu/private/compiler/translate-parameters.ss Normal file
View File

@ -0,0 +1,7 @@
(module translate-parameters mzscheme
(provide (all-defined))
(define current-mixin-argument-type (make-parameter #f))
)

29
collects/honu/private/compiler/translate-utils.ss
View File

@ -4,7 +4,8 @@
(lib "contract.ss") (lib "contract.ss")
"../../ast.ss" "../../ast.ss"
"../../parameters.ss" "../../parameters.ss"
"../../tenv.ss") "../../tenv.ss"
"translate-parameters.ss")
(define stx-for-original-property (read-syntax #f (open-input-string "original"))) (define stx-for-original-property (read-syntax #f (open-input-string "original")))
@ -91,17 +92,17 @@
"-set!")))) "-set!"))))
(provide translate-static-method translate-static-field-getter translate-static-field-setter) (provide translate-static-method translate-static-field-getter translate-static-field-setter)
(define (translate-static-method arg-type name arg) (define (translate-static-method name arg)
(if arg-type (if (current-mixin-argument-type)
(let ([type-entry (get-type-entry arg-type)]) (let ([type-entry (get-type-entry (current-mixin-argument-type))])
(if (s:member name (if (s:member name
(map tenv:member-name (append (tenv:type-members type-entry) (map tenv:member-name (append (tenv:type-members type-entry)
(tenv:type-inherited type-entry))) (tenv:type-inherited type-entry)))
tenv-key=?) tenv-key=?)
(if arg (if arg
`(super ,(translate-method-name arg-type name) ,arg) `(super ,(translate-method-name (current-mixin-argument-type) name) ,arg)
`(lambda (arg-tuple) `(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 (if arg
`(,(at-ctxt name) ,arg) `(,(at-ctxt name) ,arg)
(at-ctxt name)))) (at-ctxt name))))
@ -109,25 +110,25 @@
`(,(at-ctxt name) ,arg) `(,(at-ctxt name) ,arg)
(at-ctxt name)))) (at-ctxt name))))
(define (translate-static-field-getter arg-type name) (define (translate-static-field-getter name)
(if arg-type (if (current-mixin-argument-type)
(let ([type-entry (get-type-entry arg-type)]) (let ([type-entry (get-type-entry (current-mixin-argument-type))])
(if (s:member name (if (s:member name
(map tenv:member-name (append (tenv:type-members type-entry) (map tenv:member-name (append (tenv:type-members type-entry)
(tenv:type-inherited type-entry))) (tenv:type-inherited type-entry)))
tenv-key=?) 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)))
(at-ctxt name))) (at-ctxt name)))
(define (translate-static-field-setter arg-type name arg) (define (translate-static-field-setter name arg)
(if arg-type (if (current-mixin-argument-type)
(let ([type-entry (get-type-entry arg-type)]) (let ([type-entry (get-type-entry (current-mixin-argument-type))])
(if (s:member name (if (s:member name
(map tenv:member-name (append (tenv:type-members type-entry) (map tenv:member-name (append (tenv:type-members type-entry)
(tenv:type-inherited type-entry))) (tenv:type-inherited type-entry)))
tenv-key=?) 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) `(begin (set! ,(at-ctxt name) ,arg)
,void-value))) ,void-value)))
`(begin (set! ,(at-ctxt name) ,arg) `(begin (set! ,(at-ctxt name) ,arg)

111
collects/honu/private/compiler/translate.ss
View File

@ -9,6 +9,7 @@
"../typechecker/type-utils.ss" "../typechecker/type-utils.ss"
"translate-class-utils.ss" "translate-class-utils.ss"
"translate-expression.ss" "translate-expression.ss"
"translate-parameters.ss"
"translate-utils.ss") "translate-utils.ss")
(provide/contract [translate ((listof honu:defn?) (provide/contract [translate ((listof honu:defn?)
@ -53,10 +54,10 @@
(define (translate-defn defn) (define (translate-defn defn)
(match defn (match defn
[(struct honu:bind-top (stx names _ value)) [(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)))] (at stx `(define-values ,bound-names ,body)))]
[(struct honu:function (stx name _ args 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)) [(struct honu:iface (stx name supers members))
(at stx `(define ,(translate-iface-name (make-iface-type name name)) (at stx `(define ,(translate-iface-name (make-iface-type name name))
(interface ,(if (null? supers) (interface ,(if (null? supers)
@ -68,10 +69,10 @@
(class* object% ,(map translate-iface-name impls) (class* object% ,(map translate-iface-name impls)
(inspect #f) (inspect #f)
,(translate-inits inits) ,(translate-inits inits)
,@(map (lambda (m) ,@(map translate-member members)
(translate-member #f m)) members)
,@(translate-class-exports exports) ,@(translate-class-exports exports)
,(translate-formatter name members #f) ,(translate-impl-method impls)
,(translate-formatter name members)
(super-new))))] (super-new))))]
[else (raise-read-error-with-stx [else (raise-read-error-with-stx
"Haven't translated that type of definition yet." "Haven't translated that type of definition yet."
@ -81,51 +82,59 @@
(match (list 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 _ arg-type _ impls inits _ super-new members-before members-after exports))
(struct honu:subclass (stx name base mixin))) (struct honu:subclass (stx name base mixin)))
(let* ([base-entry (get-class-entry base)] (parameterize ([current-mixin-argument-type arg-type])
[base-types (cons (tenv:class-sub-type base-entry) (let* ([base-entry (get-class-entry base)]
(tenv:class-impls base-entry))]) [base-types (cons (tenv:class-sub-type base-entry)
(at stx `(define ,(translate-class-name name) (tenv:class-impls base-entry))])
(class* ,(translate-class-name base) ,(map translate-iface-name impls) (at stx `(define ,(translate-class-name name)
(inspect #f) (class* ,(translate-class-name base) ,(map translate-iface-name impls)
,(translate-inits inits) (inspect #f)
,@(map (lambda (m) ,(translate-inits inits)
(translate-member arg-type m)) members-before) ,@(map translate-member members-before)
,(translate-super-new arg-type super-new) ,(translate-super-new super-new)
,@(map (lambda (m) ,@(map translate-member members-after)
(translate-member arg-type m)) members-after) ,@(translate-subclass-exports base-types exports)
,@(translate-subclass-exports base-types arg-type exports) ,(translate-impl-method impls)
,(translate-formatter name (append members-before members-after) arg-type)))))])) ,(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) (define (translate-formatter name members)
(let ([right-define (if arg-type 'define/override 'define/public)]) (let ([right-define (if (current-mixin-argument-type) 'define/override 'define/public)])
`(,right-define (format-class renderer indent print-fields?) `(begin
(if print-fields? (,right-define (format-class-name)
(format "~a {~a}" ,(format "~a" (syntax-e name)))
(quote ,(syntax-e name)) (,right-define (format-class renderer indent)
,(cons 'string-append (format "~a {~a}"
(let ([printable-members (filter (lambda (m) (format-class-name)
(not (honu:method? m))) ,(cons 'string-append
members)] (let ([printable-members (filter (lambda (m)
[printable-smembers (if arg-type (not (honu:method? m)))
(filter-map (lambda (m) members)]
(if (not (honu:type-disp? (tenv:member-type m))) [printable-smembers (if (current-mixin-argument-type)
(tenv:member-name m) (filter-map (lambda (m)
#f)) (if (not (honu:type-disp? (tenv:member-type m)))
(tenv:type-members (get-type-entry arg-type))) (tenv:member-name m)
'())] #f))
;; how much more do we want the members indented? Let's try 2 spaces more. (tenv:type-members (get-type-entry (current-mixin-argument-type))))
[indent-delta 2]) '())]
(if (and (null? printable-members) ;; how much more do we want the members indented? Let's try 2 spaces more.
(null? printable-smembers)) [indent-delta 2])
'("") (if (and (null? printable-members)
(fold-right (lambda (m l) (null? printable-smembers))
(list* "\n" (translate-super-member-formatter arg-type m indent-delta) l)) '("")
(fold-right (lambda (m l) (fold-right (lambda (m l)
(list* "\n" (translate-member-formatter m indent-delta) l)) (list* "\n" (translate-super-member-formatter m indent-delta) l))
'("\n" (make-string indent #\space)) (fold-right (lambda (m l)
printable-members) (list* "\n" (translate-member-formatter m indent-delta) l))
printable-smembers))))) '("\n" (make-string indent #\space))
(format "~a" (quote ,(syntax-e name))))))) printable-members)
printable-smembers)))))))))
(define (translate-member-formatter member indent-delta) (define (translate-member-formatter member indent-delta)
(let ([name (if (honu:field? member) (let ([name (if (honu:field? member)
@ -137,11 +146,11 @@
;; the 3 is for " = " ;; the 3 is for " = "
(renderer ,name (+ indent ,(+ indent-delta (string-length (symbol->string (syntax-e name))) 3)))))) (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;" `(format "~a~a = ~a;"
(make-string (+ indent ,indent-delta) #\space) (make-string (+ indent ,indent-delta) #\space)
(quote ,(syntax-e name)) (quote ,(syntax-e name))
;; as before, the 3 is for " = " ;; 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))))) (+ indent ,(+ indent-delta (string-length (symbol->string (syntax-e name))) 3)))))
) )

6
collects/honu/private/typechecker/type-utils.ss
View File

@ -255,6 +255,12 @@
(tenv:type-supers type-entry))))] (tenv:type-supers type-entry))))]
[else #f])) [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) (provide raise-honu-type-error)
(define (raise-honu-type-error stx expected received) (define (raise-honu-type-error stx expected received)
(raise-read-error-with-stx (raise-read-error-with-stx

7
collects/honu/tool.ss
View File

@ -214,11 +214,12 @@
(cdr value)) (cdr value))
")"))] ")"))]
[(is-a? value null%) "null"] [(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?) (lambda (value at-top?)
(format-honu-value value settings at-top?)) (format-honu-value value settings at-top?))
indent indent)
(eqv? (honu-settings-display-style settings) 'field))] (send value format-class-name))]
[else (format "~a" value)])) [else (format "~a" value)]))
;Set the Honu editing colors ;Set the Honu editing colors