0.9.6.36:

[sbcl.git] / src / pcl / std-class.lisp

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 651437a..9952a16 100644 (file)
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -1440,11 +1440,34 @@
 (defmethod change-class ((instance standard-object) (new-class standard-class)
                          &rest initargs)
   (let ((cpl (class-precedence-list new-class)))
-    (when (member (find-class 'method) cpl)
-      (error 'metaobject-initialization-violation
-             :format-control "~@<Cannot ~S objects into ~S metaobjects.~@:>"
-             :format-arguments (list 'change-class 'method)
-             :references (list '(:amop :initialization "Method")))))
+    (dolist (class cpl)
+      (macrolet
+          ((frob (class-name)
+             `(when (eq class (find-class ',class-name))
+               (error 'metaobject-initialization-violation
+                :format-control "~@<Cannot ~S objects into ~S metaobjects.~@:>"
+                :format-arguments (list 'change-class ',class-name)
+                :references (list '(:amop :initialization ,class-name))))))
+        (frob class)
+        (frob generic-function)
+        (frob method)
+        (frob slot-definition))))
+  (change-class-internal instance new-class initargs))
+
+(defmethod change-class ((instance forward-referenced-class)
+                         (new-class standard-class) &rest initargs)
+  (let ((cpl (class-precedence-list new-class)))
+    (dolist (class cpl
+             (error 'metaobject-initialization-violation
+                    :format-control
+                    "~@<Cannot ~S ~S objects into non-~S objects.~@:>"
+                    :format-arguments
+                    (list 'change-class 'forward-referenced-class 'class)
+                    :references
+                    (list '(:amop :generic-function ensure-class-using-class)
+                          '(:amop :initialization class))))
+      (when (eq class (find-class 'class))
+        (return nil))))
   (change-class-internal instance new-class initargs))
 
 (defmethod change-class ((instance funcallable-standard-object)