diff options
| author | Kaz Kylheku <kaz@kylheku.com> | 2018-03-20 22:13:06 -0700 |
|---|---|---|
| committer | Kaz Kylheku <kaz@kylheku.com> | 2018-03-20 22:13:06 -0700 |
| commit | bea25c5395d1bffc4f671defa558510ce07670ac (patch) | |
| tree | c9ecd0198d6b4e8b0628d3c977f10f9882a4d0dd | |
| parent | 97753bee4c03e02a7cf8605dc4b5c98d556715a9 (diff) | |
| download | txr-bea25c5395d1bffc4f671defa558510ce07670ac.tar.gz txr-bea25c5395d1bffc4f671defa558510ce07670ac.tar.bz2 txr-bea25c5395d1bffc4f671defa558510ce07670ac.zip | |
compiler: handle special forms and or.
* share/txr/stdlib/compiler.tl (compiler compile): Handle and
and or cases via comp-and-or method.
(compiler comp-and-or): New method. This is based on
comp-progn.
| -rw-r--r-- | share/txr/stdlib/compiler.tl | 27 |
1 files changed, 27 insertions, 0 deletions
diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl index fdbf0138..ad6d886f 100644 --- a/share/txr/stdlib/compiler.tl +++ b/share/txr/stdlib/compiler.tl @@ -151,6 +151,8 @@ (lambda me.(comp-lambda oreg env form)) (sys:for-op me.(comp-for oreg env form)) (progn me.(comp-progn oreg env (cdr form))) + (and me.(comp-and-or oreg env form)) + (or me.(comp-and-or oreg env form)) (prog1 me.(comp-prog1 oreg env form)) (sys:quasi me.(comp-quasi oreg env form)) (dohash me.(compile oreg env (expand-dohash form))) @@ -462,6 +464,31 @@ me.(free-treg oreg-discard) (new (frag (if lastfrag lastfrag.oreg ^(t 0)) code fvars ffuns)))) +(defmeth compiler comp-and-or (me oreg env form) + (mac-param-bind form (op . args) form + (let* (ffuns fvars + (nargs (len args)) + lastfrag + (is-and (eq op 'and)) + (lout (gensym "l")) + (code (build + (each ((form args) + (n (range 1))) + (let ((islast (eql n nargs))) + (let ((frag me.(compile oreg env form))) + (when islast + (set lastfrag frag)) + (pend frag.code + (maybe-mov oreg frag.oreg)) + (unless islast + (add (if is-and + ^(if ,oreg ,lout) + ^(ifq ,oreg ,nil ,lout)))) + (set fvars (uni fvars frag.fvars)) + (set ffuns (uni ffuns frag.ffuns)))))))) + (new (frag (if lastfrag oreg (if is-and me.(get-dreg t) ^(t 0))) + (append code ^(,lout)) fvars ffuns))))) + (defmeth compiler comp-prog1 (me oreg env form) (tree-case form ((prog1 fi . re) (let* ((igreg me.(alloc-treg)) |