diff options
| author | Kaz Kylheku <kaz@kylheku.com> | 2018-07-10 06:56:21 -0700 |
|---|---|---|
| committer | Kaz Kylheku <kaz@kylheku.com> | 2018-07-10 06:56:21 -0700 |
| commit | ac21241540700a7a1f101d2cdf0c6f2906fba34e (patch) | |
| tree | a7fa77b3645d761e4cfd6104cebb62e2b23b7af9 | |
| parent | cba24e923d8cdd1afa80f8d828c69bcfacc81eaa (diff) | |
| download | txr-ac21241540700a7a1f101d2cdf0c6f2906fba34e.tar.gz txr-ac21241540700a7a1f101d2cdf0c6f2906fba34e.tar.bz2 txr-ac21241540700a7a1f101d2cdf0c6f2906fba34e.zip | |
compiler: bugfix: mishandled empty test
* share/txr/stdlib/compiler.tl (compiler comp-for): Fix
exception thrown when compiling (for init test step ...)
when test is nil. Firstly, we must distinguish a (nil)
test from (), because the latter means (t). Hence the need for
the test-p Boolean. The list of frags must not contain a
nil, which isn't a frag. The instruction template must not
only omit generating the conditional jump when the test is
absent, but also omit generating the test code (insertion of
tfrag.code) in that case, because tfrag is nil.
| -rw-r--r-- | share/txr/stdlib/compiler.tl | 15 |
1 files changed, 9 insertions, 6 deletions
diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl index 04a92bf5..56db42b2 100644 --- a/share/txr/stdlib/compiler.tl +++ b/share/txr/stdlib/compiler.tl @@ -1061,23 +1061,26 @@ apply-list-arg))))) (defmeth compiler comp-for (me oreg env form) - (mac-param-bind form (op inits (: test . rets) incs . body) form + (mac-param-bind form (op inits (: (test nil test-p) . rets) incs . body) form (let* ((treg me.(alloc-treg)) (ifrag me.(comp-progn treg env inits)) - (tfrag (if test me.(compile oreg env test))) + (tfrag (if test-p me.(compile oreg env test))) (rfrag me.(comp-progn oreg env rets)) (nfrag me.(comp-progn treg env incs)) (bfrag me.(comp-progn treg env body)) (lback (gensym "l")) (lskip (gensym "l")) - (frags (list ifrag tfrag rfrag nfrag bfrag))) + (frags (build + (add ifrag) + (if test-p (add tfrag)) + (add rfrag nfrag bfrag)))) me.(free-treg treg) (new (frag rfrag.oreg ^(,*ifrag.code ,lback - ,*tfrag.code - ,*(if test - ^((if ,tfrag.oreg ,lskip))) + ,*(if test-p + ^(,*tfrag.code + (if ,tfrag.oreg ,lskip))) ,*bfrag.code ,*nfrag.code (jmp ,lback) |