(allocate-instance class)
(allocate-standard-instance wrapper))))))
+(defmethod class-prototype ((class condition-class))
+ (with-slots (prototype) class
+ (or prototype (setf prototype (allocate-instance class)))))
+
(defmethod class-direct-default-initargs ((class slot-class))
(plist-value class 'direct-default-initargs))
(constantly (make-member-type :members (list (specializer-object specl))))))
\f
-(defun real-load-defclass (name metaclass-name supers slots other)
- (let ((res (apply #'ensure-class name :metaclass metaclass-name
- :direct-superclasses supers
- :direct-slots slots
- :definition-source `((defclass ,name)
- ,*load-pathname*)
- other)))
- res))
+(defun real-load-defclass (name metaclass-name supers slots other
+ readers writers slot-names)
+ (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*)
+ other)))
+ res)))
(setf (gdefinition 'load-defclass) #'real-load-defclass)
args))
(defmethod ensure-class-using-class ((class null) name &rest args &key)
- (without-package-locks
- (multiple-value-bind (meta initargs)
- (ensure-class-values class args)
- (set-class-type-translation (class-prototype meta) name)
- (setf class (apply #'make-instance meta :name name initargs)
- (find-class name) class)
- (set-class-type-translation class name)
- class)))
+ (multiple-value-bind (meta initargs)
+ (ensure-class-values class args)
+ (set-class-type-translation (class-prototype meta) name)
+ (setf class (apply #'make-instance meta :name name initargs))
+ (without-package-locks
+ (setf (find-class name) class))
+ (set-class-type-translation class name)
+ class))
(defmethod ensure-class-using-class ((class pcl-class) name &rest args &key)
- (without-package-locks
- (multiple-value-bind (meta initargs)
- (ensure-class-values class args)
- (unless (eq (class-of class) meta)
- (apply #'change-class class meta initargs))
- (apply #'reinitialize-instance class initargs)
- (setf (find-class name) class)
- (set-class-type-translation class name)
- class)))
+ (multiple-value-bind (meta initargs)
+ (ensure-class-values class args)
+ (unless (eq (class-of class) meta)
+ (apply #'change-class class meta initargs))
+ (apply #'reinitialize-instance class initargs)
+ (without-package-locks
+ (setf (find-class name) class))
+ (set-class-type-translation class name)
+ class))
(defmethod class-predicate-name ((class t))
'constantly-nil)
&key direct-slots direct-superclasses)
(declare (ignore slot-names))
(let ((classoid (find-classoid (class-name class))))
- (with-slots (wrapper class-precedence-list prototype predicate-name
+ (with-slots (wrapper class-precedence-list cpl-available-p
+ prototype predicate-name
(direct-supers direct-superclasses))
class
(setf (slot-value class 'direct-slots)
(setq direct-supers direct-superclasses)
(setq wrapper (classoid-layout classoid))
(setq class-precedence-list (compute-class-precedence-list class))
- (setq prototype (make-condition (class-name class)))
+ (setq cpl-available-p t)
(add-direct-subclasses class direct-superclasses)
(setq predicate-name (make-class-predicate-name (class-name class)))
(make-class-predicate class predicate-name)
instance))))
(defmethod shared-initialize :after
- ((class structure-class)
- slot-names
- &key (direct-superclasses nil direct-superclasses-p)
- (direct-slots nil direct-slots-p)
- direct-default-initargs
- (predicate-name nil predicate-name-p))
+ ((class structure-class)
+ slot-names
+ &key (direct-superclasses nil direct-superclasses-p)
+ (direct-slots nil direct-slots-p)
+ direct-default-initargs
+ (predicate-name nil predicate-name-p))
(declare (ignore slot-names direct-default-initargs))
(if direct-superclasses-p
(setf (slot-value class 'direct-superclasses)
(make-defstruct-allocation-function class)))
(add-direct-subclasses class direct-superclasses)
(setf (slot-value class 'class-precedence-list)
- (compute-class-precedence-list class))
+ (compute-class-precedence-list class))
+ (setf (slot-value class 'cpl-available-p) t)
(setf (slot-value class 'slots) (compute-slots class))
(let ((lclass (find-classoid (class-name class))))
(setf (classoid-pcl-class lclass) class)
(fix-slot-accessors class dslotds 'remove))
(defun fix-slot-accessors (class dslotds add/remove)
- ;; We disable package locks here, since defining a class can trigger
- ;; the update of the accessors of another class -- which might lead
- ;; to package lock violations if we didn't.
- (without-package-locks
- (flet ((fix (gfspec name r/w)
- (let* ((ll (case r/w (r '(object)) (w '(new-value object))))
- (gf (if (fboundp gfspec)
- (ensure-generic-function gfspec)
- (ensure-generic-function gfspec :lambda-list ll))))
- (case r/w
- (r (if (eq add/remove 'add)
- (add-reader-method class gf name)
- (remove-reader-method class gf)))
- (w (if (eq add/remove 'add)
- (add-writer-method class gf name)
- (remove-writer-method class gf)))))))
- (dolist (dslotd dslotds)
- (let ((slot-name (slot-definition-name dslotd)))
- (dolist (r (slot-definition-readers dslotd))
- (fix r slot-name 'r))
- (dolist (w (slot-definition-writers dslotd))
- (fix w slot-name 'w)))))))
+ (flet ((fix (gfspec name r/w)
+ (let ((gf (if (fboundp gfspec)
+ (without-package-locks
+ (ensure-generic-function gfspec))
+ (ensure-generic-function
+ gfspec :lambda-list (case r/w
+ (r '(object))
+ (w '(new-value object)))))))
+ (case r/w
+ (r (if (eq add/remove 'add)
+ (add-reader-method class gf name)
+ (remove-reader-method class gf)))
+ (w (if (eq add/remove 'add)
+ (add-writer-method class gf name)
+ (remove-writer-method class gf)))))))
+ (dolist (dslotd dslotds)
+ (let ((slot-name (slot-definition-name dslotd)))
+ (dolist (r (slot-definition-readers dslotd))
+ (fix r slot-name 'r))
+ (dolist (w (slot-definition-writers dslotd))
+ (fix w slot-name 'w))))))
\f
(defun add-direct-subclasses (class supers)
(dolist (super supers)
(update-cpl class (compute-class-precedence-list class))
;; This invocation of UPDATE-SLOTS, in practice, finalizes the
;; class. The hoops above are to ensure that FINALIZE-INHERITANCE
- ;; is called at finalization, so that MOP programmers can hook
+ ;; is called at finalization, so that MOP programmers can hook
;; into the system as described in "Class Finalization Protocol"
;; (section 5.5.2 of AMOP).
(update-slots class (compute-slots class))
;; Need to have the cpl setup before update-lisp-class-layout
;; is called on CMU CL.
(setf (slot-value class 'class-precedence-list) cpl)
+ (setf (slot-value class 'cpl-available-p) t)
(force-cache-flushes class))
- (setf (slot-value class 'class-precedence-list) cpl))
+ (progn
+ (setf (slot-value class 'class-precedence-list) cpl)
+ (setf (slot-value class 'cpl-available-p) t)))
(update-class-can-precede-p cpl))
(defun update-class-can-precede-p (cpl)
(location -1))
(dolist (eslotd eslotds eslotds)
(setf (slot-definition-location eslotd)
- (ecase (slot-definition-allocation eslotd)
+ (case (slot-definition-allocation eslotd)
(:instance
(incf location))
(:class
(instance-slots ())
(class-slots ()))
(dolist (slotd all-slotds)
- (ecase (slot-definition-allocation slotd)
+ (case (slot-definition-allocation slotd)
(:instance (push slotd instance-slots))
(:class (push slotd class-slots))))
(let ((layout (compute-layout instance-slots)))
projects / sbcl.git / blobdiff