From 19d37e39d4e0bfc943749d111c1ba2cbed805939 Mon Sep 17 00:00:00 2001
From: Stas Boukarev <stassats@gmail.com>
Date: Mon, 23 Sep 2013 21:25:51 +0400
Subject: [PATCH] ADJOIN shouldn't constant fold.

ADJOIN creates new lists, so it shouldn't be constant folded. The
problem materialized when more %adjoin-* helper functions received an
fndb entry with foldable attribute copied, causing more cases to be
folded.

Reported by Eric Marsden.
---
 src/compiler/fndb.lisp |   32 +++++++++++++++++++++++++-------
 tests/list.pure.lisp   |    4 ++++
 2 files changed, 29 insertions(+), 7 deletions(-)

diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index b25fe32..bb39bc4 100644
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -794,7 +794,7 @@
 
 (defknown adjoin (t list &key (:key callable) (:test callable)
                     (:test-not callable))
-  cons (foldable flushable call))
+  cons (flushable call))
 
 (defknown (union intersection set-difference set-exclusive-or)
   (list list &key (:key callable) (:test callable) (:test-not callable))
@@ -1545,13 +1545,23 @@
   function
   (flushable foldable))
 
-(defknown (%adjoin %adjoin-eq %member %member-eq
+(defknown (%adjoin %adjoin-eq)
+    (t list)
+    list
+    (explicit-check flushable))
+
+(defknown (%member %member-eq
            %assoc %assoc-eq %rassoc %rassoc-eq)
     (t list)
     list
     (explicit-check foldable flushable))
 
-(defknown (%adjoin-key %adjoin-key-eq %member-key %member-key-eq
+(defknown (%adjoin-key %adjoin-key-eq)
+    (t list function)
+    list
+    (explicit-check flushable call))
+
+(defknown (%member-key %member-key-eq
            %assoc-key %assoc-key-eq %rassoc-key %rassoc-key-eq)
   (t list function)
   list
@@ -1569,16 +1579,24 @@
   list
   (explicit-check foldable flushable call))
 
-(defknown (%adjoin-test %adjoin-test-not
-           %member-test %member-test-not
+(defknown (%adjoin-test %adjoin-test-not)
+    (t list function)
+    list
+    (explicit-check flushable call))
+
+(defknown (%member-test %member-test-not
            %assoc-test %assoc-test-not
            %rassoc-test %rassoc-test-not)
     (t list function)
     list
     (explicit-check foldable flushable call))
 
-(defknown (%adjoin-key-test %adjoin-key-test-not
-           %member-key-test %member-key-test-not
+(defknown (%adjoin-key-test %adjoin-key-test-not)
+    (t list function function)
+    list
+    (explicit-check flushable call))
+
+(defknown (%member-key-test %member-key-test-not
            %assoc-key-test %assoc-key-test-not
            %rassoc-key-test %rassoc-key-test-not)
     (t list function function)
diff --git a/tests/list.pure.lisp b/tests/list.pure.lisp
index 431275b..7ccdf3c 100644
--- a/tests/list.pure.lisp
+++ b/tests/list.pure.lisp
@@ -373,3 +373,7 @@
 
 ;;; FIND on lists should not call key outside the specified subsquence.
 (assert (not (find :a '(0 (:c) 1) :start 1 :end 2 :key #'car)))
+
+(with-test (:name :adjoin-folding)
+  (flet ((%f () (adjoin 'x '(a b))))
+    (assert (not (eq (%f) (%f))))))
-- 
1.7.10.4