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

diff --git a/NEWS b/NEWS
index 85e34f6..2e658ba 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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")
 \f
 ;;;; 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)))))