ref: 656ccd1c81fb6b571da0eb85f101635e3a8c387d
dir: /test/ast/asttools.lsp/
; utilities for AST processing
(def (symconcat s1 s2)
(symbol (string s1 s2)))
(def (list-adjoin item lst)
(if (member item lst)
lst
(cons item lst)))
(def (index-of item lst start)
(cond ((not lst) nil)
((eq? item (car lst)) start)
(else (index-of item (cdr lst) (+ start 1)))))
(def (each f l)
(if (not l) l
(begin (f (car l))
(each f (cdr l)))))
(def (maptree-pre f tr)
(let ((new-t (f tr)))
(if (cons? new-t)
(map (lambda (e) (maptree-pre f e)) new-t)
new-t)))
(def (maptree-post f tr)
(if (not (cons? tr))
(f tr)
(let ((new-t (map (lambda (e) (maptree-post f e)) tr)))
(f new-t))))
(def (foldtree-pre f tr zero)
(if (not (cons? tr))
(f tr zero)
(foldl tr (lambda (e state) (foldtree-pre f e state)) (f tr zero))))
(def (foldtree-post f tr zero)
(if (not (cons? tr))
(f tr zero)
(f tr (foldl tr (lambda (e state) (foldtree-post f e state)) zero))))
; general tree transformer
; folds in preorder (foldtree-pre), maps in postorder (maptree-post)
; therefore state changes occur immediately, just by looking at the current node,
; while transformation follows evaluation order. this seems to be the most natural
; approach.
; (mapper tree state) - should return transformed tree given current state
; (folder tree state) - should return new state
(def (map&fold tr zero mapper folder)
(let ((head (and (cons? tr) (car tr))))
(cond
((eq? head 'quote) tr)
((or (eq? head 'the) (eq? head 'meta))
(list head
(cadr tr)
(map&fold (caddr tr) zero mapper folder)))
(else
(let ((new-s (folder tr zero)))
(mapper
(if (cons? tr)
; head symbol is a tag; never transform it
(cons (car tr)
(map (lambda (e) (map&fold e new-s mapper folder))
(cdr tr)))
tr)
new-s))))))
; convert to proper list, i.e. remove "dots", and append
(def (append.2 l tail)
(cond ((not l) tail)
((atom? l) (cons l tail))
(else (cons (car l) (append.2 (cdr l) tail)))))
; transform code by calling (f expr env) on each subexpr, where
; env is a list of lexical variables in effect at that point.
(def (lexical-walk f tr)
(map&fold tr () f
(lambda (tree state)
(if (and (eq? (car tr) 'lambda)
(cons? (cdr tr)))
(append.2 (cadr tr) state)
state))))
; collapse forms like (&& (&& (&& (&& a b) c) d) e) to (&& a b c d e)
(def (flatten-left-op op e)
(maptree-post (lambda (node)
(if (and (cons? node)
(eq? (car node) op)
(cons? (cdr node))
(cons? (cadr node))
(eq? (caadr node) op))
(cons op
(append (cdadr node) (cddr node)))
node))
e))
; convert all local variable references to (lexref rib slot name)
; where rib is the nesting level and slot is the stack slot#
; name is just there for reference
; this assumes lambda is the only remaining naming form
(def (lookup-var v env lev)
(if (not env) v
(let ((i (index-of v (car env) 0)))
(if i (list 'lexref lev i v)
(lookup-var v (cdr env) (+ lev 1))))))
(def (lvc- e env)
(cond ((symbol? e) (lookup-var e env 0))
((cons? e)
(if (eq? (car e) 'quote)
e
(let* ((newvs (and (eq? (car e) 'lambda) (cadr e)))
(newenv (if newvs (cons newvs env) env)))
(if newvs
(cons 'lambda
(cons (cadr e)
(map (lambda (se) (lvc- se newenv))
(cddr e))))
(map (lambda (se) (lvc- se env)) e)))))
(else e)))
(def (lexical-var-conversion e)
(lvc- e ()))
; convert let to lambda
(def (let-expand e)
(maptree-post (lambda (n)
(if (and (cons? n) (eq? (car n) 'let))
`((lambda ,(map car (cadr n)) ,@(cddr n))
,@(map cadr (cadr n)))
n))
e))
; alpha renaming
; transl is an assoc list ((old-sym-name . new-sym-name) ...)
(def (alpha-rename e transl)
(map&fold e
()
; mapper: replace symbol if unbound
(lambda (te env)
(if (symbol? te)
(let ((found (assq te transl)))
(if (and found
(not (memq te env)))
(cdr found)
te))
te))
; folder: add locals to environment if entering a new scope
(lambda (te env)
(if (and (cons? te) (or (eq? (car te) 'let)
(eq? (car te) 'lambda)))
(append (cadr te) env)
env))))
; flatten op with any associativity
(defmacro (flatten-all-op op e)
`(pattern-expand
(pattern-lambda (,op (-- l ...) (-- inner (,op ...)) (-- r ...))
(cons ',op (append l (cdr inner) r)))
,e))
(defmacro (pattern-lambda pat body)
(let* ((args (patargs pat))
(expander `(lambda ,args ,body)))
`(lambda (expr)
(let ((m (match ',pat expr)))
(if m
; matches; perform expansion
(apply ,expander (map (lambda (var) (cdr (or (assq var m) '(0 . nil))))
',args))
nil)))))