diff options
| author | Kaz Kylheku <kaz@kylheku.com> | 2018-03-20 00:05:35 -0700 |
|---|---|---|
| committer | Kaz Kylheku <kaz@kylheku.com> | 2018-03-20 00:05:35 -0700 |
| commit | 61dbc3f0a55029a10720d2affe049d13f3147da2 (patch) | |
| tree | b88e6475828db05b909797d2b4b84e441543aec1 | |
| parent | 50b3b8a020217910041ece4f380cc97ed6845ae9 (diff) | |
| download | txr-61dbc3f0a55029a10720d2affe049d13f3147da2.tar.gz txr-61dbc3f0a55029a10720d2affe049d13f3147da2.tar.bz2 txr-61dbc3f0a55029a10720d2affe049d13f3147da2.zip | |
compiler: handle cond special form.
* share/txr/stdlib/compiler.tl (compiler compile): Handle cond
case via comp-cond method.
(compiler comp-cond): New method.
| -rw-r--r-- | share/txr/stdlib/compiler.tl | 54 |
1 files changed, 54 insertions, 0 deletions
diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl index d02e8aee..9ec9e10b 100644 --- a/share/txr/stdlib/compiler.tl +++ b/share/txr/stdlib/compiler.tl @@ -144,6 +144,7 @@ (caseq sym (quote me.(comp-atom oreg (cadr form))) (sys:setq me.(comp-setq oreg env form)) + (cond me.(comp-cond oreg env form)) (block me.(comp-block oreg env form)) ((let let*) me.(comp-let oreg env form)) (lambda me.(comp-lambda oreg env form)) @@ -197,6 +198,59 @@ (uni (list sym) vfrag.fvars) vfrag.ffuns))))) +(defmeth compiler comp-cond (me oreg env form) + (let* ((lout (gensym "l")) + (frags (collect-each ((cl (rest form))) + (mac-param-bind form (test . forms) cl + (cond + ((and (eq test t) (null forms)) + (let ((dreg me.(get-dreg t))) + (new (frag oreg + ^(,*(if (nequal oreg dreg) + ^((mov ,oreg ,dreg))) + (jmp ,lout)))))) + ((eq test t) + (let ((ffrag me.(comp-progn oreg env forms))) + (new (frag oreg + ^(,*ffrag.code + ,*(if (nequal oreg ffrag.oreg) + ^((mov ,oreg ,ffrag.oreg))) + (jmp ,lout)) + ffrag.fvars + ffrag.ffuns)))) + ((null forms) + (let ((tfrag me.(compile oreg env test)) + (lskip (gensym "l"))) + (new (frag oreg + ^(,*tfrag.code + ,*(if (neq (car tfrag.oreg) 'd) + ^((if ,tfrag.oreg ,lskip))) + ,*(if (nequal oreg tfrag.oreg) + ^((mov ,oreg ,tfrag.oreg))) + (jmp ,lout) + ,lskip) + tfrag.fvars + tfrag.ffuns)))) + (t (let ((tfrag me.(compile oreg env test)) + (ffrag me.(comp-progn oreg env forms)) + (lskip (gensym "l"))) + (new (frag oreg + ^(,*tfrag.code + ,*(if (neq (car tfrag.oreg) 'd) + ^((if ,tfrag.oreg ,lskip))) + ,*ffrag.code + ,*(if (nequal oreg ffrag.oreg) + ^((mov ,oreg ,ffrag.oreg))) + (jmp ,lout) + ,lskip) + (uni tfrag.fvars ffrag.fvars) + (uni tfrag.ffuns ffrag.ffuns)))))))))) + (new (frag oreg + ^(,*(mappend .code frags) + ,lout) + [reduce-left uni frags nil .fvars] + [reduce-left uni frags nil .ffuns])))) + (defmeth compiler comp-block (me oreg env form) (mac-param-bind form (op name . body) form (let* ((nreg (if name me.(get-dreg name) '(t 0))) |