Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

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
  • Loading branch information...
commit 38329dab20845da6964ffc2b03c6a0778c5498a1 1 parent a4c8f8a
Nikodemus Siivola nikodemus authored
Showing with 20 additions and 2 deletions.
  1. +2 −0  NEWS
  2. +6 −2 src/code/class.lisp
  3. +12 −0 tests/defstruct.impure.lisp
2  NEWS
View
@@ -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)
8 src/code/class.lisp
View
@@ -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))
12 tests/defstruct.impure.lisp
View
@@ -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)))))
Please sign in to comment.
Something went wrong with that request. Please try again.