ref: 538d930befd24d2f826bb4586bd7117d201d2be5
dir: /test/ast/rpasses.lsp/
(load "match.lsp")
(load "asttools.lsp")
(def missing-arg-tag '*r-missing*)
; tree inspection utils
(def (assigned-var e)
(and (cons? e)
(or (eq? (car e) '<-) (eq? (car e) 'ref=))
(symbol? (cadr e))
(cadr e)))
(def (func-argnames f)
(let ((argl (cadr f)))
(if (eq? argl '*r-null*) nil
(map cadr argl))))
; transformations
(let ((ctr 0))
(set! r-gensym (lambda ()
(prog1 (symbol (string "%r:" ctr))
(set! ctr (+ ctr 1))))))
(def (dollarsign-transform e)
(pattern-expand
(pattern-lambda ($ lhs name)
(let* ((g (if (not (cons? lhs)) lhs (r-gensym)))
(n (if (symbol? name)
name ;(symbol->string name)
name))
(expr `(r-call
r-aref ,g (index-in-strlist ,n (r-call attr ,g "names")))))
(if (not (cons? lhs))
expr
`(r-block (ref= ,g ,lhs) ,expr))))
e))
; lower r expressions of the form f(lhs,...) <- rhs
; TODO: if there are any special forms that can be f in this expression,
; they need to be handled separately. For example a$b can be lowered
; to an index assignment (by dollarsign-transform), after which
; this transform applies. I don't think there are any others though.
(def (fancy-assignment-transform e)
(pattern-expand
(pattern-lambda (-$ (<- (r-call f lhs ...) rhs)
(<<- (r-call f lhs ...) rhs))
(let ((g (if (cons? rhs) (r-gensym) rhs))
(op (car __)))
`(r-block ,@(if (cons? rhs) `((ref= ,g ,rhs)) nil)
(,op ,lhs (r-call ,(symconcat f '<-) ,@(cddr (cadr __)) ,g))
,g)))
e))
; map an arglist with default values to appropriate init code
; function(x=blah) { ... } gets
; if (missing(x)) x = blah
; added to its body
(def (gen-default-inits arglist)
(map (lambda (arg)
(let ((name (cadr arg))
(default (caddr arg)))
`(when (missing ,name)
(<- ,name ,default))))
(filter (lambda (arg) (not (eq? (caddr arg) missing-arg-tag))) arglist)))
; convert r function expressions to lambda
(def (normalize-r-functions e)
(maptree-post (lambda (n)
(if (and (cons? n) (eq? (car n) 'function))
`(lambda ,(func-argnames n)
(r-block ,@(gen-default-inits (cadr n))
,@(if (and (cons? (caddr n))
(eq? (car (caddr n)) 'r-block))
(cdr (caddr n))
(list (caddr n)))))
n))
e))
(def (find-assigned-vars n)
(let ((vars nil))
(maptree-pre (lambda (s)
(if (not (cons? s)) s
(cond ((eq? (car s) 'lambda) nil)
((eq? (car s) '<-)
(set! vars (list-adjoin (cadr s) vars))
(cddr s))
(else s))))
n)
vars))
; introduce let based on assignment statements
(def (letbind-locals e)
(maptree-post (lambda (n)
(if (and (cons? n) (eq? (car n) 'lambda))
(let ((vars (find-assigned-vars (cddr n))))
`(lambda ,(cadr n) (let ,(map (lambda (v) (list v nil))
vars)
,@(cddr n))))
n))
e))
(def (compile-ish e)
(letbind-locals
(normalize-r-functions
(fancy-assignment-transform
(dollarsign-transform
(flatten-all-op && (flatten-all-op \|\| e)))))))