From 4ad20e760c4745ea27bc83a21d12a8ef84c87445 Mon Sep 17 00:00:00 2001
From: Taylan Kammer <taylan.kammer@gmail.com>
Date: Fri, 14 May 2021 18:35:12 +0200
Subject: [PATCH] Make #nil and () equal as per equal?.

* libguile/eq.c (scm_equal_p): Add check to see if both arguments
satisfy null? and return true if they do.
* module/language/tree-il/compile-cps.scm (canonicalize): In equal?
primcalls, add a check to see if both arguments satisfy null?.
* module/language/tree-il/peval.scm (peval): In the partial evaluation
of equality primitives, don't fold to eq? for #nil and '().
---
 libguile/eq.c                           |  3 ++
 module/language/tree-il/compile-cps.scm | 39 ++++++++++++++++---------
 module/language/tree-il/peval.scm       |  4 +--
 3 files changed, 30 insertions(+), 16 deletions(-)

diff --git a/libguile/eq.c b/libguile/eq.c
index 627d6f09b..0a8a60634 100644
--- a/libguile/eq.c
+++ b/libguile/eq.c
@@ -299,6 +299,9 @@ scm_equal_p (SCM x, SCM y)
   SCM_TICK;
   if (scm_is_eq (x, y))
     return SCM_BOOL_T;
+  /* Make sure #nil and () are equal. */
+  if (scm_is_null (x) && scm_is_null (y))
+    return SCM_BOOL_T;
   if (SCM_IMP (x))
     return SCM_BOOL_F;
   if (SCM_IMP (y))
diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm
index ffc8308a6..a0a3e2381 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -2478,14 +2478,15 @@ integer."
         (let ()
           (define-syntax-rule (primcall name . args)
             (make-primcall src 'name (list . args)))
-          (define-syntax primcall-chain
+          (define-syntax primcall-cond-chain
             (syntax-rules ()
-              ((_ x) x)
-              ((_ x . y)
-               (make-conditional src (primcall . x) (primcall-chain . y)
-                                 (make-const src #f)))))
-          (define-syntax-rule (bool x)
-            (make-conditional src x (make-const src #t) (make-const src #f)))
+              ((_ consequent alternate) consequent)
+              ((_ test test* ... consequent alternate)
+               (make-conditional
+                src
+                (primcall . test)
+                (primcall-cond-chain test* ... consequent alternate)
+                alternate))))
           (with-lexicals src (a b)
             (make-conditional
              src
@@ -2494,14 +2495,24 @@ integer."
              (match (primcall-name exp)
                ('eqv?
                 ;; Completely inline.
-                (primcall-chain (heap-number? a)
-                                (heap-number? b)
-                                (bool (primcall heap-numbers-equal? a b))))
+                (primcall-cond-chain
+                 (heap-number? a)
+                 (heap-number? b)
+                 (heap-numbers-equal? a b)
+                 (make-const src #t)
+                 (make-const src #f)))
                ('equal?
-                ;; Partially inline.
-                (primcall-chain (heap-object? a)
-                                (heap-object? b)
-                                (primcall equal? a b))))))))
+                ;; Make sure #nil and () are equal.
+                (primcall-cond-chain
+                 (null? a)
+                 (null? b)
+                 (make-const src #t)
+                 ;; Partially inline.
+                 (primcall-cond-chain
+                  (heap-object? a)
+                  (heap-object? b)
+                  (primcall equal? a b)
+                  (make-const src #f)))))))))
 
        (($ <primcall> src 'vector args)
         ;; Expand to "allocate-vector" + "vector-init!".
diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm
index d910088c9..93741b4cf 100644
--- a/module/language/tree-il/peval.scm
+++ b/module/language/tree-il/peval.scm
@@ -1430,8 +1430,8 @@ top-level bindings from ENV and return the resulting expression."
            ((eq? name 'eq?)
             ;; Already in a reduced state.
             (make-primcall src 'eq? (list a b)))
-           ((or (memq v '(#f #t () #nil)) (symbol? v) (char? v)
-                ;; Only fold to eq? value is a fixnum on target and
+           ((or (memq v '(#f #t)) (symbol? v) (char? v)
+                ;; Only fold to eq? if value is a fixnum on target and
                 ;; host, as constant folding may have us compare on host
                 ;; as well.
                 (and (exact-integer? v)
-- 
2.30.2