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
This commit is contained in:
Stevie Strickland
parent
541cf4b7ad
commit
cc8ee7ac3a
|
|
@ -79,5 +79,6 @@
|
|||
[else (string-ref s i)])))
|
||||
|
||||
(provide (all-from mzscheme)
|
||||
(rename ormap mz:ormap)
|
||||
(all-from (lib "class.ss"))
|
||||
(all-defined)))
|
||||
|
|
|
|||
|
|
@ -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)))])))
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -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))]))
|
||||
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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)))]
|
||||
[(char)
|
||||
(at stx
|
||||
`(,(at op-stx 'char<?)
|
||||
,(translate-expression arg-type larg)
|
||||
,(translate-expression arg-type rarg)))])]
|
||||
,(translate-expression larg)
|
||||
,(translate-expression rarg)))])]
|
||||
[(le)
|
||||
(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)))])]
|
||||
[(gt)
|
||||
(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)))])]
|
||||
[(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
|
||||
|
|
|
|||
7
collects/honu/private/compiler/translate-parameters.ss
Normal file
7
collects/honu/private/compiler/translate-parameters.ss
Normal file
|
|
@ -0,0 +1,7 @@
|
|||
(module translate-parameters mzscheme
|
||||
|
||||
(provide (all-defined))
|
||||
|
||||
(define current-mixin-argument-type (make-parameter #f))
|
||||
|
||||
)
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
)
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user