0.8.19.15:

[sbcl.git] / src / pcl / macros.lisp

diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp
index baec938..296aeb4 100644 (file)
--- a/src/pcl/macros.lisp
+++ b/src/pcl/macros.lisp
@@ -75,9 +75,7 @@
 \f
 ;;;; FIND-CLASS
 ;;;;
-;;;; This is documented in the CLOS specification. FIXME: Except that
-;;;; SBCL deviates from the spec by having CL:FIND-CLASS distinct from
-;;;; PCL:FIND-CLASS, alas.
+;;;; This is documented in the CLOS specification.
 
 (/show "pcl/macros.lisp 119")
 
@@ -89,9 +87,6 @@
 (defmacro find-class-cell-predicate (cell)
   `(cadr ,cell))
 
-(defmacro find-class-cell-make-instance-function-keys (cell)
-  `(cddr ,cell))
-
 (defmacro make-find-class-cell (class-name)
   (declare (ignore class-name))
   '(list* nil #'constantly-nil nil))
@@ -110,8 +105,8 @@
 (defun find-class-from-cell (symbol cell &optional (errorp t))
   (or (find-class-cell-class cell)
       (and *create-classes-from-internal-structure-definitions-p*
-          (structure-type-p symbol)
-          (find-structure-class symbol))
+          (or (structure-type-p symbol) (condition-type-p symbol))
+          (ensure-non-standard-class symbol))
       (cond ((null errorp) nil)
            ((legal-class-name-p symbol)
             (error "There is no class named ~S." symbol))
@@ -124,8 +119,7 @@
   (find-class-cell-predicate cell))
 
 (defun legal-class-name-p (x)
-  (and (symbolp x)
-       (not (keywordp x))))
+  (symbolp x))
 
 (defun find-class (symbol &optional (errorp t) environment)
   (declare (ignore environment))
@@ -149,9 +143,6 @@
 
 (/show "pcl/macros.lisp 187")
 
-;;; Note that in SBCL as in CMU CL,
-;;;   COMMON-LISP:FIND-CLASS /= SB-PCL:FIND-CLASS.
-;;; (Yes, this is a KLUDGE!)
 (define-compiler-macro find-class (&whole form
                                   symbol &optional (errorp t) environment)
   (declare (ignore environment))
@@ -166,29 +157,31 @@
           (or (find-class-cell-class ,class-cell)
               ,(if errorp
                    `(find-class-from-cell ',symbol ,class-cell t)
-                   `(and (sb-kernel:class-cell-class
-                          ',(sb-kernel:find-class-cell symbol))
+                   `(and (classoid-cell-classoid
+                          ',(find-classoid-cell symbol))
                          (find-class-from-cell ',symbol ,class-cell nil))))))
       form))
 
-(defun (setf find-class) (new-value symbol)
-  (if (legal-class-name-p symbol)
-      (let ((cell (find-class-cell symbol)))
-       (setf (find-class-cell-class cell) new-value)
-       (when (or (eq *boot-state* 'complete)
-                 (eq *boot-state* 'braid))
-         (when (and new-value (class-wrapper new-value))
-           (setf (find-class-cell-predicate cell)
-                 (fdefinition (class-predicate-name new-value))))
-         (when (and new-value (not (forward-referenced-class-p new-value)))
-
-           (dolist (keys+aok (find-class-cell-make-instance-function-keys
-                              cell))
-             (update-initialize-info-internal
-              (initialize-info new-value (car keys+aok) nil (cdr keys+aok))
-              'make-instance-function))))
-       new-value)
-      (error "~S is not a legal class name." symbol)))
+(defun (setf find-class) (new-value name &optional errorp environment)
+  (declare (ignore errorp environment))
+  (cond ((legal-class-name-p name)
+        (with-single-package-locked-error
+            (:symbol name "using ~A as the class-name argument in ~
+                           (SETF FIND-CLASS)"))
+        (let ((cell (find-class-cell name)))
+          (setf (find-class-cell-class cell) new-value)
+          (when (and (eq *boot-state* 'complete) (null new-value))
+            (setf (find-classoid name) nil))
+          (when (or (eq *boot-state* 'complete)
+                    (eq *boot-state* 'braid))
+            (when (and new-value (class-wrapper new-value)
+                        (class-predicate-name new-value))
+              (setf (find-class-cell-predicate cell)
+                    (fdefinition (class-predicate-name new-value))))
+            (update-ctors 'setf-find-class :class new-value :name name))
+          new-value))
+       (t
+        (error "~S is not a legal class name." name))))
 
 (/show "pcl/macros.lisp 230")