0.9.6.33:

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

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 19377bb..651437a 100644 (file)
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -291,14 +291,13 @@
         (constantly (make-member-type :members (list (specializer-object specl))))))
 
 (defun real-load-defclass (name metaclass-name supers slots other
-                           readers writers slot-names)
+                           readers writers slot-names source-location)
   (with-single-package-locked-error (:symbol name "defining ~S as a class")
     (%compiler-defclass name readers writers slot-names)
     (let ((res (apply #'ensure-class name :metaclass metaclass-name
                       :direct-superclasses supers
                       :direct-slots slots
-                      :definition-source `((defclass ,name)
-                                           ,*load-pathname*)
+                      :definition-source source-location
                       other)))
       res)))
 
@@ -1079,6 +1078,8 @@
          (allocation nil)
          (allocation-class nil)
          (type t)
+         (documentation nil)
+         (documentationp nil)
          (namep  nil)
          (initp  nil)
          (allocp nil))
@@ -1093,6 +1094,10 @@
             (setq initform (slot-definition-initform slotd)
                   initfunction (slot-definition-initfunction slotd)
                   initp t)))
+        (unless documentationp
+          (when (%slot-definition-documentation slotd)
+            (setq documentation (%slot-definition-documentation slotd)
+                  documentationp t)))
         (unless allocp
           (setq allocation (slot-definition-allocation slotd)
                 allocation-class (slot-definition-class slotd)
@@ -1109,7 +1114,8 @@
           :allocation allocation
           :allocation-class allocation-class
           :type type
-          :class class)))
+          :class class
+          :documentation documentation)))
 
 (defmethod compute-effective-slot-definition-initargs :around
     ((class structure-class) direct-slotds)
@@ -1431,9 +1437,14 @@
     (apply #'update-instance-for-different-class copy instance initargs)
     instance))
 
-(defmethod change-class ((instance standard-object)
-                         (new-class standard-class)
+(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")))))
   (change-class-internal instance new-class initargs))
 
 (defmethod change-class ((instance funcallable-standard-object)
@@ -1469,15 +1480,24 @@
 ;;;; But, there are other parts of the protocol we must follow and those
 ;;;; definitions appear here.
 
-(defmethod shared-initialize :before
-           ((class built-in-class) slot-names &rest initargs)
-  (declare (ignore slot-names initargs))
-  (error "attempt to initialize or reinitialize a built in class"))
-
-(defmethod class-direct-slots       ((class built-in-class)) ())
-(defmethod class-slots             ((class built-in-class)) ())
-(defmethod class-direct-default-initargs ((class built-in-class)) ())
-(defmethod class-default-initargs       ((class built-in-class)) ())
+(macrolet ((def (name args control)
+               `(defmethod ,name ,args
+                 (declare (ignore initargs))
+                 (error 'metaobject-initialization-violation
+                  :format-control ,(format nil "~@<~A~@:>" control)
+                  :format-arguments (list ',name)
+                  :references (list '(:amop :initialization "Class"))))))
+  (def initialize-instance ((class built-in-class) &rest initargs)
+    "Cannot ~S an instance of BUILT-IN-CLASS.")
+  (def reinitialize-instance ((class built-in-class) &rest initargs)
+    "Cannot ~S an instance of BUILT-IN-CLASS."))
+
+(macrolet ((def (name)
+               `(defmethod ,name ((class built-in-class)) nil)))
+  (def class-direct-slots)
+  (def class-slots)
+  (def class-direct-default-initargs)
+  (def class-default-initargs))
 
 (defmethod validate-superclass ((c class) (s built-in-class))
   (or (eq s *the-class-t*) (eq s *the-class-stream*)