Moving all the calculation for what needs to be dragged along kicking
and screaming into its own file, and now we stick that stuff into its own little space at the front of what translate returns so that it's seen by Check Syntax, but we can drop it like a hot potato when it comes time to run the compiled code. svn: r340
This commit is contained in:
Stevie Strickland
parent
e4dbf7ffd8
commit
2feaff9d19
|
|
@ -19,7 +19,7 @@
|
|||
(provide/contract [compile/defns
|
||||
(tenv? tenv? (listof honu:defn?)
|
||||
. -> .
|
||||
(listof (syntax/c any/c)))]
|
||||
(cons/c any/c (listof (syntax/c any/c))))]
|
||||
[compile/interaction
|
||||
((tenv?
|
||||
tenv?
|
||||
|
|
|
|||
|
|
@ -99,10 +99,9 @@
|
|||
|
||||
(define (translate-export in-super? export)
|
||||
(cons 'begin
|
||||
(cons `(honu:type ,(translate-type-for-syntax (comp:export-type export)))
|
||||
(map (lambda (b)
|
||||
(translate-exp-bind in-super? (comp:export-type export) b))
|
||||
(comp:export-binds export)))))
|
||||
(map (lambda (b)
|
||||
(translate-exp-bind in-super? (comp:export-type export) b))
|
||||
(comp:export-binds export))))
|
||||
|
||||
(define (translate-exp-bind in-super? type binding)
|
||||
(let ([right-defn (if in-super? 'define/override 'define/public)])
|
||||
|
|
@ -126,11 +125,9 @@
|
|||
(honu:super-new-args super-new)))))
|
||||
|
||||
(define (translate-inits inits)
|
||||
`(begin
|
||||
(honu:type ,@(map (lambda (i) (translate-type-for-syntax (honu:formal-type i))) inits))
|
||||
,(cons 'init (map (lambda (i)
|
||||
(at-ctxt (honu:formal-name i)))
|
||||
inits))))
|
||||
(cons 'init (map (lambda (i)
|
||||
(at-ctxt (honu:formal-name i)))
|
||||
inits)))
|
||||
|
||||
(define (mangle-init-name name)
|
||||
(at name (string->symbol (string-append "init-" (symbol->string (syntax-e name))))))
|
||||
|
|
@ -139,21 +136,15 @@
|
|||
(match member
|
||||
[(struct honu:init-field (stx name type value))
|
||||
(if value
|
||||
(at stx`(begin (honu:type ,(translate-type-for-syntax type))
|
||||
(init ([,(mangle-init-name name) ,(at-ctxt name)]
|
||||
(at stx`(begin (init ([,(mangle-init-name name) ,(at-ctxt name)]
|
||||
,(translate-expression value)))
|
||||
(define ,(at-ctxt name) ,(mangle-init-name))))
|
||||
(at stx `(begin (honu:type ,(translate-type-for-syntax type))
|
||||
(init ([,(mangle-init-name name) ,(at-ctxt name)]))
|
||||
(at stx `(begin (init ([,(mangle-init-name name) ,(at-ctxt name)]))
|
||||
(define ,(at-ctxt name) ,(mangle-init-name name)))))]
|
||||
[(struct honu:field (stx name type value))
|
||||
(at stx `(begin (honu:type ,(translate-type-for-syntax type))
|
||||
(define ,(at-ctxt name) ,(translate-expression value))))]
|
||||
(at stx `(define ,(at-ctxt name) ,(translate-expression value)))]
|
||||
[(struct honu:method (stx name type formals body))
|
||||
(at stx `(begin (honu:type ,(translate-type-for-syntax type))
|
||||
(honu:type ,@(map (lambda (f) (translate-type-for-syntax (honu:formal-type f))) formals))
|
||||
,(translate-function stx name formals
|
||||
(translate-expression body))))]))
|
||||
(translate-function stx name formals (translate-expression body))]))
|
||||
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -21,8 +21,7 @@
|
|||
;; list is a bindable name in Honu, so... we use list*, which isn't.
|
||||
(at stx `(list* ,@(map translate-expression args) ()))]
|
||||
[(struct honu:lambda (stx _ formals body))
|
||||
(at stx `(begin (honu:type ,@(map (lambda (f) (translate-type-for-syntax (honu:formal-type f))) formals))
|
||||
,(translate-function stx #f formals (translate-expression body))))]
|
||||
(translate-function stx #f formals (translate-expression body))]
|
||||
[(struct honu:call (stx func arg))
|
||||
(match func
|
||||
[(struct honu:member (stx 'my _ name #t))
|
||||
|
|
@ -230,9 +229,7 @@
|
|||
(translate-expression (honu:binding-value b)))])
|
||||
;; make sure to give the let binding the appropriate syntax,
|
||||
;; otherwise errors will highlight the entire let expression.
|
||||
(at (honu:ast-stx b) `(,bound-names (begin (honu:type ,@(map translate-type-for-syntax
|
||||
(honu:binding-types b)))
|
||||
,body)))))
|
||||
(at (honu:ast-stx b) `(,bound-names ,body))))
|
||||
bindings)
|
||||
,(translate-expression body)))]
|
||||
[(struct honu:seq (stx effects value))
|
||||
|
|
|
|||
161
collects/honu/private/compiler/translate-unwanted-types.ss
Normal file
161
collects/honu/private/compiler/translate-unwanted-types.ss
Normal file
|
|
@ -0,0 +1,161 @@
|
|||
(module translate-unwanted-types mzscheme
|
||||
|
||||
(require (lib "plt-match.ss")
|
||||
"../../ast.ss"
|
||||
"translate-utils.ss")
|
||||
|
||||
(provide build-unwanted-type-syntax)
|
||||
(define (build-unwanted-type-syntax defns)
|
||||
(map build-unwanted-type-syntax-defn defns))
|
||||
|
||||
;; since we're never going to run the result anyway, it doesn't matter
|
||||
;; how we build things -- no need to flatten.
|
||||
(define (build-unwanted-type-syntax-defn defn)
|
||||
(match defn
|
||||
[(struct honu:bind-top (_ _ types value))
|
||||
(cons (build-unwanted-type-syntax-expression value)
|
||||
(map translate-type-for-syntax types))]
|
||||
[(struct honu:function (_ _ type formals body))
|
||||
(list (translate-type-for-syntax type)
|
||||
(build-unwanted-type-syntax-expression body)
|
||||
(map (lambda (f)
|
||||
(translate-type-for-syntax (honu:formal-type f)))
|
||||
formals))]
|
||||
[(struct honu:iface (_ _ _ members))
|
||||
(map build-unwanted-type-syntax-member-decl members)]
|
||||
[(struct honu:class (_ _ selftype _ _ inits members exports))
|
||||
(list (translate-type-for-syntax selftype)
|
||||
(map (lambda (f)
|
||||
(translate-type-for-syntax (honu:formal-type f)))
|
||||
inits)
|
||||
(map build-unwanted-type-syntax-member members)
|
||||
(map (lambda (e)
|
||||
(translate-type-for-syntax (honu:export-type e)))
|
||||
exports))]
|
||||
[(struct honu:mixin (_ _ selftype arg-type _ _ inits withs super-new
|
||||
members-before members-after exports))
|
||||
(list (translate-type-for-syntax selftype)
|
||||
(translate-type-for-syntax arg-type)
|
||||
(map (lambda (f)
|
||||
(translate-type-for-syntax (honu:formal-type f)))
|
||||
inits)
|
||||
(map (lambda (f)
|
||||
(translate-type-for-syntax (honu:formal-type f)))
|
||||
withs)
|
||||
(map (lambda (a)
|
||||
(build-unwanted-type-syntax-expression (honu:name-arg-value a)))
|
||||
(honu:super-new-args super-new))
|
||||
(map build-unwanted-type-syntax-member members-before)
|
||||
(map build-unwanted-type-syntax-member members-after)
|
||||
(map (lambda (e)
|
||||
(translate-type-for-syntax (honu:export-type e)))
|
||||
exports))]
|
||||
[(struct honu:subclass (_ _ _ _))
|
||||
'()]))
|
||||
|
||||
(define (build-unwanted-type-syntax-member-decl member)
|
||||
(match member
|
||||
[(struct honu:field-decl (_ _ type))
|
||||
(translate-type-for-syntax type)]
|
||||
[(struct honu:method-decl (_ _ type arg-types))
|
||||
(list (translate-type-for-syntax type)
|
||||
(map translate-type-for-syntax arg-types))]))
|
||||
|
||||
(define (build-unwanted-type-syntax-member member)
|
||||
(match member
|
||||
[(struct honu:init-field (_ _ type value))
|
||||
(list (translate-type-for-syntax type)
|
||||
(if value (build-unwanted-type-syntax-expression value) '()))]
|
||||
[(struct honu:field (_ _ type value))
|
||||
(list (translate-type-for-syntax type)
|
||||
(build-unwanted-type-syntax-expression value))]
|
||||
[(struct honu:method (_ _ type formals body))
|
||||
(list (translate-type-for-syntax type)
|
||||
(map (lambda (f)
|
||||
(translate-type-for-syntax (honu:formal-type f)))
|
||||
formals)
|
||||
(build-unwanted-type-syntax-expression body))]))
|
||||
|
||||
(define (build-unwanted-type-syntax-expression expr)
|
||||
(match expr
|
||||
[(struct honu:lambda (_ type formals body))
|
||||
(list (translate-type-for-syntax type)
|
||||
(map (lambda (f)
|
||||
(translate-type-for-syntax (honu:formal-type f)))
|
||||
formals)
|
||||
(build-unwanted-type-syntax-expression body))]
|
||||
[(struct honu:let (_ bindings body))
|
||||
(list (map (lambda (b)
|
||||
(list (map translate-type-for-syntax (honu:binding-types b))
|
||||
(build-unwanted-type-syntax-expression (honu:binding-value b))))
|
||||
bindings)
|
||||
(build-unwanted-type-syntax-expression body))]
|
||||
[(struct honu:seq (_ effects result))
|
||||
(list (map (lambda (e)
|
||||
(build-unwanted-type-syntax-expression e))
|
||||
effects)
|
||||
(build-unwanted-type-syntax-expression result))]
|
||||
[(struct honu:call (_ func arg))
|
||||
(list (build-unwanted-type-syntax-expression func)
|
||||
(build-unwanted-type-syntax-expression arg))]
|
||||
[(struct honu:assn (_ lhs rhs))
|
||||
(list (build-unwanted-type-syntax-expression lhs)
|
||||
(build-unwanted-type-syntax-expression rhs))]
|
||||
[(struct honu:return (_ body))
|
||||
(build-unwanted-type-syntax-expression body)]
|
||||
[(struct honu:select (_ _ arg))
|
||||
(build-unwanted-type-syntax-expression arg)]
|
||||
[(struct honu:tuple (_ args))
|
||||
(map build-unwanted-type-syntax-expression args)]
|
||||
[(struct honu:member (_ obj _ _ _))
|
||||
(if (honu:expr? obj)
|
||||
(build-unwanted-type-syntax-expression obj)
|
||||
(list))]
|
||||
[(struct honu:new (_ obj type args))
|
||||
(list (build-unwanted-type-syntax-expression obj)
|
||||
(translate-type-for-syntax type)
|
||||
(map (lambda (a)
|
||||
(build-unwanted-type-syntax-expression (honu:name-arg-value a)))
|
||||
args))]
|
||||
;; here are the two cases where the type already appears in the compiled code
|
||||
[(struct honu:cast (_ obj _))
|
||||
(build-unwanted-type-syntax-expression obj)]
|
||||
[(struct honu:isa (_ obj _))
|
||||
(build-unwanted-type-syntax-expression obj)]
|
||||
[(struct honu:un-op (_ _ _ _ arg))
|
||||
(build-unwanted-type-syntax-expression arg)]
|
||||
[(struct honu:bin-op (_ _ _ _ larg rarg))
|
||||
(list (build-unwanted-type-syntax-expression larg)
|
||||
(build-unwanted-type-syntax-expression rarg))]
|
||||
[(struct honu:if (_ cond then else))
|
||||
(list (build-unwanted-type-syntax-expression cond)
|
||||
(build-unwanted-type-syntax-expression then)
|
||||
(build-unwanted-type-syntax-expression else))]
|
||||
[(struct honu:cond (_ clauses else))
|
||||
(list (map (lambda (c)
|
||||
(list (build-unwanted-type-syntax-expression (honu:cond-clause-pred c))
|
||||
(build-unwanted-type-syntax-expression (honu:cond-clause-rhs c))))
|
||||
clauses)
|
||||
(if else (build-unwanted-type-syntax-expression else) '()))]
|
||||
[else '()]))
|
||||
|
||||
;; Yes, this is just part of the hack that gives us Check Syntax-correctness on all the types that
|
||||
;; are not otherwise used in the compiled code.
|
||||
(provide translate-type-for-syntax)
|
||||
(define (translate-type-for-syntax type)
|
||||
(define (real-translation type)
|
||||
(match type
|
||||
[(struct honu:type-iface (stx name))
|
||||
(translate-iface-name type)]
|
||||
[(struct honu:type-iface-top (stx))
|
||||
(translate-iface-name type)]
|
||||
[(struct honu:type-prim (stx name))
|
||||
'()]
|
||||
[(struct honu:type-func (stx arg ret))
|
||||
(list (real-translation arg)
|
||||
(real-translation ret))]
|
||||
[(struct honu:type-tuple (stx args))
|
||||
(map real-translation args)]))
|
||||
(real-translation type))
|
||||
|
||||
)
|
||||
|
|
@ -1,7 +1,6 @@
|
|||
(module translate-utils mzscheme
|
||||
|
||||
(require (all-except (lib "list.ss" "srfi" "1") any)
|
||||
(lib "plt-match.ss")
|
||||
(lib "contract.ss")
|
||||
"../../ast.ss"
|
||||
"../../parameters.ss"
|
||||
|
|
@ -135,23 +134,4 @@
|
|||
`(begin (set! ,(at-ctxt name) ,arg)
|
||||
,void-value)))
|
||||
|
||||
;; Yes, this is just part of the hack that gives us Check Syntax-correctness on all the types that
|
||||
;; are not otherwise used in the compiled code.
|
||||
(provide translate-type-for-syntax)
|
||||
(define (translate-type-for-syntax type)
|
||||
(define (real-translation type)
|
||||
(match type
|
||||
[(struct honu:type-iface (stx name))
|
||||
(list (translate-iface-name type))]
|
||||
[(struct honu:type-iface-top (stx))
|
||||
(list (translate-iface-name type))]
|
||||
[(struct honu:type-prim (stx name))
|
||||
'()]
|
||||
[(struct honu:type-func (stx arg ret))
|
||||
(append (real-translation arg)
|
||||
(real-translation ret))]
|
||||
[(struct honu:type-tuple (stx args))
|
||||
(apply append (map real-translation args))]))
|
||||
`(list* ,@(real-translation type) '()))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -10,11 +10,12 @@
|
|||
"translate-class-utils.ss"
|
||||
"translate-expression.ss"
|
||||
"translate-parameters.ss"
|
||||
"translate-unwanted-types.ss"
|
||||
"translate-utils.ss")
|
||||
|
||||
(provide/contract [translate ((listof honu:defn?)
|
||||
. -> .
|
||||
(listof (syntax/c any/c)))]
|
||||
(cons/c any/c (listof (syntax/c any/c))))]
|
||||
[translate-defn (honu:defn?
|
||||
. -> .
|
||||
(syntax/c any/c))])
|
||||
|
|
@ -22,7 +23,9 @@
|
|||
(let loop ([defns-to-go defns]
|
||||
[syntaxes '()])
|
||||
(cond
|
||||
[(null? defns-to-go) (reverse syntaxes)]
|
||||
[(null? defns-to-go)
|
||||
(cons (build-unwanted-type-syntax defns)
|
||||
(reverse syntaxes))]
|
||||
[(honu:mixin? (car defns-to-go))
|
||||
(loop (cdr defns-to-go) syntaxes)]
|
||||
[(honu:subclass? (car defns-to-go))
|
||||
|
|
@ -51,38 +54,22 @@
|
|||
(cons (translate-field-getter-name iface (tenv:member-name (car members)))
|
||||
names))))))))
|
||||
|
||||
(define (translate-iface-member-types members)
|
||||
(define (get-member-type-list m)
|
||||
(match m
|
||||
[(struct honu:field-decl (_ _ type))
|
||||
(list (translate-type-for-syntax type))]
|
||||
[(struct honu:method-decl (_ _ type arg-types))
|
||||
(cons (translate-type-for-syntax type)
|
||||
(map translate-type-for-syntax arg-types))]))
|
||||
(apply append (map get-member-type-list members)))
|
||||
|
||||
(define (translate-defn defn)
|
||||
(match defn
|
||||
[(struct honu:bind-top (stx names types value))
|
||||
(let-values ([(bound-names body) (translate-binding-clause names (translate-expression value))])
|
||||
(at stx `(begin (honu:type ,@(map translate-type-for-syntax types))
|
||||
(define-values ,bound-names ,body))))]
|
||||
(at stx `(define-values ,bound-names ,body)))]
|
||||
[(struct honu:function (stx name type args body))
|
||||
(at stx `(begin (honu:type ,(translate-type-for-syntax type))
|
||||
(honu:type ,@(map (lambda (a) (translate-type-for-syntax (honu:formal-type a))) args))
|
||||
,(translate-function stx name args (translate-expression body))))]
|
||||
(translate-function stx name args (translate-expression body))]
|
||||
[(struct honu:iface (stx name supers members))
|
||||
(at stx `(begin
|
||||
(define ,(translate-iface-name (make-iface-type name name))
|
||||
(interface ,(if (null? supers)
|
||||
(list (translate-iface-name (make-any-type #f)))
|
||||
(map translate-iface-name supers))
|
||||
,@(translate-iface-member-names name)))
|
||||
(honu:type ,@(translate-iface-member-types members))))]
|
||||
(at stx `(define ,(translate-iface-name (make-iface-type name name))
|
||||
(interface ,(if (null? supers)
|
||||
(list (translate-iface-name (make-any-type #f)))
|
||||
(map translate-iface-name supers))
|
||||
,@(translate-iface-member-names name))))]
|
||||
[(struct honu:class (stx name selftype _ impls inits members exports))
|
||||
(at stx `(define ,(translate-class-name name)
|
||||
(class* object% ,(map translate-iface-name impls)
|
||||
(honu:type ,(translate-type-for-syntax selftype))
|
||||
(inspect #f)
|
||||
,(translate-inits inits)
|
||||
,@(map translate-member members)
|
||||
|
|
@ -104,8 +91,6 @@
|
|||
(tenv:class-impls base-entry))])
|
||||
(at stx `(define ,(translate-class-name name)
|
||||
(class* ,(translate-class-name base) ,(map translate-iface-name impls)
|
||||
(honu:type ,(translate-type-for-syntax selftype))
|
||||
(honu:type ,@(map (lambda (w) (translate-type-for-syntax (honu:formal-type w))) withs))
|
||||
(inspect #f)
|
||||
,(translate-inits inits)
|
||||
,@(map translate-member members-before)
|
||||
|
|
|
|||
|
|
@ -138,8 +138,10 @@
|
|||
(syntax-e #'type))]
|
||||
;; if it wasn't either of those, this must have been from the definitions
|
||||
;; window, so just eval it.
|
||||
[exp
|
||||
(old-current-eval (syntax-as-top #'exp))]))))
|
||||
;;
|
||||
;; well, remove the cruft I added to get Check Syntax to work first.
|
||||
[(_ type-cruft stx ...)
|
||||
(old-current-eval (syntax-as-top #'(begin stx ...)))]))))
|
||||
(namespace-attach-module n path)
|
||||
(namespace-require path)))))
|
||||
(define/public (render-value value settings port)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user