From 893795b1c377f23dd42709b4367a1aade4b7570f Mon Sep 17 00:00:00 2001
From: Ron Gut <rongut@google.com>
Date: Mon, 24 Oct 2016 13:13:06 -0400
Subject: [PATCH] Make COND a non-recursive macro

Doing so simplifies life for the interpreter, as the entire expansion is
available at once (and can be memoized directly with no special-casing).

This change also elides unneeded PROGNs in the expansion.
---
 src/code/defboot.lisp  | 55 ++++++++++++++++++++++++--------------------------
 tests/walk.impure.lisp |  4 +---
 2 files changed, 27 insertions(+), 32 deletions(-)

diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp
index 2d234a703..d73e2409f 100644
--- a/src/code/defboot.lisp
+++ b/src/code/defboot.lisp
@@ -65,39 +65,36 @@
 
 ;;;; various conditional constructs
 
-;;; COND defined in terms of IF
-(sb!xc:defmacro cond (&rest clauses)
-  (if (endp clauses)
-      nil
-      (let ((clause (first clauses))
-            (more (rest clauses)))
-        (if (atom clause)
-            (error 'simple-type-error
-                   :format-control "COND clause is not a ~S: ~S"
-                   :format-arguments (list 'cons clause)
-                   :expected-type 'cons
-                   :datum clause)
-            (let ((test (first clause))
-                  (forms (rest clause)))
-              (if (endp forms)
-                  (let ((n-result (gensym)))
-                    `(let ((,n-result ,test))
-                       (if ,n-result
-                           ,n-result
-                           (cond ,@more))))
-                  (if (and (eq test t)
-                           (not more))
-                      ;; THE to preserve non-toplevelness for FOO in
-                      ;;   (COND (T (FOO)))
-                      `(the t (progn ,@forms))
-                      `(if ,test
-                           (progn ,@forms)
-                           ,(when more `(cond ,@more))))))))))
-
 (flet ((prognify (forms)
          (cond ((singleton-p forms) (car forms))
                ((not forms) nil)
                (t `(progn ,@forms)))))
+  ;; COND defined in terms of IF
+  (sb!xc:defmacro cond (&rest clauses)
+    (named-let make-clauses ((clauses clauses))
+      (if (endp clauses)
+          nil
+          (let ((clause (first clauses))
+                (more (rest clauses)))
+            (if (atom clause)
+                (error 'simple-type-error
+                       :format-control "COND clause is not a ~S: ~S"
+                       :format-arguments (list 'cons clause)
+                       :expected-type 'cons
+                       :datum clause)
+                (let ((test (first clause))
+                      (forms (rest clause)))
+                  (if (endp forms)
+                      `(or ,test ,(make-clauses more))
+                      (if (and (eq test t)
+                               (not more))
+                          ;; THE to preserve non-toplevelness for FOO in
+                          ;;   (COND (T (FOO)))
+                          `(the t ,(prognify forms))
+                          `(if ,test
+                               ,(prognify forms)
+                               ,(when more (make-clauses more)))))))))))
+
   (sb!xc:defmacro when (test &body forms)
   #!+sb-doc
   "If the first argument is true, the rest of the forms are
diff --git a/tests/walk.impure.lisp b/tests/walk.impure.lisp
index e53f47e93..7b357eace 100644
--- a/tests/walk.impure.lisp
+++ b/tests/walk.impure.lisp
@@ -984,11 +984,9 @@ Form: 2   Context: EVAL
              (take-it-out-for-a-test-walk (cond (a b)
                                                 ((foo bar) a (foo a)))))
            "Form: (COND (A B) ((FOO BAR) A (FOO A)))   Context: EVAL
-Form: (IF A (PROGN B) (COND ((FOO BAR) A (FOO A))))   Context: EVAL
+Form: (IF A B (IF (FOO BAR) (PROGN A (FOO A)) NIL))   Context: EVAL
 Form: A   Context: EVAL
-Form: (PROGN B)   Context: EVAL
 Form: B   Context: EVAL
-Form: (COND ((FOO BAR) A (FOO A)))   Context: EVAL
 Form: (IF (FOO BAR) (PROGN A (FOO A)) NIL)   Context: EVAL
 Form: (FOO BAR)   Context: EVAL
 Form: 'GLOBAL-FOO   Context: EVAL
-- 
2.11.4.GIT