From 817cd83e0165714cb482e4acc54409510a2d0417 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Wed, 28 Mar 2018 06:42:15 -0700
Subject: compiler: replace cond implementation.

* share/txr/stdlib/compiler.tl (compiler comp-cond): Replace
pointlessly verbose cond implementation compact implementation
that rewrites cond to combinations of if, progn and smaller
cond.  This generates pretty much the same code, and will
automatically benefit from special case translations
applied in if.
---
 share/txr/stdlib/compiler.tl | 77 ++++++--------------------------------------
 1 file changed, 10 insertions(+), 67 deletions(-)

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index 65d66a24..a45d2c09 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -289,73 +289,16 @@
                    vfrag.ffuns))))))
 
 (defmeth compiler comp-cond (me oreg env form)
-  (let* ((lout (gensym "l"))
-         (raw-cases (rest form))
-         (first-const [member-if constantp raw-cases car])
-         (cases (ldiff raw-cases (cdr first-const)))
-         (ncases (len cases))
-         (frags (collect-each ((cl cases)
-                               (i (range 1)))
-                  (mac-param-bind form (test . forms) cl
-                    (cond
-                      ((and (eq test t) (null forms))
-                       (let ((dreg me.(get-dreg t)))
-                         (new (frag oreg
-                                    ^(,*(maybe-mov oreg dreg)
-                                      ,*(if (neql i ncases)
-                                          ^((jmp ,lout))))))))
-                      ((eq test t)
-                       (let ((ffrag me.(comp-progn oreg env forms)))
-                         (new (frag oreg
-                                    ^(,*ffrag.code
-                                      ,*(maybe-mov oreg ffrag.oreg)
-                                      ,*(if (neql i ncases)
-                                          ^((jmp ,lout))))
-                                    ffrag.fvars
-                                    ffrag.ffuns))))
-                      ((null test)
-                       me.(compile oreg env nil))
-                      ((constantp test)
-                       (let ((ffrag me.(comp-progn oreg env cl)))
-                         (new (frag oreg
-                                    ^(,*ffrag.code
-                                      ,*(maybe-mov oreg ffrag.oreg)
-                                      ,*(if (neql i ncases)
-                                          ^((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)))
-                                      ,*(maybe-mov oreg tfrag.oreg)
-                                      ,*(if (neql i ncases)
-                                          ^((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
-                                         ,*(maybe-mov oreg ffrag.oreg)
-                                         ,*(if (neql i ncases)
-                                             ^((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]))))
+  (tree-case form
+    ((op) me.(comp-atom oreg nil))
+    ((op (test . forms) . more) me.(compile oreg env
+                                            ^(if ,test
+                                               (progn ,*forms)
+                                               (cond ,*more))))
+    ((op atom . more)
+     (compile-error form "atom in cond syntax; pair expected"))
+    ((op . atom)
+     (compile-error form "trailing atom in cond syntax"))))
 
 (defmeth compiler comp-if (me oreg env form)
   (tree-case form
-- 
cgit v1.2.3