267 lines
12 KiB
Scheme
267 lines
12 KiB
Scheme
(module honu-translate-expression mzscheme
|
|
|
|
(require (all-except (lib "list.ss" "srfi" "1") any)
|
|
(lib "contract.ss")
|
|
(lib "plt-match.ss"))
|
|
|
|
(require "../../ast.ss")
|
|
(require "../../tenv.ss")
|
|
(require "honu-translate-utils.ss")
|
|
(require "../../read-error-with-stx.ss")
|
|
|
|
(define (get-builtin-translation name)
|
|
; (case (printable-key name)
|
|
; [(println) (at name '(lambda (s) (display s) (newline)))]
|
|
; [(error) (at name '(lambda (s) (error s)))]))
|
|
;; since we can change the context of identifiers, just make
|
|
;; sure that the appropriate things are bound in honu-compile-context.
|
|
(at-ctxt name))
|
|
|
|
(define (field-in-defn? field defn)
|
|
(or (find (lambda (n)
|
|
(tenv-key=? n field))
|
|
(cond
|
|
[(honu-class? defn) (honu-class-init-names defn)]
|
|
[(honu-mixin? defn) (honu-mixin-init-names defn)]))
|
|
(find (match-lambda
|
|
[(struct honu-field (_ name _ _))
|
|
(tenv-key=? name field)]
|
|
[(struct honu-init-field (_ name _ _))
|
|
(tenv-key=? name field)]
|
|
[_ #f])
|
|
(cond
|
|
[(honu-class? defn) (honu-class-defns defn)]
|
|
[(honu-mixin? defn) (append (honu-mixin-defns-before defn)
|
|
(honu-mixin-defns-after defn))]))))
|
|
|
|
(provide/contract [honu-translate-expression
|
|
(tenv?
|
|
(union false/c
|
|
honu-defn?)
|
|
honu-exp?
|
|
. -> .
|
|
; (syntax/c any/c))])
|
|
any)])
|
|
(define (honu-translate-expression tenv defn exp)
|
|
(match exp
|
|
[(struct honu-null (stx))
|
|
(at stx 'null)]
|
|
|
|
[(struct honu-int (stx val))
|
|
(at stx val)]
|
|
[(struct honu-float (stx val))
|
|
(at stx val)]
|
|
[(struct honu-char (stx val))
|
|
(at stx val)]
|
|
[(struct honu-str (stx val))
|
|
(at stx val)]
|
|
[(struct honu-bool (stx val))
|
|
(at stx val)]
|
|
|
|
[(struct honu-var (stx name builtin?))
|
|
(if builtin?
|
|
(get-builtin-translation name)
|
|
name)]
|
|
[(struct honu-this (stx))
|
|
(at stx 'this)]
|
|
|
|
[(struct honu-uprim (stx op op-stx op-type body))
|
|
(let ((body-exp (honu-translate-expression tenv defn body)))
|
|
(case op
|
|
[(not)
|
|
(at stx `(,(at op-stx 'not) ,body-exp))]
|
|
[(minus)
|
|
(at stx `(,(at op-stx '-) ,body-exp))]))]
|
|
[(struct honu-prim (stx op op-stx op-type left right))
|
|
(let ((left-exp (honu-translate-expression tenv defn left))
|
|
(right-exp (honu-translate-expression tenv defn right)))
|
|
(case op
|
|
[(plus)
|
|
(if (eqv? 'str (honu-prim-type-name op-type))
|
|
(at stx `(,(at op-stx 'string-append) ,left-exp ,right-exp))
|
|
(at stx `(,(at op-stx '+) ,left-exp ,right-exp)))]
|
|
[(minus)
|
|
(at stx `(,(at op-stx '-) ,left-exp ,right-exp))]
|
|
[(times)
|
|
(at stx `(,(at op-stx '*) ,left-exp ,right-exp))]
|
|
[(div)
|
|
(if (eqv? 'float (honu-prim-type-name op-type))
|
|
(at stx `(,(at op-stx '/) ,left-exp ,right-exp))
|
|
(at stx `(,(at op-stx 'quotient) ,left-exp ,right-exp)))]
|
|
[(mod)
|
|
(at stx `(,(at op-stx 'modulo) ,left-exp ,right-exp))]
|
|
[(lt)
|
|
(case (honu-prim-type-name op-type)
|
|
[(int float)
|
|
(at stx `(,(at op-stx '<) ,left-exp ,right-exp))]
|
|
[(string)
|
|
(at stx `(,(at op-stx 'string<?) ,left-exp ,right-exp))]
|
|
[(char)
|
|
(at stx `(,(at op-stx 'char<?) ,left-exp ,right-exp))])]
|
|
[(le)
|
|
(case (honu-prim-type-name op-type)
|
|
[(int float)
|
|
(at stx `(,(at op-stx '<=) ,left-exp ,right-exp))]
|
|
[(string)
|
|
(at stx `(,(at op-stx 'string<=?) ,left-exp ,right-exp))]
|
|
[(char)
|
|
(at stx `(,(at op-stx 'char<=?) ,left-exp ,right-exp))])]
|
|
[(gt)
|
|
(case (honu-prim-type-name op-type)
|
|
[(int float)
|
|
(at stx `(,(at op-stx '>) ,left-exp ,right-exp))]
|
|
[(string)
|
|
(at stx `(,(at op-stx 'string>?) ,left-exp ,right-exp))]
|
|
[(char)
|
|
(at stx `(,(at op-stx 'char>?) ,left-exp ,right-exp))])]
|
|
[(ge)
|
|
(case (honu-prim-type-name op-type)
|
|
[(int float)
|
|
(at stx `(,(at op-stx '>=) ,left-exp ,right-exp))]
|
|
[(string)
|
|
(at stx `(,(at op-stx 'string>=?) ,left-exp ,right-exp))]
|
|
[(char)
|
|
(at stx `(,(at op-stx 'char>=?) ,left-exp ,right-exp))])]
|
|
[(and)
|
|
(at stx `(,(at op-stx 'and) ,left-exp ,right-exp))]
|
|
[(or)
|
|
(at stx `(,(at op-stx 'or) ,left-exp ,right-exp))]
|
|
[(clseq)
|
|
(at stx `(,(at op-stx 'equal?) ,left-exp ,right-exp))]
|
|
[(equal)
|
|
(if (and (honu-prim-type? op-type)
|
|
(eqv? 'str (honu-prim-type-name op-type)))
|
|
(at stx `(,(at op-stx 'string=?) ,left-exp ,right-exp))
|
|
(at stx `(,(at op-stx 'eqv?) ,left-exp ,right-exp)))]
|
|
[(neq)
|
|
(if (and (honu-prim-type? op-type)
|
|
(eqv? 'str (honu-prim-type-name op-type)))
|
|
(at stx `(,(at op-stx 'not) (,(at op-stx 'string=?) ,left-exp ,right-exp)))
|
|
(at stx `(,(at op-stx 'not) (,(at op-stx 'eqv?) ,left-exp ,right-exp))))]))]
|
|
|
|
[(struct honu-lambda (stx arg-names _ body))
|
|
(at stx `(lambda ,(map (lambda (n) (at-ctxt n)) arg-names)
|
|
,(honu-translate-expression tenv defn body)))]
|
|
|
|
[(struct honu-assn (stx name rhs))
|
|
(at stx `(set! ,(at-ctxt name)
|
|
,(honu-translate-expression tenv defn rhs)))]
|
|
[(struct honu-call (stx name args builtin?))
|
|
(let ([f (if builtin?
|
|
(get-builtin-translation name)
|
|
(at-ctxt name))])
|
|
(at stx (cons f (map (lambda (e)
|
|
(honu-translate-expression tenv defn e))
|
|
args))))]
|
|
|
|
[(struct honu-facc (stx obj elab field))
|
|
(if (eqv? obj 'my)
|
|
(if (field-in-defn? field defn)
|
|
(at stx field)
|
|
(at stx `(super ,(honu-translate-dynamic-field-getter tenv
|
|
field
|
|
(honu-mixin-arg-type defn)))))
|
|
(at stx `(send ,(honu-translate-expression tenv defn obj)
|
|
,(honu-translate-dynamic-field-getter tenv field elab))))]
|
|
[(struct honu-fassn (stx obj elab field rhs))
|
|
(if (eqv? (honu-fassn-obj exp) 'my)
|
|
(if (field-in-defn? field defn)
|
|
(at stx `(set! ,(at-ctxt field)
|
|
,(honu-translate-expression tenv defn rhs)))
|
|
(at stx `(super ,(honu-translate-dynamic-field-setter tenv
|
|
field
|
|
(honu-mixin-arg-type defn))
|
|
,(honu-translate-expression tenv defn rhs))))
|
|
(at stx `(send ,(honu-translate-expression tenv defn obj)
|
|
,(honu-translate-dynamic-field-setter tenv field elab)
|
|
,(honu-translate-expression tenv defn rhs))))]
|
|
[(struct honu-mcall (stx obj elab method args))
|
|
(if (eqv? obj 'my)
|
|
(if (find (match-lambda
|
|
[(struct honu-method (_ name _ _ _ _))
|
|
(tenv-key=? name method)]
|
|
[_ #f])
|
|
(cond
|
|
[(honu-class? defn) (honu-class-defns defn)]
|
|
[(honu-mixin? defn) (append (honu-mixin-defns-before defn)
|
|
(honu-mixin-defns-after defn))]))
|
|
(at stx `(,(at-ctxt method)
|
|
,@(map (lambda (e)
|
|
(honu-translate-expression tenv defn e))
|
|
args)))
|
|
(at stx `(super ,(honu-translate-dynamic-method-name tenv
|
|
method
|
|
(honu-mixin-arg-type defn))
|
|
,@(map (lambda (e)
|
|
(honu-translate-expression tenv defn e))
|
|
args))))
|
|
(at stx `(send ,(honu-translate-expression tenv defn obj)
|
|
,(honu-translate-dynamic-method-name tenv method elab)
|
|
,@(map (lambda (e)
|
|
(honu-translate-expression tenv defn e))
|
|
args))))]
|
|
|
|
[(struct honu-cast (stx obj type))
|
|
(let ([cast-type (honu-translate-type-name type)])
|
|
(if cast-type
|
|
(at stx `(let ((cast-obj ,(honu-translate-expression tenv defn obj)))
|
|
(if (is-a? cast-obj ,cast-type)
|
|
cast-obj
|
|
(error "Cast failed!"))))
|
|
(honu-translate-expression tenv defn obj)))]
|
|
[(struct honu-isa (stx obj type))
|
|
(let ([isa-type (honu-translate-type-name type)])
|
|
(if isa-type
|
|
(at stx `(is-a? ,(honu-translate-expression tenv defn obj)
|
|
,isa-type))
|
|
(honu-translate-expression tenv defn (make-honu-bool stx #t))))]
|
|
|
|
[(struct honu-new (stx class type arg-names arg-vals))
|
|
(at stx `(new ,(honu-translate-class-name class)
|
|
,@(map (lambda (a b) (list a (honu-translate-expression tenv defn b)))
|
|
arg-names
|
|
arg-vals)))]
|
|
|
|
[(struct honu-if (stx cond true false))
|
|
(at stx `(if ,(honu-translate-expression tenv defn cond)
|
|
,(honu-translate-expression tenv defn true)
|
|
,(honu-translate-expression tenv defn false)))]
|
|
|
|
[(struct honu-while (stx cond body))
|
|
(at stx `(let loop ()
|
|
(if ,(honu-translate-expression tenv defn cond)
|
|
(begin ,(honu-translate-expression tenv defn body)
|
|
(loop)))))]
|
|
|
|
[(struct honu-return (stx body))
|
|
(at stx (if body
|
|
(honu-translate-expression tenv defn body)
|
|
`(void)))]
|
|
[(struct honu-block (stx binds exps))
|
|
(at stx `(let* ,(map (lambda (b)
|
|
(honu-translate-binding tenv defn b #f))
|
|
binds)
|
|
,@(map (lambda (e)
|
|
(honu-translate-expression tenv defn e))
|
|
exps)))]))
|
|
|
|
(provide/contract [honu-translate-binding
|
|
(tenv?
|
|
(union false/c
|
|
honu-defn?)
|
|
honu-binding?
|
|
(union false/c
|
|
(lambda (b) (eq? #t b)))
|
|
. -> .
|
|
; (syntax/c any/c))])
|
|
any)])
|
|
(define (honu-translate-binding tenv defn bnd top-level?)
|
|
(match bnd
|
|
[(struct honu-binding (stx name _ rhs))
|
|
(if top-level?
|
|
(at stx `(define ,name
|
|
,(honu-translate-expression tenv defn rhs)))
|
|
(at stx `[,(at-ctxt name) ,(honu-translate-expression tenv defn rhs)]))]))
|
|
)
|
|
|