From 38329dab20845da6964ffc2b03c6a0778c5498a1 Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Wed, 28 Mar 2012 16:46:04 +0300
Subject: [PATCH] more conservative classoid-name clearing

  (SETF (FIND-CLASS X) NIL) should not clear the classoid name if X is
  not the proper name of the class.

  lp#941102
---
 NEWS                        |    2 ++
 src/code/class.lisp         |    8 ++++++--
 tests/defstruct.impure.lisp |   12 ++++++++++++
 3 files changed, 20 insertions(+), 2 deletions(-)

diff --git a/NEWS b/NEWS
index 85e34f6..2e658ba 100644
--- a/NEWS
+++ b/NEWS
@@ -4,6 +4,8 @@ changes relative to sbcl-1.0.55:
     OPEN. (lp#969352, thanks to Kambiz Darabi)
   * bug fix: CASE normal-clauses do not allow T and OTHERWISE as keys.
     (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)
   * documentation:
     ** improved docstrings: REPLACE (lp#965592)
 
diff --git a/src/code/class.lisp b/src/code/class.lisp
index c29bc8f..19edd29 100644
--- a/src/code/class.lisp
+++ b/src/code/class.lisp
@@ -808,8 +808,12 @@
          ;; getting a different cell for a classoid with the same name
          ;; just would not do.
 
-         ;; Remove the proper name of the classoid.
-         (setf (classoid-name (classoid-cell-classoid cell)) nil)
+         ;; Remove the proper name of the classoid, if this was it.
+         (let* ((classoid (classoid-cell-classoid cell))
+                (proper-name (classoid-name classoid)))
+           (when (eq proper-name name)
+             (setf (classoid-name classoid) nil)))
+
          ;; Clear the cell.
          (setf (classoid-cell-classoid cell) nil
                (classoid-cell-pcl-class cell) nil))
diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp
index f9b4145..f676122 100644
--- a/tests/defstruct.impure.lisp
+++ b/tests/defstruct.impure.lisp
@@ -10,6 +10,7 @@
 ;;;; more information.
 
 (load "assertoid.lisp")
+(load "compiler-test-util.lisp")
 (use-package "ASSERTOID")
 
 ;;;; examples from, or close to, the Common Lisp DEFSTRUCT spec
@@ -1127,3 +1128,14 @@ redefinition."
     (handler-bind ((warning #'error))
      (eval `(let ()
               (defstruct destruct-no-warning-not-at-toplevel bar))))))
+
+(with-test (:name :bug-941102)
+  (let ((test `((defstruct bug-941102)
+                 (setf (find-class 'bug-941102-alias) (find-class 'bug-941102))
+                 (setf (find-class 'bug-941102-alias) nil))))
+    (multiple-value-bind (warn fail) (ctu:file-compile test :load t)
+      (assert (not warn))
+      (assert (not fail)))
+    (multiple-value-bind (warn2 fail2) (ctu:file-compile test)
+      (assert (not warn2))
+      (assert (not fail2)))))
-- 
1.7.10.4