(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)))
(unless (structure-type-p name) (eval defstruct-form))
(mapc (lambda (dslotd reader-name writer-name)
(let* ((reader (gdefinition reader-name))
- (writer (when (gboundp writer-name)
+ (writer (when (fboundp writer-name)
(gdefinition writer-name))))
(setf (slot-value dslotd 'internal-reader-function)
reader)
(allocation nil)
(allocation-class nil)
(type t)
+ (documentation nil)
+ (documentationp nil)
(namep nil)
(initp nil)
(allocp nil))
(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)
: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)
;;;; 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*)