diff options
| author | Kaz Kylheku <kaz@kylheku.com> | 2018-03-20 06:16:32 -0700 |
|---|---|---|
| committer | Kaz Kylheku <kaz@kylheku.com> | 2018-03-20 06:16:32 -0700 |
| commit | 46c773ac117c9d2502160b929c87d1611c65c718 (patch) | |
| tree | 4f2a568c9f9086e59b506ee950203190cd4ecb67 | |
| parent | 61dbc3f0a55029a10720d2affe049d13f3147da2 (diff) | |
| download | txr-46c773ac117c9d2502160b929c87d1611c65c718.tar.gz txr-46c773ac117c9d2502160b929c87d1611c65c718.tar.bz2 txr-46c773ac117c9d2502160b929c87d1611c65c718.zip | |
compiler: handle if special form
* share/txr/stdlib/compiler.tl (compiler compile): Handle if
case via comp-if method.
(compiler comp-if): New method.
| -rw-r--r-- | share/txr/stdlib/compiler.tl | 52 |
1 files changed, 52 insertions, 0 deletions
diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl index 9ec9e10b..b74d2b84 100644 --- a/share/txr/stdlib/compiler.tl +++ b/share/txr/stdlib/compiler.tl @@ -145,6 +145,7 @@ (quote me.(comp-atom oreg (cadr form))) (sys:setq me.(comp-setq oreg env form)) (cond me.(comp-cond oreg env form)) + (if me.(comp-if 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)) @@ -251,6 +252,57 @@ [reduce-left uni frags nil .fvars] [reduce-left uni frags nil .ffuns])))) +(defmeth compiler comp-if (me oreg env form) + (tree-case form + ((op test then else) + (let* ((te-oreg me.(alloc-treg)) + (lelse (gensym "l")) + (lskip (gensym "l")) + (te-frag me.(compile te-oreg env test)) + (th-frag me.(compile oreg env then)) + (el-frag me.(compile oreg env else))) + me.(free-treg te-oreg) + (new (frag oreg + ^(,*te-frag.code + (if ,te-frag.oreg ,lelse) + ,*th-frag.code + ,*(if (nequal oreg th-frag.oreg) + ^((mov ,oreg ,th-frag.oreg))) + (jmp ,lskip) + ,lelse + ,*el-frag.code + ,*(if (nequal oreg el-frag.oreg) + ^((mov ,oreg ,el-frag.oreg))) + ,lskip + ,*(if (nequal te-oreg te-frag.oreg) + ^((mov ,te-oreg ,te-frag.oreg)))) + (uni te-frag.fvars (uni th-frag.fvars el-frag.fvars)) + (uni te-frag.ffuns (uni th-frag.ffuns el-frag.ffuns)))))) + ((op test then) + (let ((lskip (gensym "l")) + (te-frag me.(compile oreg env test)) + (th-frag me.(compile oreg env then))) + (new (frag oreg + ^(,*te-frag.code + ,*(if (nequal oreg te-frag.oreg) + ^((mov ,oreg ,te-frag.oreg))) + (if ,oreg ,lskip) + ,*th-frag.code + ,*(if (nequal oreg th-frag.oreg) + ^((mov ,oreg ,th-frag.oreg))) + ,lskip) + (uni te-frag.fvars th-frag.fvars) + (uni te-frag.ffuns th-frag.ffuns))))) + ((op test) + (let ((te-frag me.(compile oreg env test))) + (new (frag oreg + ^(,*te-frag.code + (mov ,oreg nil)) + te-frag.fvars + te-frag.ffuns)))) + ((op) me.(compile oreg env nil)) + (form (compile-error form "excess argument forms")))) + (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))) |