diff options
| author | Kaz Kylheku <kaz@kylheku.com> | 2018-03-24 18:05:27 -0700 |
|---|---|---|
| committer | Kaz Kylheku <kaz@kylheku.com> | 2018-03-24 18:05:27 -0700 |
| commit | f8d69f3dc4de10b70eb4796e664db860ff306cc6 (patch) | |
| tree | cacf92f2976bdd02df6130ebc93c8f7e0970e40a | |
| parent | b887b0a46cb66f2f2bc1a67b13e115e57058f298 (diff) | |
| download | txr-f8d69f3dc4de10b70eb4796e664db860ff306cc6.tar.gz txr-f8d69f3dc4de10b70eb4796e664db860ff306cc6.tar.bz2 txr-f8d69f3dc4de10b70eb4796e664db860ff306cc6.zip | |
compiler: add fbind and lbind special forms
This supports labels and flet.
* share/txr/stdlib/compiler.tl (compiler compile): Route fbind
and lbind to comp-fbind method.
(compiler comp-fbind): New method.
| -rw-r--r-- | share/txr/stdlib/compiler.tl | 32 |
1 files changed, 32 insertions, 0 deletions
diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl index d9c89bea..36e2746b 100644 --- a/share/txr/stdlib/compiler.tl +++ b/share/txr/stdlib/compiler.tl @@ -166,6 +166,7 @@ (return-from me.(comp-return-from oreg env form)) (return me.(comp-return oreg env form)) ((let let*) me.(comp-let oreg env form)) + ((sys:fbind sys:lbind) me.(comp-fbind oreg env form)) (lambda me.(comp-lambda oreg env form)) (sys:for-op me.(comp-for oreg env form)) (sys:each-op me.(compile oreg env (expand-each form env))) @@ -451,6 +452,37 @@ (uni (diff bfrag.fvars lexsyms) fvars) (uni ffuns bfrag.ffuns))))))) +(defmeth compiler comp-fbind (me oreg env form) + (mac-param-bind form (sym raw-fis . body) form + (let* ((fis (mapcar [iffi atom list] raw-fis)) + (lexfuns [mapcar car fis]) + (frsize (len lexfuns)) + (rec (eq sym 'sys:lbind)) + (nenv (new env up env co me))) + (each ((lfun lexfuns)) + nenv.(extend-fun lfun)) + (let* (ffuns fvars + (code (build + (add ^(frame ,nenv.lev ,frsize)) + (each ((fi fis)) + (tree-bind (sym : form) fi + (let* ((bind nenv.(lookup-fun sym)) + (frag me.(compile bind.loc + (if rec nenv env) + form))) + (pend frag.code + (maybe-mov bind.loc frag.oreg)) + (set ffuns (uni ffuns frag.ffuns) + fvars (uni fvars frag.fvars))))))) + (bfrag me.(comp-progn oreg nenv body)) + (boreg (if env.(out-of-scope bfrag.oreg) oreg bfrag.oreg))) + (new (frag boreg + (append code bfrag.code + (maybe-mov boreg bfrag.oreg) + ^((end ,boreg))) + (uni fvars bfrag.fvars) + (uni (diff bfrag.ffuns lexfuns) bfrag.ffuns))))))) + (defmeth compiler comp-lambda (me oreg env form) (mac-param-bind form (op pars . body) form (let* ((rest-par (nthlast 0 pars)) |