(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)
;;; the slots predictably, but maybe it would be good to compute some
;;; kind of optimal slot layout by looking at locations of slots in
;;; superclasses?
-(defmethod compute-slots ((class std-class))
+(defun std-compute-slots (class)
;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once
;; for each different slot name we find in our superclasses. Each
;; call receives the class and a list of the dslotds with that name.
(nreverse name-dslotds-alist))))
(defmethod compute-slots ((class standard-class))
- (call-next-method))
+ (std-compute-slots class))
+(defmethod compute-slots ((class funcallable-standard-class))
+ (std-compute-slots class))
-(defmethod compute-slots :around ((class standard-class))
- (let ((eslotds (call-next-method))
- (location -1))
+(defun std-compute-slots-around (class eslotds)
+ (let ((location -1))
(dolist (eslotd eslotds eslotds)
(setf (slot-definition-location eslotd)
(case (slot-definition-allocation eslotd)
(setf (slot-definition-class eslotd) class))
(initialize-internal-slot-functions eslotd))))
-(defmethod compute-slots ((class funcallable-standard-class))
- (call-next-method))
-
+(defmethod compute-slots :around ((class standard-class))
+ (let ((eslotds (call-next-method)))
+ (std-compute-slots-around class eslotds)))
(defmethod compute-slots :around ((class funcallable-standard-class))
- (labels ((instance-slot-names (slotds)
- (let (collect)
- (dolist (slotd slotds (nreverse collect))
- (when (eq (slot-definition-allocation slotd) :instance)
- (push (slot-definition-name slotd) collect)))))
- ;; This sorts slots so that slots of classes later in the CPL
- ;; come before slots of other classes. This is crucial for
- ;; funcallable instances because it ensures that the slots of
- ;; FUNCALLABLE-STANDARD-OBJECT, which includes the slots of
- ;; KERNEL:FUNCALLABLE-INSTANCE, come first, which in turn
- ;; makes it possible to treat FUNCALLABLE-STANDARD-OBJECT as
- ;; a funcallable instance.
- (compute-layout (eslotds)
- (let ((first ())
- (names (instance-slot-names eslotds)))
- (dolist (class
- (reverse (class-precedence-list class))
- (nreverse (nconc names first)))
- (dolist (ss (class-slots class))
- (let ((name (slot-definition-name ss)))
- (when (member name names)
- (push name first)
- (setq names (delete name names)))))))))
- (let ((all-slotds (call-next-method))
- (instance-slots ())
- (class-slots ()))
- (dolist (slotd all-slotds)
- (case (slot-definition-allocation slotd)
- (:instance (push slotd instance-slots))
- (:class (push slotd class-slots))))
- (let ((layout (compute-layout instance-slots)))
- (dolist (slotd instance-slots)
- (setf (slot-definition-location slotd)
- (position (slot-definition-name slotd) layout))
- (initialize-internal-slot-functions slotd)))
- (dolist (slotd class-slots)
- (let ((name (slot-definition-name slotd))
- (from-class (slot-definition-allocation-class slotd)))
- (setf (slot-definition-location slotd)
- (assoc name (class-slot-cells from-class)))
- (aver (consp (slot-definition-location slotd)))
- (initialize-internal-slot-functions slotd)))
- all-slotds)))
+ (let ((eslotds (call-next-method)))
+ (std-compute-slots-around class eslotds)))
(defmethod compute-slots ((class structure-class))
(mapcan (lambda (superclass)
(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)
(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)))
+ (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)
;;;; 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*)
projects / sbcl.git / blobdiff