From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Thu, 29 Mar 2012 15:31:58 +0000 (+0300)
Subject: MAKE-LEXENV used NCONC on its arguments, which callers did not expect
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=09cbe389732a42a2eaeaa5fbe3847a95a10c996e;p=sbcl.git

MAKE-LEXENV used NCONC on its arguments, which callers did not expect

  Fixes lp#924276.
---

diff --git a/NEWS b/NEWS
index 2e658ba..c8d6951 100644
--- a/NEWS
+++ b/NEWS
@@ -6,6 +6,8 @@ changes relative to sbcl-1.0.55:
     (lp#959687)
   * bug fix: (SETF (FIND-CLASS X) NIL) removed proper name of the underlying
     classoid even if X was not the proper name of the class. (lp#941102)
+  * bug fix: declaration leakage between lexical environments due to careless
+    use of NCONC in MAKE-LEXENV. (lp#924276)
   * documentation:
     ** improved docstrings: REPLACE (lp#965592)
 
diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index f62f0a4..731b8db 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -837,7 +837,7 @@
         (reoptimize-lvar prev)))
 
 ;;; Return a new LEXENV just like DEFAULT except for the specified
-;;; slot values. Values for the alist slots are NCONCed to the
+;;; slot values. Values for the alist slots are APPENDed to the
 ;;; beginning of the current value, rather than replacing it entirely.
 (defun make-lexenv (&key (default *lexenv*)
                          funs vars blocks tags
@@ -852,7 +852,7 @@
   (macrolet ((frob (var slot)
                `(let ((old (,slot default)))
                   (if ,var
-                      (nconc ,var old)
+                      (append ,var old)
                       old))))
     (internal-make-lexenv
      (frob funs lexenv-funs)
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 67ded22..bcdfe32 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -4199,3 +4199,13 @@
                          :somethign-else))))
     (assert (and warn fail))
     (assert (not (ignore-errors (funcall fun t))))))
+
+(with-test (:name :bug-924276)
+  (assert (eq :style-warning
+              (handler-case
+                  (compile nil `(lambda (a)
+                                  (cons a (symbol-macrolet ((b 1))
+                                            (declare (ignorable a))
+                                            :c))))
+                (style-warning ()
+                  :style-warning)))))