X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=975acc43bf1f12dd1be9cb5f869121e9e7aa13b6;hb=441dfe5655f1ec3ee96e7b17b7cb1c7a4a906117;hp=d03f94ebf9f71ce15a702fa164d9f0d1169fc53c;hpb=fb9c34275389e23f32d80954ab4848fac48936d9;p=sbcl.git diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index d03f94e..975acc4 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -24,18 +24,20 @@ (in-package "SB-PCL") (defmethod slot-accessor-function ((slotd effective-slot-definition) type) - (ecase type - (reader (slot-definition-reader-function slotd)) - (writer (slot-definition-writer-function slotd)) - (boundp (slot-definition-boundp-function slotd)))) + (let ((info (slot-definition-info slotd))) + (ecase type + (reader (slot-info-reader info)) + (writer (slot-info-writer info)) + (boundp (slot-info-boundp info))))) (defmethod (setf slot-accessor-function) (function - (slotd effective-slot-definition) - type) - (ecase type - (reader (setf (slot-definition-reader-function slotd) function)) - (writer (setf (slot-definition-writer-function slotd) function)) - (boundp (setf (slot-definition-boundp-function slotd) function)))) + (slotd effective-slot-definition) + type) + (let ((info (slot-definition-info slotd))) + (ecase type + (reader (setf (slot-info-reader info) function)) + (writer (setf (slot-info-writer info) function)) + (boundp (setf (slot-info-boundp info) function))))) (defconstant +slotd-reader-function-std-p+ 1) (defconstant +slotd-writer-function-std-p+ 2) @@ -46,45 +48,67 @@ (let ((flags (slot-value slotd 'accessor-flags))) (declare (type fixnum flags)) (if (eq type 'all) - (eql +slotd-all-function-std-p+ flags) - (let ((mask (ecase type - (reader +slotd-reader-function-std-p+) - (writer +slotd-writer-function-std-p+) - (boundp +slotd-boundp-function-std-p+)))) - (declare (type fixnum mask)) - (not (zerop (the fixnum (logand mask flags)))))))) + (eql +slotd-all-function-std-p+ flags) + (let ((mask (ecase type + (reader +slotd-reader-function-std-p+) + (writer +slotd-writer-function-std-p+) + (boundp +slotd-boundp-function-std-p+)))) + (declare (type fixnum mask)) + (not (zerop (the fixnum (logand mask flags)))))))) (defmethod (setf slot-accessor-std-p) (value - (slotd effective-slot-definition) - type) + (slotd effective-slot-definition) + type) (let ((mask (ecase type - (reader +slotd-reader-function-std-p+) - (writer +slotd-writer-function-std-p+) - (boundp +slotd-boundp-function-std-p+))) - (flags (slot-value slotd 'accessor-flags))) + (reader +slotd-reader-function-std-p+) + (writer +slotd-writer-function-std-p+) + (boundp +slotd-boundp-function-std-p+))) + (flags (slot-value slotd 'accessor-flags))) (declare (type fixnum mask flags)) (setf (slot-value slotd 'accessor-flags) - (if value - (the fixnum (logior mask flags)) - (the fixnum (logand (the fixnum (lognot mask)) flags))))) + (if value + (the fixnum (logior mask flags)) + (the fixnum (logand (the fixnum (lognot mask)) flags))))) value) -(defmethod initialize-internal-slot-functions ((slotd - effective-slot-definition)) +(defmethod initialize-internal-slot-functions + ((slotd effective-slot-definition)) (let* ((name (slot-value slotd 'name)) - (class (slot-value slotd 'class))) - (let ((table (or (gethash name *name->class->slotd-table*) - (setf (gethash name *name->class->slotd-table*) - (make-hash-table :test 'eq :size 5))))) - (setf (gethash class table) slotd)) + (class (slot-value slotd '%class))) (dolist (type '(reader writer boundp)) (let* ((gf-name (ecase type - (reader 'slot-value-using-class) - (writer '(setf slot-value-using-class)) - (boundp 'slot-boundp-using-class))) - (gf (gdefinition gf-name))) - (compute-slot-accessor-info slotd type gf))) - (initialize-internal-slot-gfs name))) + (reader 'slot-value-using-class) + (writer '(setf slot-value-using-class)) + (boundp 'slot-boundp-using-class))) + (gf (gdefinition gf-name))) + ;; KLUDGE: this logic is cut'n'pasted from + ;; GET-ACCESSOR-METHOD-FUNCTION, which (for STD-CLASSes) is + ;; only called later, because it does things that can't be + ;; computed this early in class finalization; however, we need + ;; this bit as early as possible. -- CSR, 2009-11-05 + (setf (slot-accessor-std-p slotd type) + (let* ((std-method (standard-svuc-method type)) + (str-method (structure-svuc-method type)) + (types1 `((eql ,class) (class-eq ,class) (eql ,slotd))) + (types (if (eq type 'writer) `(t ,@types1) types1)) + (methods (compute-applicable-methods-using-types gf types))) + (null (cdr methods)))) + (setf (slot-accessor-function slotd type) + (lambda (&rest args) + (declare (dynamic-extent args)) + ;; FIXME: a tiny amount of wasted SLOT-ACCESSOR-STD-P + ;; work here (see KLUDGE comment above). + (let ((fun (compute-slot-accessor-info slotd type gf))) + (apply fun args)))))))) + +(defmethod finalize-internal-slot-functions ((slotd effective-slot-definition)) + (dolist (type '(reader writer boundp)) + (let* ((gf-name (ecase type + (reader 'slot-value-using-class) + (writer '(setf slot-value-using-class)) + (boundp 'slot-boundp-using-class))) + (gf (gdefinition gf-name))) + (compute-slot-accessor-info slotd type gf)))) ;;; CMUCL (Gerd PCL 2003-04-25) comment: ;;; @@ -101,19 +125,15 @@ ;;; FIXME: Change the function name to COMPUTE-SVUC-SLOTD-FUNCTION, ;;; or some such. (defmethod compute-slot-accessor-info ((slotd effective-slot-definition) - type gf) + type gf) (let* ((name (slot-value slotd 'name)) - (class (slot-value slotd 'class)) - (old-slotd (find-slot-definition class name)) - (old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all)))) + (class (slot-value slotd '%class))) (multiple-value-bind (function std-p) - (if (eq *boot-state* 'complete) - (get-accessor-method-function gf type class slotd) - (get-optimized-std-accessor-method-function class slotd type)) + (if (eq **boot-state** 'complete) + (get-accessor-method-function gf type class slotd) + (get-optimized-std-accessor-method-function class slotd type)) (setf (slot-accessor-std-p slotd type) std-p) - (setf (slot-accessor-function slotd type) function)) - (when (and old-slotd (not (eq old-std-p (slot-accessor-std-p slotd 'all)))) - (push (cons class name) *pv-table-cache-update-info*)))) + (setf (slot-accessor-function slotd type) function)))) (defmethod slot-definition-allocation ((slotd structure-slot-definition)) :instance) @@ -121,17 +141,21 @@ ;;;; various class accessors that are a little more complicated than can be ;;;; done with automatically generated reader methods -(defmethod class-prototype ((class std-class)) - (with-slots (prototype) class - (or prototype (setq prototype (allocate-instance class))))) - -(defmethod class-prototype ((class structure-class)) - (with-slots (prototype wrapper defstruct-constructor) class - (or prototype - (setq prototype - (if defstruct-constructor - (allocate-instance class) - (allocate-standard-instance wrapper)))))) +(defmethod class-prototype :before (class) + (unless (class-finalized-p class) + (error "~@<~S is not finalized.~:@>" class))) + +;;; KLUDGE: For some reason factoring the common body into a function +;;; breaks PCL bootstrapping, so just generate it with a macrolet for +;;; all. +(macrolet ((def (class) + `(defmethod class-prototype ((class ,class)) + (with-slots (prototype) class + (or prototype + (setf prototype (allocate-instance class))))))) + (def std-class) + (def condition-class) + (def structure-class)) (defmethod class-direct-default-initargs ((class slot-class)) (plist-value class 'direct-default-initargs)) @@ -141,6 +165,8 @@ (defmethod class-slot-cells ((class std-class)) (plist-value class 'class-slot-cells)) +(defmethod (setf class-slot-cells) (new-value (class std-class)) + (setf (plist-value class 'class-slot-cells) new-value)) ;;;; class accessors that are even a little bit more complicated than those ;;;; above. These have a protocol for updating them, we must implement that @@ -150,7 +176,7 @@ ;;; here, the values are read by an automatically generated reader method. (defmethod add-direct-subclass ((class class) (subclass class)) (with-slots (direct-subclasses) class - (pushnew subclass direct-subclasses) + (pushnew subclass direct-subclasses :test #'eq) subclass)) (defmethod remove-direct-subclass ((class class) (subclass class)) (with-slots (direct-subclasses) class @@ -172,15 +198,40 @@ ;;; In each case, we maintain one value which is a cons. The car is the list ;;; methods. The cdr is a list of the generic functions. The cdr is always ;;; computed lazily. + +;;; This needs to be used recursively, in case a non-trivial user +;;; defined ADD/REMOVE-DIRECT-METHOD method ends up calling another +;;; function using the same lock. +(defvar *specializer-lock* (sb-thread:make-mutex :name "Specializer lock")) + +(defmethod add-direct-method :around ((specializer specializer) method) + ;; All the actions done under this lock are done in an order + ;; that is safe to unwind at any point. + (sb-thread::with-recursive-system-lock (*specializer-lock*) + (call-next-method))) + +(defmethod remove-direct-method :around ((specializer specializer) method) + ;; All the actions done under this lock are done in an order + ;; that is safe to unwind at any point. + (sb-thread::with-recursive-system-lock (*specializer-lock*) + (call-next-method))) + (defmethod add-direct-method ((specializer class) (method method)) - (with-slots (direct-methods) specializer - (setf (car direct-methods) (adjoin method (car direct-methods)) ;PUSH - (cdr direct-methods) ())) + (let ((cell (slot-value specializer 'direct-methods))) + ;; We need to first smash the CDR, because a parallel read may + ;; be in progress, and because if an interrupt catches us we + ;; need to have a consistent state. + (setf (cdr cell) () + (car cell) (adjoin method (car cell) :test #'eq))) method) + (defmethod remove-direct-method ((specializer class) (method method)) - (with-slots (direct-methods) specializer - (setf (car direct-methods) (remove method (car direct-methods)) - (cdr direct-methods) ())) + (let ((cell (slot-value specializer 'direct-methods))) + ;; We need to first smash the CDR, because a parallel read may + ;; be in progress, and because if an interrupt catches us we + ;; need to have a consistent state. + (setf (cdr cell) () + (car cell) (remove method (car cell)))) method) (defmethod specializer-direct-methods ((specializer class)) @@ -188,20 +239,26 @@ (car direct-methods))) (defmethod specializer-direct-generic-functions ((specializer class)) - (with-slots (direct-methods) specializer - (or (cdr direct-methods) - (setf (cdr direct-methods) - (let (collect) - (dolist (m (car direct-methods)) - ;; the old PCL code used COLLECTING-ONCE which used - ;; #'EQ to check for newness - (pushnew (method-generic-function m) collect :test #'eq)) - (nreverse collect)))))) + (let ((cell (slot-value specializer 'direct-methods))) + ;; If an ADD/REMOVE-METHOD is in progress, no matter: either + ;; we behave as if we got just first or just after -- it's just + ;; for update that we need to lock. + (or (cdr cell) + (sb-thread:with-mutex (*specializer-lock*) + (setf (cdr cell) + (let (collect) + (dolist (m (car cell)) + ;; the old PCL code used COLLECTING-ONCE which used + ;; #'EQ to check for newness + (pushnew (method-generic-function m) collect :test #'eq)) + (nreverse collect))))))) ;;; This hash table is used to store the direct methods and direct generic ;;; functions of EQL specializers. Each value in the table is the cons. -(defvar *eql-specializer-methods* (make-hash-table :test 'eql)) -(defvar *class-eq-specializer-methods* (make-hash-table :test 'eq)) +;;; +;;; These tables are shared between threads, so they need to be synchronized. +(defvar *eql-specializer-methods* (make-hash-table :test 'eql :synchronized t)) +(defvar *class-eq-specializer-methods* (make-hash-table :test 'eq :synchronized t)) (defmethod specializer-method-table ((specializer eql-specializer)) *eql-specializer-methods*) @@ -210,308 +267,235 @@ *class-eq-specializer-methods*) (defmethod add-direct-method ((specializer specializer-with-object) - (method method)) + (method method)) (let* ((object (specializer-object specializer)) - (table (specializer-method-table specializer)) - (entry (gethash object table))) + (table (specializer-method-table specializer)) + (entry (gethash object table))) (unless entry - (setq entry - (setf (gethash object table) - (cons nil nil)))) - (setf (car entry) (adjoin method (car entry)) - (cdr entry) ()) + (setf entry + (setf (gethash object table) (cons nil nil)))) + ;; We need to first smash the CDR, because a parallel read may + ;; be in progress, and because if an interrupt catches us we + ;; need to have a consistent state. + (setf (cdr entry) () + (car entry) (adjoin method (car entry) :test #'eq)) method)) (defmethod remove-direct-method ((specializer specializer-with-object) - (method method)) + (method method)) (let* ((object (specializer-object specializer)) - (entry (gethash object (specializer-method-table specializer)))) + (entry (gethash object (specializer-method-table specializer)))) (when entry - (setf (car entry) (remove method (car entry)) - (cdr entry) ())) + ;; We need to first smash the CDR, because a parallel read may + ;; be in progress, and because if an interrupt catches us we + ;; need to have a consistent state. + (setf (cdr entry) () + (car entry) (remove method (car entry)))) method)) (defmethod specializer-direct-methods ((specializer specializer-with-object)) (car (gethash (specializer-object specializer) - (specializer-method-table specializer)))) + (specializer-method-table specializer)))) (defmethod specializer-direct-generic-functions ((specializer - specializer-with-object)) + specializer-with-object)) (let* ((object (specializer-object specializer)) - (entry (gethash object (specializer-method-table specializer)))) + (entry (gethash object (specializer-method-table specializer)))) (when entry (or (cdr entry) - (setf (cdr entry) - (let (collect) - (dolist (m (car entry)) - (pushnew (method-generic-function m) collect :test #'eq)) - (nreverse collect))))))) + (sb-thread:with-mutex (*specializer-lock*) + (setf (cdr entry) + (let (collect) + (dolist (m (car entry)) + (pushnew (method-generic-function m) collect :test #'eq)) + (nreverse collect)))))))) (defun map-specializers (function) (map-all-classes (lambda (class) - (funcall function (class-eq-specializer class)) - (funcall function class))) + (funcall function (class-eq-specializer class)) + (funcall function class))) (maphash (lambda (object methods) - (declare (ignore methods)) - (intern-eql-specializer object)) - *eql-specializer-methods*) + (declare (ignore methods)) + (intern-eql-specializer object)) + *eql-specializer-methods*) (maphash (lambda (object specl) - (declare (ignore object)) - (funcall function specl)) - *eql-specializer-table*) + (declare (ignore object)) + (funcall function specl)) + *eql-specializer-table*) nil) (defun map-all-generic-functions (function) (let ((all-generic-functions (make-hash-table :test 'eq))) (map-specializers (lambda (specl) - (dolist (gf (specializer-direct-generic-functions - specl)) - (unless (gethash gf all-generic-functions) - (setf (gethash gf all-generic-functions) t) - (funcall function gf)))))) + (dolist (gf (specializer-direct-generic-functions + specl)) + (unless (gethash gf all-generic-functions) + (setf (gethash gf all-generic-functions) t) + (funcall function gf)))))) nil) (defmethod shared-initialize :after ((specl class-eq-specializer) - slot-names - &key) + slot-names + &key) (declare (ignore slot-names)) - (setf (slot-value specl 'type) `(class-eq ,(specializer-class specl)))) + (setf (slot-value specl '%type) `(class-eq ,(specializer-class specl)))) (defmethod shared-initialize :after ((specl eql-specializer) slot-names &key) (declare (ignore slot-names)) - (setf (slot-value specl 'type) `(eql ,(specializer-object specl)))) - -(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)) + (setf (slot-value specl '%type) + `(eql ,(specializer-object specl))) + (setf (info :type :translator specl) + (constantly (make-member-type :members (list (specializer-object specl)))))) + +(defun real-load-defclass (name metaclass-name supers slots other + readers writers slot-names source-location safe-p) + (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 source-location + 'safe-p safe-p + other))) + res))) (setf (gdefinition 'load-defclass) #'real-load-defclass) (defun ensure-class (name &rest args) - (apply #'ensure-class-using-class - (let ((class (find-class name nil))) - (when (and class (eq name (class-name class))) - ;; NAME is the proper name of CLASS, so redefine it - class)) - name - args)) + (with-world-lock () + (apply #'ensure-class-using-class + (let ((class (find-class name nil))) + (when (and class (eq name (class-name class))) + ;; NAME is the proper name of CLASS, so redefine it + class)) + name + args))) (defmethod ensure-class-using-class ((class null) name &rest args &key) - (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)) + (with-world-lock () + (multiple-value-bind (meta initargs) + (frob-ensure-class-args args) + (setf class (apply #'make-instance meta :name name initargs)) + (without-package-locks + (setf (find-class name) class)))) + ;; After boot (SETF FIND-CLASS) does this. + (unless (eq **boot-state** 'complete) + (%set-class-type-translation class name)) + class) (defmethod ensure-class-using-class ((class pcl-class) name &rest args &key) - (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)) - -(defmethod class-predicate-name ((class t)) - 'constantly-nil) - -(defun fix-super (s) - (cond ((classp s) s) - ((not (legal-class-name-p s)) - (error "~S is not a class or a legal class name." s)) - (t - (or (find-class s nil) - (make-instance 'forward-referenced-class - :name s))))) - -(defun ensure-class-values (class args) - (let* ((initargs (copy-list args)) - (unsupplied (list 1)) - (supplied-meta (getf initargs :metaclass unsupplied)) - (supplied-supers (getf initargs :direct-superclasses unsupplied)) - (supplied-slots (getf initargs :direct-slots unsupplied)) - (meta - (cond ((neq supplied-meta unsupplied) - (find-class supplied-meta)) - ((or (null class) - (forward-referenced-class-p class)) - *the-class-standard-class*) - (t - (class-of class))))) - ;; KLUDGE: It seemed to me initially that there ought to be a way - ;; of collecting all the erroneous problems in one go, rather than - ;; this way of solving the problem of signalling the errors that - ;; we are required to, which stops at the first bogus input. - ;; However, after playing around a little, I couldn't find that - ;; way, so I've left it as is, but if someone does come up with a - ;; better way... -- CSR, 2002-09-08 - (do ((direct-slots (getf initargs :direct-slots) (cdr direct-slots))) - ((endp direct-slots) nil) - (destructuring-bind (slot &rest more) direct-slots - (let ((slot-name (getf slot :name))) - (when (some (lambda (s) (eq slot-name (getf s :name))) more) - ;; FIXME: It's quite possible that we ought to define an - ;; SB-INT:PROGRAM-ERROR function to signal these and other - ;; errors throughout the codebase that are required to be - ;; of type PROGRAM-ERROR. - (error 'simple-program-error - :format-control "~@" - :format-arguments (list slot-name))) - (do ((stuff slot (cddr stuff))) - ((endp stuff) nil) - (destructuring-bind (option value &rest more) stuff - (cond - ((and (member option '(:allocation :type - :initform :documentation)) - (not (eq unsupplied - (getf more option unsupplied)))) - (error 'simple-program-error - :format-control "~@" - :format-arguments (list option slot-name))) - ((and (eq option :readers) - (notevery #'symbolp value)) - (error 'simple-program-error - :format-control "~@" - :format-arguments (list slot-name))) - ((and (eq option :initargs) - (notevery #'symbolp value)) - (error 'simple-program-error - :format-control "~@" - :format-arguments (list slot-name))))))))) - (loop for (initarg . more) on (getf initargs :direct-default-initargs) - for name = (car initarg) - when (some (lambda (a) (eq (car a) name)) more) - do (error 'simple-program-error - :format-control "~@" - :format-arguments (list name class))) - (let ((metaclass 0) - (default-initargs 0)) - (do ((args initargs (cddr args))) - ((endp args) nil) - (case (car args) - (:metaclass - (when (> (incf metaclass) 1) - (error 'simple-program-error - :format-control "~@"))) - (:direct-default-initargs - (when (> (incf default-initargs) 1) - (error 'simple-program-error - :format-control "~@")))))) - (remf initargs :metaclass) - (loop (unless (remf initargs :direct-superclasses) (return))) - (loop (unless (remf initargs :direct-slots) (return))) - (values - meta - (nconc - (when (neq supplied-supers unsupplied) - (list :direct-superclasses (mapcar #'fix-super supplied-supers))) - (when (neq supplied-slots unsupplied) - (list :direct-slots supplied-slots)) - initargs)))) + (with-world-lock () + (multiple-value-bind (meta initargs) + (frob-ensure-class-args 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)))) + ;; After boot (SETF FIND-CLASS) does this. + (unless (eq **boot-state** 'complete) + (%set-class-type-translation class name)) + class) + +(defun frob-ensure-class-args (args) + (let (metaclass metaclassp reversed-plist) + (flet ((frob-superclass (s) + (cond + ((classp s) s) + ((legal-class-name-p s) + (or (find-class s nil) + (ensure-class s :metaclass 'forward-referenced-class))) + (t (error "Not a class or a legal class name: ~S." s))))) + (doplist (key val) args + (cond ((eq key :metaclass) + (unless metaclassp + (setf metaclass val metaclassp key))) + (t + (when (eq key :direct-superclasses) + (setf val (mapcar #'frob-superclass val))) + (setf reversed-plist (list* val key reversed-plist))))) + (values (cond (metaclassp + (if (classp metaclass) + metaclass + (find-class metaclass))) + (t *the-class-standard-class*)) + (nreverse reversed-plist))))) + +;;; This is used to call initfunctions of :allocation :class slots. +(defun call-initfun (fun slotd safe) + (declare (function fun)) + (let ((value (funcall fun))) + (when safe + (let ((type (slot-definition-type slotd))) + (unless (or (eq t type) + (typep value type)) + (error 'type-error :expected-type type :datum value)))) + value)) (defmethod shared-initialize :after - ((class std-class) - slot-names - &key (direct-superclasses nil direct-superclasses-p) - (direct-slots nil direct-slots-p) - (direct-default-initargs nil direct-default-initargs-p) - (predicate-name nil predicate-name-p)) + ((class std-class) slot-names &key + (direct-superclasses nil direct-superclasses-p) + (direct-slots nil direct-slots-p) + (direct-default-initargs nil direct-default-initargs-p) + definition-source) (cond (direct-superclasses-p - (setq direct-superclasses - (or direct-superclasses - (list (if (funcallable-standard-class-p class) - *the-class-funcallable-standard-object* - *the-class-standard-object*)))) - (dolist (superclass direct-superclasses) - (unless (validate-superclass class superclass) - (error "The class ~S was specified as a~% - super-class of the class ~S;~%~ - but the meta-classes ~S and~%~S are incompatible.~@ - Define a method for ~S to avoid this error." - superclass class (class-of superclass) (class-of class) - 'validate-superclass))) - (setf (slot-value class 'direct-superclasses) direct-superclasses)) - (t - (setq direct-superclasses (slot-value class 'direct-superclasses)))) + (setq direct-superclasses + (or direct-superclasses + (list (if (funcallable-standard-class-p class) + *the-class-funcallable-standard-object* + *the-class-standard-object*)))) + (dolist (superclass direct-superclasses) + (unless (validate-superclass class superclass) + (error "~@" + superclass class (class-of superclass) (class-of class) + 'validate-superclass))) + (setf (slot-value class 'direct-superclasses) direct-superclasses)) + (t + (setq direct-superclasses (slot-value class 'direct-superclasses)))) (setq direct-slots - (if direct-slots-p - (setf (slot-value class 'direct-slots) - (mapcar (lambda (pl) (make-direct-slotd class pl)) - direct-slots)) - (slot-value class 'direct-slots))) + (if direct-slots-p + (setf (slot-value class 'direct-slots) + (mapcar (lambda (pl) (make-direct-slotd class pl)) + direct-slots)) + (slot-value class 'direct-slots))) (if direct-default-initargs-p (setf (plist-value class 'direct-default-initargs) - direct-default-initargs) + direct-default-initargs) (setq direct-default-initargs - (plist-value class 'direct-default-initargs))) + (plist-value class 'direct-default-initargs))) (setf (plist-value class 'class-slot-cells) - (let ((old-class-slot-cells (plist-value class 'class-slot-cells)) - (collect '())) - (dolist (dslotd direct-slots) - (when (eq :class (slot-definition-allocation dslotd)) - ;; see CLHS 4.3.6 - (let* ((name (slot-definition-name dslotd)) - (old (assoc name old-class-slot-cells))) - (if (or (not old) - (eq t slot-names) - (member name slot-names)) - (let* ((initfunction (slot-definition-initfunction dslotd)) - (value (if initfunction - (funcall initfunction) - +slot-unbound+))) - (push (cons name value) collect)) - (push old collect))))) + (let ((old-class-slot-cells (plist-value class 'class-slot-cells)) + (safe (safe-p class)) + (collect '())) + (dolist (dslotd direct-slots) + (when (eq :class (slot-definition-allocation dslotd)) + ;; see CLHS 4.3.6 + (let* ((name (slot-definition-name dslotd)) + (old (assoc name old-class-slot-cells))) + (if (or (not old) + (eq t slot-names) + (member name slot-names :test #'eq)) + (let* ((initfunction (slot-definition-initfunction dslotd)) + (value + (if initfunction + (call-initfun initfunction dslotd safe) + +slot-unbound+))) + (push (cons name value) collect)) + (push old collect))))) (nreverse collect))) - (setq predicate-name (if predicate-name-p - (setf (slot-value class 'predicate-name) - (car predicate-name)) - (or (slot-value class 'predicate-name) - (setf (slot-value class 'predicate-name) - (make-class-predicate-name (class-name - class)))))) (add-direct-subclasses class direct-superclasses) - (make-class-predicate class predicate-name) - (update-class class nil) - (do* ((slots (slot-value class 'slots) (cdr slots)) - (dupes nil)) - ((null slots) (when dupes - (style-warn - ;; FIXME: the indentation request ("~4I") - ;; below appears not to do anything. Finding - ;; out why would be nice. -- CSR, 2003-04-24 - "~@~@:>" - class - dupes))) - (let* ((slot (car slots)) - (oslots (remove (slot-definition-name slot) (cdr slots) - :test #'string/= :key #'slot-definition-name))) - (when oslots - (pushnew (cons (slot-definition-name slot) - (mapcar #'slot-definition-name oslots)) - dupes - :test #'string= :key #'car)))) - (add-slot-accessors class direct-slots) + (if (class-finalized-p class) + ;; required by AMOP, "Reinitialization of Class Metaobjects" + (finalize-inheritance class) + (update-class class nil)) + (add-slot-accessors class direct-slots definition-source) (make-preliminary-layout class)) (defmethod shared-initialize :after ((class forward-referenced-class) - slot-names &key &allow-other-keys) + slot-names &key &allow-other-keys) (declare (ignore slot-names)) (make-preliminary-layout class)) @@ -521,89 +505,110 @@ ;;; make it known to the type system. (defun make-preliminary-layout (class) (flet ((compute-preliminary-cpl (root) - (let ((*allow-forward-referenced-classes-in-cpl-p* t)) - (compute-class-precedence-list root)))) - (unless (class-finalized-p class) - (let ((name (class-name class))) - (setf (find-class name) class) - ;; KLUDGE: This is fairly horrible. We need to make a - ;; full-fledged CLASSOID here, not just tell the compiler that - ;; some class is forthcoming, because there are legitimate - ;; questions one can ask of the type system, implemented in - ;; terms of CLASSOIDs, involving forward-referenced classes. So. - (when (and (eq *boot-state* 'complete) - (null (find-classoid name nil))) - (setf (find-classoid name) - (make-standard-classoid :name name))) - (set-class-type-translation class name) - (let ((layout (make-wrapper 0 class)) - (classoid (find-classoid name))) - (setf (layout-classoid layout) classoid) - (setf (classoid-pcl-class classoid) class) - (setf (slot-value class 'wrapper) layout) - (let ((cpl (compute-preliminary-cpl class))) - (setf (layout-inherits layout) - (order-layout-inherits - (map 'simple-vector #'class-wrapper - (reverse (rest cpl)))))) - (register-layout layout :invalidate t) - (setf (classoid-layout classoid) layout) - (mapc #'make-preliminary-layout (class-direct-subclasses class))))))) + (let ((*allow-forward-referenced-classes-in-cpl-p* t)) + (compute-class-precedence-list root)))) + (with-world-lock () + (without-package-locks + (unless (class-finalized-p class) + (let ((name (class-name class))) + ;; KLUDGE: This is fairly horrible. We need to make a + ;; full-fledged CLASSOID here, not just tell the compiler that + ;; some class is forthcoming, because there are legitimate + ;; questions one can ask of the type system, implemented in + ;; terms of CLASSOIDs, involving forward-referenced classes. So. + (let ((layout (make-wrapper 0 class))) + (setf (slot-value class 'wrapper) layout) + (let ((cpl (compute-preliminary-cpl class))) + (setf (layout-inherits layout) + (order-layout-inherits + (map 'simple-vector #'class-wrapper + (reverse (rest cpl)))))) + (register-layout layout :invalidate t) + (%set-class-type-translation class (layout-classoid layout))))) + (mapc #'make-preliminary-layout (class-direct-subclasses class)))))) (defmethod shared-initialize :before ((class class) slot-names &key name) (declare (ignore slot-names name)) ;; FIXME: Could this just be CLASS instead of `(CLASS ,CLASS)? If not, ;; why not? (See also similar expression in !BOOTSTRAP-INITIALIZE-CLASS.) - (setf (slot-value class 'type) `(class ,class)) + (setf (slot-value class '%type) `(class ,class)) (setf (slot-value class 'class-eq-specializer) - (make-instance 'class-eq-specializer :class class))) + (make-instance 'class-eq-specializer :class class))) -(defmethod reinitialize-instance :before ((class slot-class) &key) - (remove-direct-subclasses class (class-direct-superclasses class)) - (remove-slot-accessors class (class-direct-slots class))) +(defmethod reinitialize-instance :before ((class slot-class) &key direct-superclasses) + (dolist (old-super (set-difference (class-direct-superclasses class) direct-superclasses)) + (remove-direct-subclass old-super class)) + (remove-slot-accessors class (class-direct-slots class))) (defmethod reinitialize-instance :after ((class slot-class) - &rest initargs - &key) + &rest initargs + &key) (map-dependents class - (lambda (dependent) - (apply #'update-dependent class dependent initargs)))) + (lambda (dependent) + (apply #'update-dependent class dependent initargs)))) + +(defmethod reinitialize-instance :after ((class condition-class) &key) + (let* ((name (class-name class)) + (classoid (find-classoid name)) + (slots (condition-classoid-slots classoid))) + ;; to balance the REMOVE-SLOT-ACCESSORS call in + ;; REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS). + (dolist (slot slots) + (let ((slot-name (condition-slot-name slot))) + (dolist (reader (condition-slot-readers slot)) + ;; FIXME: see comment in SHARED-INITIALIZE :AFTER + ;; (CONDITION-CLASS T), below. -- CSR, 2005-11-18 + (sb-kernel::install-condition-slot-reader reader name slot-name)) + (dolist (writer (condition-slot-writers slot)) + (sb-kernel::install-condition-slot-writer writer name slot-name)))))) (defmethod shared-initialize :after ((class condition-class) slot-names - &key direct-slots direct-superclasses) + &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 - (direct-supers direct-superclasses)) - class + (let ((classoid (find-classoid (slot-value class 'name)))) + (with-slots (wrapper + %class-precedence-list cpl-available-p finalized-p + prototype (direct-supers direct-superclasses) + plist) + class (setf (slot-value class 'direct-slots) - (mapcar (lambda (pl) (make-direct-slotd class pl)) - direct-slots)) - (setf (slot-value class 'finalized-p) t) - (setf (classoid-pcl-class classoid) class) - (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))) + (mapcar (lambda (pl) (make-direct-slotd class pl)) + direct-slots) + finalized-p t + (classoid-pcl-class classoid) class + direct-supers direct-superclasses + wrapper (classoid-layout classoid) + %class-precedence-list (compute-class-precedence-list class) + cpl-available-p t + (getf plist 'direct-default-initargs) + (sb-kernel::condition-classoid-direct-default-initargs classoid)) (add-direct-subclasses class direct-superclasses) - (setq predicate-name (make-class-predicate-name (class-name class))) - (make-class-predicate class predicate-name) - (setf (slot-value class 'slots) (compute-slots class)))) + (let ((slots (compute-slots class))) + (setf (slot-value class 'slots) slots) + (setf (layout-slot-table wrapper) (make-slot-table class slots))))) ;; Comment from Gerd's PCL, 2003-05-15: ;; ;; We don't ADD-SLOT-ACCESSORS here because we don't want to ;; override condition accessors with generic functions. We do this ;; differently. - (update-pv-table-cache-info class)) + ;; + ;; ??? What does the above comment mean and why is it a good idea? + ;; CMUCL (which still as of 2005-11-18 uses this code and has this + ;; comment) loses slot information in its condition classes: + ;; DIRECT-SLOTS is always NIL. We have the right information, so we + ;; remove slot accessors but never put them back. I've added a + ;; REINITIALIZE-INSTANCE :AFTER (CONDITION-CLASS) method, but what + ;; was meant to happen? -- CSR, 2005-11-18 + ) (defmethod direct-slot-definition-class ((class condition-class) - &rest initargs) + &rest initargs) (declare (ignore initargs)) (find-class 'condition-direct-slot-definition)) (defmethod effective-slot-definition-class ((class condition-class) - &rest initargs) + &rest initargs) (declare (ignore initargs)) (find-class 'condition-effective-slot-definition)) @@ -613,36 +618,37 @@ (defmethod compute-effective-slot-definition ((class condition-class) slot-name dslotds) - (let ((slotd (call-next-method))) - (setf (slot-definition-reader-function slotd) - (lambda (x) - (handler-case (condition-reader-function x slot-name) - ;; FIXME: FIND-SLOT-DEFAULT throws an error if the slot - ;; is unbound; maybe it should be a CELL-ERROR of some - ;; sort? - (error () (values (slot-unbound class x slot-name)))))) - (setf (slot-definition-writer-function slotd) - (lambda (v x) - (condition-writer-function x v slot-name))) - (setf (slot-definition-boundp-function slotd) - (lambda (x) - (multiple-value-bind (v c) - (ignore-errors (condition-reader-function x slot-name)) - (declare (ignore v)) - (null c)))) + (let* ((slotd (call-next-method)) + (info (slot-definition-info slotd))) + (setf (slot-info-reader info) + (lambda (x) + (handler-case (condition-reader-function x slot-name) + ;; FIXME: FIND-SLOT-DEFAULT throws an error if the slot + ;; is unbound; maybe it should be a CELL-ERROR of some + ;; sort? + (error () (values (slot-unbound class x slot-name)))))) + (setf (slot-info-writer info) + (lambda (v x) + (condition-writer-function x v slot-name))) + (setf (slot-info-boundp info) + (lambda (x) + (multiple-value-bind (v c) + (ignore-errors (condition-reader-function x slot-name)) + (declare (ignore v)) + (null c)))) slotd)) (defmethod compute-slots ((class condition-class)) (mapcan (lambda (superclass) - (mapcar (lambda (dslotd) - (compute-effective-slot-definition - class (slot-definition-name dslotd) (list dslotd))) - (class-direct-slots superclass))) - (reverse (slot-value class 'class-precedence-list)))) + (mapcar (lambda (dslotd) + (compute-effective-slot-definition + class (slot-definition-name dslotd) (list dslotd))) + (class-direct-slots superclass))) + (reverse (slot-value class '%class-precedence-list)))) (defmethod compute-slots :around ((class condition-class)) (let ((eslotds (call-next-method))) - (mapc #'initialize-internal-slot-functions eslotds) + (mapc #'finalize-internal-slot-functions eslotds) eslotds)) (defmethod shared-initialize :after @@ -653,137 +659,136 @@ (error "Structure slots must have :INSTANCE allocation."))) (defun make-structure-class-defstruct-form (name direct-slots include) - (let* ((conc-name (intern (format nil "~S structure class " name))) - (constructor (intern (format nil "~Aconstructor" conc-name))) - (defstruct `(defstruct (,name - ,@(when include - `((:include ,(class-name include)))) - (:predicate nil) - (:conc-name ,conc-name) - (:constructor ,constructor ()) - (:copier nil)) - ,@(mapcar (lambda (slot) - `(,(slot-definition-name slot) - +slot-unbound+)) - direct-slots))) - (reader-names (mapcar (lambda (slotd) - (list 'slot-accessor name - (slot-definition-name slotd) - 'reader)) - direct-slots)) - (writer-names (mapcar (lambda (slotd) - (list 'slot-accessor name - (slot-definition-name slotd) - 'writer)) - direct-slots)) - (readers-init - (mapcar (lambda (slotd reader-name) - (let ((accessor + (let* ((conc-name (format-symbol *package* "~S structure class " name)) + (constructor (format-symbol *package* "~Aconstructor" conc-name)) + (included-name (class-name include)) + (included-slots + (when include + (mapcar #'dsd-name (dd-slots (find-defstruct-description included-name))))) + (old-slots nil) + (new-slots nil) + (reader-names nil) + (writer-names nil)) + (dolist (slotd (reverse direct-slots)) + (let* ((slot-name (slot-definition-name slotd)) + (initform (slot-definition-initform slotd)) + (type (slot-definition-type slotd)) + (desc `(,slot-name ,initform :type ,type))) + (push `(slot-accessor ,name ,slot-name reader) + reader-names) + (push `(slot-accessor ,name ,slot-name writer) + writer-names) + (if (member slot-name included-slots :test #'eq) + (push desc old-slots) + (push desc new-slots)))) + (let* ((defstruct `(defstruct (,name + ,@(when include + `((:include ,included-name + ,@old-slots))) + (:constructor ,constructor ()) + (:predicate nil) + (:conc-name ,conc-name) + (:copier nil)) + ,@new-slots)) + (readers-init + (mapcar (lambda (slotd reader-name) + (let ((accessor (slot-definition-defstruct-accessor-symbol slotd))) - `(defun ,reader-name (obj) - (declare (type ,name obj)) - (,accessor obj)))) - direct-slots reader-names)) - (writers-init - (mapcar (lambda (slotd writer-name) - (let ((accessor + `(defun ,reader-name (obj) + (declare (type ,name obj)) + (,accessor obj)))) + direct-slots reader-names)) + (writers-init + (mapcar (lambda (slotd writer-name) + (let ((accessor (slot-definition-defstruct-accessor-symbol slotd))) - `(defun ,writer-name (nv obj) - (declare (type ,name obj)) - (setf (,accessor obj) nv)))) - direct-slots writer-names)) - (defstruct-form - `(progn + `(defun ,writer-name (nv obj) + (declare (type ,name obj)) + (setf (,accessor obj) nv)))) + direct-slots writer-names)) + (defstruct-form + `(progn ,defstruct ,@readers-init ,@writers-init (cons nil nil)))) - (values defstruct-form constructor reader-names writer-names))) - -(defun make-defstruct-allocation-function (class) - (let ((dd (get-structure-dd (class-name class)))) - (lambda () - (let ((instance (%make-instance (dd-length dd))) - (raw-index (dd-raw-index dd))) - (setf (%instance-layout instance) - (sb-kernel::compiler-layout-or-lose (dd-name dd))) - (when raw-index - (setf (%instance-ref instance raw-index) - (make-array (dd-raw-length dd) - :element-type '(unsigned-byte 32)))) - instance)))) + (values defstruct-form constructor reader-names writer-names)))) + +(defun make-defstruct-allocation-function (name) + ;; FIXME: Why don't we go class->layout->info == dd + (let ((dd (find-defstruct-description name))) + (ecase (dd-type dd) + (structure + (%make-structure-instance-allocator dd nil)) + (funcallable-structure + (%make-funcallable-structure-instance-allocator dd nil))))) (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 + definition-source) (declare (ignore slot-names direct-default-initargs)) (if direct-superclasses-p (setf (slot-value class 'direct-superclasses) - (or direct-superclasses - (setq direct-superclasses - (and (not (eq (class-name class) 'structure-object)) - (list *the-class-structure-object*))))) + (or direct-superclasses + (setq direct-superclasses + (and (not (eq (slot-value class 'name) 'structure-object)) + (list *the-class-structure-object*))))) (setq direct-superclasses (slot-value class 'direct-superclasses))) - (let* ((name (class-name class)) - (from-defclass-p (slot-value class 'from-defclass-p)) - (defstruct-p (or from-defclass-p (not (structure-type-p name))))) + (let* ((name (slot-value class 'name)) + (from-defclass-p (slot-value class 'from-defclass-p)) + (defstruct-p (or from-defclass-p (not (structure-type-p name))))) (if direct-slots-p - (setf (slot-value class 'direct-slots) - (setq direct-slots - (mapcar (lambda (pl) - (when defstruct-p - (let* ((slot-name (getf pl :name)) - (acc-name - (format nil - "~S structure class ~A" - name slot-name)) - (accessor (intern acc-name))) - (setq pl (list* :defstruct-accessor-symbol - accessor pl)))) - (make-direct-slotd class pl)) - direct-slots))) - (setq direct-slots (slot-value class 'direct-slots))) + (setf (slot-value class 'direct-slots) + (setq direct-slots + (mapcar (lambda (pl) + (when defstruct-p + (let* ((slot-name (getf pl :name)) + (accessor + (format-symbol *package* + "~S structure class ~A" + name slot-name))) + (setq pl (list* :defstruct-accessor-symbol + accessor pl)))) + (make-direct-slotd class pl)) + direct-slots))) + (setq direct-slots (slot-value class 'direct-slots))) (if defstruct-p - (let ((include (car (slot-value class 'direct-superclasses)))) - (multiple-value-bind (defstruct-form constructor reader-names writer-names) - (make-structure-class-defstruct-form name direct-slots include) - (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) - (gdefinition writer-name)))) - (setf (slot-value dslotd 'internal-reader-function) - reader) - (setf (slot-value dslotd 'internal-writer-function) - writer))) - direct-slots reader-names writer-names) - (setf (slot-value class 'defstruct-form) defstruct-form) - (setf (slot-value class 'defstruct-constructor) constructor))) - (setf (slot-value class 'defstruct-constructor) - (make-defstruct-allocation-function class))) + (let ((include (car (slot-value class 'direct-superclasses)))) + (multiple-value-bind (defstruct-form constructor reader-names writer-names) + (make-structure-class-defstruct-form name direct-slots include) + (unless (structure-type-p name) (eval defstruct-form)) + (mapc (lambda (dslotd reader-name writer-name) + (let* ((reader (gdefinition reader-name)) + (writer (when (fboundp writer-name) + (gdefinition writer-name)))) + (setf (slot-value dslotd 'internal-reader-function) + reader) + (setf (slot-value dslotd 'internal-writer-function) + writer))) + direct-slots reader-names writer-names) + (setf (slot-value class 'defstruct-form) defstruct-form) + (setf (slot-value class 'defstruct-constructor) constructor))) + (setf (slot-value class 'defstruct-constructor) + ;; KLUDGE: not class; in fixup.lisp, can't access slots + ;; outside methods yet. + (make-defstruct-allocation-function name))) (add-direct-subclasses class direct-superclasses) - (setf (slot-value class 'class-precedence-list) - (compute-class-precedence-list class)) - (setf (slot-value class 'slots) (compute-slots class)) - (let ((lclass (find-classoid (class-name class)))) - (setf (classoid-pcl-class lclass) class) - (setf (slot-value class 'wrapper) (classoid-layout lclass))) + (setf (slot-value class '%class-precedence-list) + (compute-class-precedence-list class)) + (setf (slot-value class 'cpl-available-p) t) + (let ((slots (compute-slots class))) + (setf (slot-value class 'slots) slots) + (let* ((lclass (find-classoid (slot-value class 'name))) + (layout (classoid-layout lclass))) + (setf (classoid-pcl-class lclass) class) + (setf (slot-value class 'wrapper) layout) + (setf (layout-slot-table layout) (make-slot-table class slots)))) (setf (slot-value class 'finalized-p) t) - (update-pv-table-cache-info class) - (setq predicate-name (if predicate-name-p - (setf (slot-value class 'predicate-name) - (car predicate-name)) - (or (slot-value class 'predicate-name) - (setf (slot-value class 'predicate-name) - (make-class-predicate-name - (class-name class)))))) - (make-class-predicate class predicate-name) - (add-slot-accessors class direct-slots))) + (add-slot-accessors class direct-slots definition-source))) (defmethod direct-slot-definition-class ((class structure-class) &rest initargs) (declare (ignore initargs)) @@ -792,40 +797,43 @@ (defmethod finalize-inheritance ((class structure-class)) nil) ; always finalized -(defun add-slot-accessors (class dslotds) - (fix-slot-accessors class dslotds 'add)) +(defun add-slot-accessors (class dslotds &optional source-location) + (fix-slot-accessors class dslotds 'add source-location)) (defun remove-slot-accessors (class dslotds) (fix-slot-accessors class dslotds 'remove)) -(defun fix-slot-accessors (class dslotds add/remove) - (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))))))) +(defun fix-slot-accessors (class dslotds add/remove &optional source-location) + (flet ((fix (gfspec name r/w doc) + (let ((gf (cond ((eq add/remove 'add) + (or (find-generic-function gfspec nil) + (ensure-generic-function + gfspec :lambda-list (case r/w + (r '(object)) + (w '(new-value object)))))) + (t + (find-generic-function gfspec nil))))) + (when gf + (case r/w + (r (if (eq add/remove 'add) + (add-reader-method class gf name doc source-location) + (remove-reader-method class gf))) + (w (if (eq add/remove 'add) + (add-writer-method class gf name doc source-location) + (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)))))) + (let ((slot-name (slot-definition-name dslotd)) + (slot-doc (%slot-definition-documentation dslotd))) + (dolist (r (slot-definition-readers dslotd)) + (fix r slot-name 'r slot-doc)) + (dolist (w (slot-definition-writers dslotd)) + (fix w slot-name 'w slot-doc)))))) (defun add-direct-subclasses (class supers) (dolist (super supers) (unless (memq class (class-direct-subclasses class)) (add-direct-subclass super class)))) -(defun remove-direct-subclasses (class supers) - (let ((old (class-direct-superclasses class))) - (dolist (o (set-difference old supers)) - (remove-direct-subclass o class)))) - (defmethod finalize-inheritance ((class std-class)) (update-class class t)) @@ -841,146 +849,216 @@ (defun class-has-a-forward-referenced-superclass-p (class) - (or (forward-referenced-class-p class) + (or (when (forward-referenced-class-p class) + class) (some #'class-has-a-forward-referenced-superclass-p - (class-direct-superclasses class)))) + (class-direct-superclasses class)))) ;;; This is called by :after shared-initialize whenever a class is initialized ;;; or reinitialized. The class may or may not be finalized. (defun update-class (class finalizep) - ;; Comment from Gerd Moellmann: - ;; - ;; Note that we can't simply delay the finalization when CLASS has - ;; no forward referenced superclasses because that causes bootstrap - ;; problems. - (when (and (not finalizep) - (not (class-finalized-p class)) - (not (class-has-a-forward-referenced-superclass-p class))) - (finalize-inheritance class) - (return-from update-class)) - (when (or finalizep (class-finalized-p class) - (not (class-has-a-forward-referenced-superclass-p class))) - (setf (find-class (class-name class)) class) - (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 - ;; into the system as described in "Class Finalization Protocol" - ;; (section 5.5.2 of AMOP). - (update-slots class (compute-slots class)) - (update-gfs-of-class class) - (update-inits class (compute-default-initargs class)) - (update-ctors 'finalize-inheritance :class class)) - (unless finalizep - (dolist (sub (class-direct-subclasses class)) (update-class sub nil)))) - -(defun update-cpl (class cpl) + (without-package-locks + (with-world-lock () + (when (or finalizep (class-finalized-p class)) + (%update-cpl class (compute-class-precedence-list class)) + ;; This invocation of UPDATE-SLOTS, in practice, finalizes the + ;; class. + (%update-slots class (compute-slots class)) + (update-gfs-of-class class) + (setf (plist-value class 'default-initargs) (compute-default-initargs class)) + (update-ctors 'finalize-inheritance :class class)) + (dolist (sub (class-direct-subclasses class)) + (update-class sub nil))))) + +(define-condition cpl-protocol-violation (reference-condition error) + ((class :initarg :class :reader cpl-protocol-violation-class) + (cpl :initarg :cpl :reader cpl-protocol-violation-cpl)) + (:default-initargs :references (list '(:sbcl :node "Metaobject Protocol"))) + (:report + (lambda (c s) + (format s "~@" + (class-name (class-of (cpl-protocol-violation-class c))) + (cpl-protocol-violation-class c) + (eq (class-of (cpl-protocol-violation-class c)) + *the-class-funcallable-standard-class*) + (find-class 'function) + (cpl-protocol-violation-cpl c))))) + +(defun class-has-a-cpl-protocol-violation-p (class) + (labels ((find-in-superclasses (class classes) + (cond + ((null classes) nil) + ((eql class (car classes)) t) + (t (find-in-superclasses class (append (class-direct-superclasses (car classes)) (cdr classes))))))) + (let ((metaclass (class-of class))) + (cond + ((eql metaclass *the-class-standard-class*) + (find-in-superclasses (find-class 'function) (list class))) + ((eql metaclass *the-class-funcallable-standard-class*) + (not (find-in-superclasses (find-class 'function) (list class)))))))) + +(defun %update-cpl (class cpl) + (when (eq (class-of class) *the-class-standard-class*) + (when (find (find-class 'function) cpl) + (error 'cpl-protocol-violation :class class :cpl cpl))) + (when (eq (class-of class) *the-class-funcallable-standard-class*) + (unless (find (find-class 'function) cpl) + (error 'cpl-protocol-violation :class class :cpl cpl))) (if (class-finalized-p class) (unless (and (equal (class-precedence-list class) cpl) - (dolist (c cpl t) - (when (position :class (class-direct-slots c) - :key #'slot-definition-allocation) - (return nil)))) - ;; comment from the old CMU CL sources: - ;; Need to have the cpl setup before update-lisp-class-layout - ;; is called on CMU CL. - (setf (slot-value class 'class-precedence-list) cpl) - (force-cache-flushes class)) - (setf (slot-value class 'class-precedence-list) cpl)) + (dolist (c cpl t) + (when (position :class (class-direct-slots c) + :key #'slot-definition-allocation) + (return nil)))) + ;; comment from the old CMU CL sources: + ;; 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)) + (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) (when cpl (let ((first (car cpl))) (dolist (c (cdr cpl)) - (pushnew c (slot-value first 'can-precede-list)))) + (pushnew c (slot-value first 'can-precede-list) :test #'eq))) (update-class-can-precede-p (cdr cpl)))) (defun class-can-precede-p (class1 class2) - (member class2 (class-can-precede-list class1))) - -(defun update-slots (class eslotds) - (let ((instance-slots ()) - (class-slots ())) - (dolist (eslotd eslotds) - (let ((alloc (slot-definition-allocation eslotd))) - (case alloc - (:instance (push eslotd instance-slots)) - (:class (push eslotd class-slots))))) - - ;; If there is a change in the shape of the instances then the - ;; old class is now obsolete. - (let* ((nlayout (mapcar #'slot-definition-name - (sort instance-slots #'< - :key #'slot-definition-location))) - (nslots (length nlayout)) - (nwrapper-class-slots (compute-class-slots class-slots)) - (owrapper (when (class-finalized-p class) - (class-wrapper class))) - (olayout (when owrapper - (wrapper-instance-slots-layout owrapper))) - (owrapper-class-slots (and owrapper (wrapper-class-slots owrapper))) - (nwrapper - (cond ((null owrapper) - (make-wrapper nslots class)) - ((and (equal nlayout olayout) - (not - (loop for o in owrapper-class-slots - for n in nwrapper-class-slots - do (unless (eq (car o) (car n)) (return t))))) - owrapper) - (t - ;; This will initialize the new wrapper to have the - ;; same state as the old wrapper. We will then have - ;; to change that. This may seem like wasted work - ;; (and it is), but the spec requires that we call - ;; MAKE-INSTANCES-OBSOLETE. - (make-instances-obsolete class) - (class-wrapper class))))) - - (with-slots (wrapper slots) class - (update-lisp-class-layout class nwrapper) - (setf slots eslotds - (wrapper-instance-slots-layout nwrapper) nlayout - (wrapper-class-slots nwrapper) nwrapper-class-slots - (wrapper-no-of-instance-slots nwrapper) nslots - wrapper nwrapper)) + (member class2 (class-can-precede-list class1) :test #'eq)) + +;;; This is called from %UPDATE-SLOTS to check if slot layouts are compatible. +;;; +;;; In addition to slot locations (implicit in the ordering of the slots), we +;;; must check classes: SLOT-INFO structures from old slotds may have been +;;; cached in permutation vectors, but new slotds have had new ones allocated +;;; to them. This is non-problematic for standard slotds, because we know the +;;; structure is compatible, but if a slot definition class changes, this can +;;; change the way SLOT-VALUE-USING-CLASS should dispatch. +;;; +;;; Also, if the slot has a non-standard allocation, we need to check that it +;;; doesn't change. +(defun slot-layouts-compatible-p + (oslotds new-instance-slotds new-class-slotds new-custom-slotds) + (multiple-value-bind (old-instance-slotds old-class-slotds old-custom-slotds) + (classify-slotds oslotds) + (and + ;; Instance slots: name, type, and class. + (dolist (o old-instance-slotds (not new-instance-slotds)) + (let ((n (pop new-instance-slotds))) + (unless (and n + (eq (slot-definition-name o) (slot-definition-name n)) + (eq (slot-definition-type o) (slot-definition-type n)) + (eq (class-of o) (class-of n))) + (return nil)))) + ;; Class slots: name and class. (FIXME: class slots not typechecked?) + (dolist (o old-class-slotds (not new-class-slotds)) + (let ((n (pop new-class-slotds))) + (unless (and n + (eq (slot-definition-name o) (slot-definition-name n)) + (eq (class-of n) (class-of o))) + (return nil)))) + ;; Custom slots: check name, type, allocation, and class. (FIXME: should we just punt?) + (dolist (o old-custom-slotds (not new-custom-slotds)) + (let ((n (pop new-custom-slotds))) + (unless (and n + (eq (slot-definition-name o) (slot-definition-name n)) + (eq (slot-definition-type o) (slot-definition-type n)) + (eq (slot-definition-allocation o) (slot-definition-allocation n)) + (eq (class-of o) (class-of n))) + (return nil))))))) + +(defun style-warn-about-duplicate-slots (class) + (do* ((slots (slot-value class 'slots) (cdr slots)) + (dupes nil)) + ((null slots) + (when dupes + (style-warn + "~@~@:>" + class dupes))) + (let* ((slot-name (slot-definition-name (car slots))) + (oslots (and (not (eq (symbol-package slot-name) + *pcl-package*)) + (remove-if + (lambda (slot-name-2) + (or (eq (symbol-package slot-name-2) + *pcl-package*) + (string/= slot-name slot-name-2))) + (cdr slots) + :key #'slot-definition-name)))) + (when oslots + (pushnew (cons slot-name + (mapcar #'slot-definition-name oslots)) + dupes + :test #'string= :key #'car))))) + +(defun %update-slots (class eslotds) + (multiple-value-bind (instance-slots class-slots custom-slots) + (classify-slotds eslotds) + (let* ((nslots (length instance-slots)) + (owrapper (when (class-finalized-p class) (class-wrapper class))) + (nwrapper + (cond ((null owrapper) + (make-wrapper nslots class)) + ((slot-layouts-compatible-p (wrapper-slots owrapper) + instance-slots class-slots custom-slots) + owrapper) + (t + ;; This will initialize the new wrapper to have the + ;; same state as the old wrapper. We will then have + ;; to change that. This may seem like wasted work + ;; (and it is), but the spec requires that we call + ;; MAKE-INSTANCES-OBSOLETE. + (make-instances-obsolete class) + (class-wrapper class))))) + (%update-lisp-class-layout class nwrapper) + (setf (slot-value class 'slots) eslotds + (wrapper-slots nwrapper) eslotds + (wrapper-slot-table nwrapper) (make-slot-table class eslotds) + (wrapper-length nwrapper) nslots + (slot-value class 'wrapper) nwrapper) + (style-warn-about-duplicate-slots class) (setf (slot-value class 'finalized-p) t) (unless (eq owrapper nwrapper) - (update-pv-table-cache-info class) - (maybe-update-standard-class-locations class))))) + (maybe-update-standard-slot-locations class))))) -(defun compute-class-slots (eslotds) - (let (collect) - (dolist (eslotd eslotds) - (push (assoc (slot-definition-name eslotd) - (class-slot-cells (slot-definition-class eslotd))) - collect)) - (nreverse collect))) +(defun update-gf-dfun (class gf) + (let ((*new-class* class) + (arg-info (gf-arg-info gf))) + (cond + ((special-case-for-compute-discriminating-function-p gf)) + ((gf-precompute-dfun-and-emf-p arg-info) + (multiple-value-bind (dfun cache info) (make-final-dfun-internal gf) + (update-dfun gf dfun cache info)))))) (defun update-gfs-of-class (class) (when (and (class-finalized-p class) - (let ((cpl (class-precedence-list class))) - (or (member *the-class-slot-class* cpl) - (member *the-class-standard-effective-slot-definition* - cpl)))) + (let ((cpl (class-precedence-list class))) + (or (member *the-class-slot-class* cpl :test #'eq) + (member *the-class-standard-effective-slot-definition* + cpl :test #'eq)))) (let ((gf-table (make-hash-table :test 'eq))) (labels ((collect-gfs (class) - (dolist (gf (specializer-direct-generic-functions class)) - (setf (gethash gf gf-table) t)) - (mapc #'collect-gfs (class-direct-superclasses class)))) - (collect-gfs class) - (maphash (lambda (gf ignore) - (declare (ignore ignore)) - (update-gf-dfun class gf)) - gf-table))))) - -(defun update-inits (class inits) - (setf (plist-value class 'default-initargs) inits)) + (dolist (gf (specializer-direct-generic-functions class)) + (setf (gethash gf gf-table) t)) + (mapc #'collect-gfs (class-direct-superclasses class)))) + (collect-gfs class) + (maphash (lambda (gf ignore) + (declare (ignore ignore)) + (update-gf-dfun class gf)) + gf-table))))) (defmethod compute-default-initargs ((class slot-class)) (let ((initargs (loop for c in (class-precedence-list class) - append (class-direct-default-initargs c)))) + append (class-direct-default-initargs c)))) (delete-duplicates initargs :test #'eq :key #'car :from-end t))) ;;;; protocols for constructing direct and effective slot definitions @@ -990,117 +1068,108 @@ (find-class 'standard-direct-slot-definition)) (defun make-direct-slotd (class initargs) - (let ((initargs (list* :class class initargs))) - (apply #'make-instance - (apply #'direct-slot-definition-class class initargs) - initargs))) - -(defmethod compute-slots ((class std-class)) + (apply #'make-instance + (apply #'direct-slot-definition-class class initargs) + :class class + initargs)) + +;;; I (CSR) am not sure, but I believe that the particular order of +;;; slots is quite important: it is ideal to attempt to have a +;;; constant slot location for the same notional slots as much as +;;; possible, so that clever discriminating functions (ONE-INDEX et +;;; al.) have a chance of working. The below at least walks through +;;; 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? +(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. ;; The list is in most-specific-first order. (let ((name-dslotds-alist ())) - (dolist (c (class-precedence-list class)) + (dolist (c (reverse (class-precedence-list class))) (dolist (slot (class-direct-slots c)) - (let* ((name (slot-definition-name slot)) - (entry (assq name name-dslotds-alist))) - (if entry - (push slot (cdr entry)) - (push (list name slot) name-dslotds-alist))))) + (let* ((name (slot-definition-name slot)) + (entry (assq name name-dslotds-alist))) + (if entry + (push slot (cdr entry)) + (push (list name slot) name-dslotds-alist))))) (mapcar (lambda (direct) - (compute-effective-slot-definition class - (car direct) - (nreverse (cdr direct)))) - name-dslotds-alist))) + (compute-effective-slot-definition class + (car direct) + (cdr direct))) + (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) + (safe (safe-p class))) (dolist (eslotd eslotds eslotds) (setf (slot-definition-location eslotd) - (ecase (slot-definition-allocation eslotd) - (:instance - (incf location)) - (:class - (let* ((name (slot-definition-name eslotd)) - (from-class (slot-definition-allocation-class eslotd)) - (cell (assq name (class-slot-cells from-class)))) - (aver (consp cell)) - cell)))) + (case (slot-definition-allocation eslotd) + (:instance + (incf location)) + (:class + (let* ((name (slot-definition-name eslotd)) + (from-class + (or + (slot-definition-allocation-class eslotd) + ;; we get here if the user adds an extra slot + ;; himself... + (setf (slot-definition-allocation-class eslotd) + class))) + ;; which raises the question of what we should + ;; do if we find that said user has added a slot + ;; with the same name as another slot... + (cell (or (assq name (class-slot-cells from-class)) + (let ((c (cons name +slot-unbound+))) + (push c (class-slot-cells from-class)) + c)))) + (aver (consp cell)) + (if (eq +slot-unbound+ (cdr cell)) + ;; We may have inherited an initfunction FIXME: Is this + ;; really right? Is the initialization in + ;; SHARED-INITIALIZE (STD-CLASS) not enough? + (let ((initfun (slot-definition-initfunction eslotd))) + (if initfun + (rplacd cell (call-initfun initfun eslotd safe)) + cell)) + cell))))) + (unless (slot-definition-class 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) - (ecase (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) - (mapcar (lambda (dslotd) - (compute-effective-slot-definition - class - (slot-definition-name dslotd) - (list dslotd))) - (class-direct-slots superclass))) - (reverse (slot-value class 'class-precedence-list)))) + (mapcar (lambda (dslotd) + (compute-effective-slot-definition + class + (slot-definition-name dslotd) + (list dslotd))) + (class-direct-slots superclass))) + (reverse (slot-value class '%class-precedence-list)))) (defmethod compute-slots :around ((class structure-class)) (let ((eslotds (call-next-method))) - (mapc #'initialize-internal-slot-functions eslotds) + (mapc #'finalize-internal-slot-functions eslotds) eslotds)) (defmethod compute-effective-slot-definition ((class slot-class) name dslotds) - (declare (ignore name)) (let* ((initargs (compute-effective-slot-definition-initargs class dslotds)) - (class (apply #'effective-slot-definition-class class initargs))) - (apply #'make-instance class initargs))) + (class (apply #'effective-slot-definition-class class initargs)) + (slotd (apply #'make-instance class initargs))) + slotd)) (defmethod effective-slot-definition-class ((class std-class) &rest initargs) (declare (ignore initargs)) @@ -1113,54 +1182,66 @@ (defmethod compute-effective-slot-definition-initargs ((class slot-class) direct-slotds) (let* ((name nil) - (initfunction nil) - (initform nil) - (initargs nil) - (allocation nil) - (allocation-class nil) - (type t) - (namep nil) - (initp nil) - (allocp nil)) + (initfunction nil) + (initform nil) + (initargs nil) + (allocation nil) + (allocation-class nil) + (type t) + (documentation nil) + (documentationp nil) + (namep nil) + (initp nil) + (allocp nil)) (dolist (slotd direct-slotds) (when slotd - (unless namep - (setq name (slot-definition-name slotd) - namep t)) - (unless initp - (when (slot-definition-initfunction slotd) - (setq initform (slot-definition-initform slotd) - initfunction (slot-definition-initfunction slotd) - initp t))) - (unless allocp - (setq allocation (slot-definition-allocation slotd) - allocation-class (slot-definition-class slotd) - allocp t)) - (setq initargs (append (slot-definition-initargs slotd) initargs)) - (let ((slotd-type (slot-definition-type slotd))) - (setq type (cond ((eq type t) slotd-type) - ((*subtypep type slotd-type) type) - (t `(and ,type ,slotd-type))))))) + (unless namep + (setq name (slot-definition-name slotd) + namep t)) + (unless initp + (awhen (slot-definition-initfunction slotd) + (setq initform (slot-definition-initform slotd) + initfunction it + initp t))) + (unless documentationp + (awhen (%slot-definition-documentation slotd) + (setq documentation it + documentationp t))) + (unless allocp + (setq allocation (slot-definition-allocation slotd) + allocation-class (slot-definition-class slotd) + allocp t)) + (setq initargs (append (slot-definition-initargs slotd) initargs)) + (let ((slotd-type (slot-definition-type slotd))) + (setq type (cond + ((eq type t) slotd-type) + ;; This pairwise type intersection is perhaps a + ;; little inefficient and inelegant, but it's + ;; unlikely to lie on the critical path. Shout + ;; if I'm wrong. -- CSR, 2005-11-24 + (t (type-specifier + (specifier-type `(and ,type ,slotd-type))))))))) (list :name name - :initform initform - :initfunction initfunction - :initargs initargs - :allocation allocation - :allocation-class allocation-class - :type type - :class class))) + :initform initform + :initfunction initfunction + :initargs initargs + :allocation allocation + :allocation-class allocation-class + :type type + :class class + :documentation documentation))) (defmethod compute-effective-slot-definition-initargs :around ((class structure-class) direct-slotds) - (let ((slotd (car direct-slotds))) - (list* :defstruct-accessor-symbol - (slot-definition-defstruct-accessor-symbol slotd) - :internal-reader-function - (slot-definition-internal-reader-function slotd) - :internal-writer-function - (slot-definition-internal-writer-function slotd) - (call-next-method)))) + (let* ((slotd (car direct-slotds)) + (accessor (slot-definition-defstruct-accessor-symbol slotd))) + (list* :defstruct-accessor-symbol accessor + :internal-reader-function + (slot-definition-internal-reader-function slotd) + :internal-writer-function + (slot-definition-internal-writer-function slotd) + (call-next-method)))) ;;; NOTE: For bootstrapping considerations, these can't use MAKE-INSTANCE ;;; to make the method object. They have to use make-a-method which @@ -1169,39 +1250,47 @@ (declare (ignore direct-slot initargs)) (find-class 'standard-reader-method)) -(defmethod add-reader-method ((class slot-class) generic-function slot-name) +(defmethod add-reader-method ((class slot-class) generic-function slot-name slot-documentation source-location) (add-method generic-function - (make-a-method 'standard-reader-method - () - (list (or (class-name class) 'object)) - (list class) - (make-reader-method-function class slot-name) - "automatically generated reader method" - slot-name))) + (make-a-method 'standard-reader-method + () + (list (or (class-name class) 'object)) + (list class) + (make-reader-method-function class slot-name) + (or slot-documentation "automatically generated reader method") + :slot-name slot-name + :object-class class + :method-class-function #'reader-method-class + :definition-source source-location))) (defmethod writer-method-class ((class slot-class) direct-slot &rest initargs) (declare (ignore direct-slot initargs)) (find-class 'standard-writer-method)) -(defmethod add-writer-method ((class slot-class) generic-function slot-name) +(defmethod add-writer-method ((class slot-class) generic-function slot-name slot-documentation source-location) (add-method generic-function - (make-a-method 'standard-writer-method - () - (list 'new-value (or (class-name class) 'object)) - (list *the-class-t* class) - (make-writer-method-function class slot-name) - "automatically generated writer method" - slot-name))) - -(defmethod add-boundp-method ((class slot-class) generic-function slot-name) + (make-a-method 'standard-writer-method + () + (list 'new-value (or (class-name class) 'object)) + (list *the-class-t* class) + (make-writer-method-function class slot-name) + (or slot-documentation "automatically generated writer method") + :slot-name slot-name + :object-class class + :method-class-function #'writer-method-class + :definition-source source-location))) + +(defmethod add-boundp-method ((class slot-class) generic-function slot-name slot-documentation source-location) (add-method generic-function - (make-a-method 'standard-boundp-method - () - (list (or (class-name class) 'object)) - (list class) - (make-boundp-method-function class slot-name) - "automatically generated boundp method" - slot-name))) + (make-a-method (constantly (find-class 'standard-boundp-method)) + class + () + (list (or (class-name class) 'object)) + (list class) + (make-boundp-method-function class slot-name) + (or slot-documentation "automatically generated boundp method") + :slot-name slot-name + :definition-source source-location))) (defmethod remove-reader-method ((class slot-class) generic-function) (let ((method (get-method generic-function () (list class) nil))) @@ -1209,16 +1298,17 @@ (defmethod remove-writer-method ((class slot-class) generic-function) (let ((method - (get-method generic-function () (list *the-class-t* class) nil))) + (get-method generic-function () (list *the-class-t* class) nil))) (when method (remove-method generic-function method)))) (defmethod remove-boundp-method ((class slot-class) generic-function) (let ((method (get-method generic-function () (list class) nil))) (when method (remove-method generic-function method)))) -;;; MAKE-READER-METHOD-FUNCTION and MAKE-WRITE-METHOD function are NOT -;;; part of the standard protocol. They are however useful, PCL makes -;;; use of them internally and documents them for PCL users. +;;; MAKE-READER-METHOD-FUNCTION and MAKE-WRITER-METHOD-FUNCTION +;;; function are NOT part of the standard protocol. They are however +;;; useful; PCL makes use of them internally and documents them for +;;; PCL users. (FIXME: but SBCL certainly doesn't) ;;; ;;; *** This needs work to make type testing by the writer functions which ;;; *** do type testing faster. The idea would be to have one constructor @@ -1230,25 +1320,24 @@ ;;; *** defined for this metaclass a chance to run. (defmethod make-reader-method-function ((class slot-class) slot-name) - (make-std-reader-method-function (class-name class) slot-name)) + (make-std-reader-method-function class slot-name)) (defmethod make-writer-method-function ((class slot-class) slot-name) - (make-std-writer-method-function (class-name class) slot-name)) + (make-std-writer-method-function class slot-name)) (defmethod make-boundp-method-function ((class slot-class) slot-name) - (make-std-boundp-method-function (class-name class) slot-name)) + (make-std-boundp-method-function class slot-name)) (defmethod compatible-meta-class-change-p (class proto-new-class) (eq (class-of class) (class-of proto-new-class))) -(defmethod validate-superclass ((class class) (new-super class)) - (or (eq new-super *the-class-t*) - (eq (class-of class) (class-of new-super)))) - -(defmethod validate-superclass ((class standard-class) (new-super std-class)) - (let ((new-super-meta-class (class-of new-super))) - (or (eq new-super-meta-class *the-class-std-class*) - (eq (class-of class) new-super-meta-class)))) +(defmethod validate-superclass ((class class) (superclass class)) + (or (eq superclass *the-class-t*) + (eq (class-of class) (class-of superclass)) + (and (eq (class-of superclass) *the-class-standard-class*) + (eq (class-of class) *the-class-funcallable-standard-class*)) + (and (eq (class-of superclass) *the-class-funcallable-standard-class*) + (eq (class-of class) *the-class-standard-class*)))) ;;; What this does depends on which of the four possible values of ;;; LAYOUT-INVALID the PCL wrapper has; the simplest case is when it @@ -1269,7 +1358,7 @@ ;;; :UNINITIALIZED))) ;;; ;;; Thanks to Gerd Moellmann for the explanation. -- CSR, 2002-10-29 -(defun force-cache-flushes (class) +(defun %force-cache-flushes (class) (let* ((owrapper (class-wrapper class))) ;; We only need to do something if the wrapper is still valid. If ;; the wrapper isn't valid, state will be FLUSH or OBSOLETE, and @@ -1277,52 +1366,53 @@ ;; particular, we must be sure we never change an OBSOLETE into a ;; FLUSH since OBSOLETE means do what FLUSH does and then some. (when (or (not (invalid-wrapper-p owrapper)) - ;; KLUDGE: despite the observations above, this remains - ;; a violation of locality or what might be considered - ;; good style. There has to be a better way! -- CSR, - ;; 2002-10-29 - (eq (layout-invalid owrapper) t)) - (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper) - class))) - (setf (wrapper-instance-slots-layout nwrapper) - (wrapper-instance-slots-layout owrapper)) - (setf (wrapper-class-slots nwrapper) - (wrapper-class-slots owrapper)) - (with-pcl-lock - (update-lisp-class-layout class nwrapper) - (setf (slot-value class 'wrapper) nwrapper) - ;; Use :OBSOLETE instead of :FLUSH if any superclass has - ;; been obsoleted. - (if (find-if (lambda (x) - (and (consp x) (eq :obsolete (car x)))) - (layout-inherits owrapper) - :key #'layout-invalid) - (invalidate-wrapper owrapper :obsolete nwrapper) - (invalidate-wrapper owrapper :flush nwrapper))))))) - -(defun flush-cache-trap (owrapper nwrapper instance) - (declare (ignore owrapper)) - (set-wrapper instance nwrapper)) + ;; KLUDGE: despite the observations above, this remains + ;; a violation of locality or what might be considered + ;; good style. There has to be a better way! -- CSR, + ;; 2002-10-29 + (eq (layout-invalid owrapper) t)) + (let ((nwrapper (make-wrapper (layout-length owrapper) + class))) + (setf (wrapper-slots nwrapper) + (wrapper-slots owrapper)) + (setf (wrapper-slot-table nwrapper) + (wrapper-slot-table owrapper)) + (%update-lisp-class-layout class nwrapper) + (setf (slot-value class 'wrapper) nwrapper) + ;; Use :OBSOLETE instead of :FLUSH if any superclass has + ;; been obsoleted. + (if (find-if (lambda (x) + (and (consp x) (eq :obsolete (car x)))) + (layout-inherits owrapper) + :key #'layout-invalid) + (%invalidate-wrapper owrapper :obsolete nwrapper) + (%invalidate-wrapper owrapper :flush nwrapper)))))) ;;; MAKE-INSTANCES-OBSOLETE can be called by user code. It will cause ;;; the next access to the instance (as defined in 88-002R) to trap ;;; through the UPDATE-INSTANCE-FOR-REDEFINED-CLASS mechanism. (defmethod make-instances-obsolete ((class std-class)) - (let* ((owrapper (class-wrapper class)) - (nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper) - class))) - (setf (wrapper-instance-slots-layout nwrapper) - (wrapper-instance-slots-layout owrapper)) - (setf (wrapper-class-slots nwrapper) - (wrapper-class-slots owrapper)) - (with-pcl-lock - (update-lisp-class-layout class nwrapper) - (setf (slot-value class 'wrapper) nwrapper) - (invalidate-wrapper owrapper :obsolete nwrapper) - class))) + (with-world-lock () + (let* ((owrapper (class-wrapper class)) + (nwrapper (make-wrapper (layout-length owrapper) + class))) + (unless (class-finalized-p class) + (if (class-has-a-forward-referenced-superclass-p class) + (return-from make-instances-obsolete class) + (%update-cpl class (compute-class-precedence-list class)))) + (setf (wrapper-slots nwrapper) + (wrapper-slots owrapper)) + (setf (wrapper-slot-table nwrapper) + (wrapper-slot-table owrapper)) + (%update-lisp-class-layout class nwrapper) + (setf (slot-value class 'wrapper) nwrapper) + (%invalidate-wrapper owrapper :obsolete nwrapper) + class))) (defmethod make-instances-obsolete ((class symbol)) - (make-instances-obsolete (find-class class))) + (make-instances-obsolete (find-class class)) + ;; ANSI wants the class name when called with a symbol. + class) ;;; OBSOLETE-INSTANCE-TRAP is the internal trap that is called when we ;;; see an obsolete instance. The times when it is called are: @@ -1361,130 +1451,227 @@ (lambda (condition stream) ;; Don't try to print the structure, since it probably won't work. (format stream - "~@" - (type-of (obsolete-structure-datum condition)))))) + "~@" + (type-of (obsolete-structure-datum condition)))))) -(defun obsolete-instance-trap (owrapper nwrapper instance) - (if (not (pcl-instance-p instance)) +(defun %obsolete-instance-trap (owrapper nwrapper instance) + (if (not (layout-for-std-class-p owrapper)) (if *in-obsolete-instance-trap* - *the-wrapper-of-structure-object* - (let ((*in-obsolete-instance-trap* t)) - (error 'obsolete-structure :datum instance))) + *the-wrapper-of-structure-object* + (let ((*in-obsolete-instance-trap* t)) + (error 'obsolete-structure :datum instance))) (let* ((class (wrapper-class* nwrapper)) - (copy (allocate-instance class)) ;??? allocate-instance ??? - (olayout (wrapper-instance-slots-layout owrapper)) - (nlayout (wrapper-instance-slots-layout nwrapper)) - (oslots (get-slots instance)) - (nslots (get-slots copy)) - (oclass-slots (wrapper-class-slots owrapper)) - (added ()) - (discarded ()) - (plist ())) - ;; local --> local transfer value - ;; local --> shared discard value, discard slot - ;; local --> -- discard slot - ;; shared --> local transfer value - ;; shared --> shared -- (cf SHARED-INITIALIZE :AFTER STD-CLASS) - ;; shared --> -- discard value - ;; -- --> local add slot - ;; -- --> shared -- - - ;; Go through all the old local slots. - (let ((opos 0)) - (dolist (name olayout) - (let ((npos (posq name nlayout))) - (if npos - (setf (clos-slots-ref nslots npos) - (clos-slots-ref oslots opos)) - (progn - (push name discarded) - (unless (eq (clos-slots-ref oslots opos) +slot-unbound+) - (setf (getf plist name) (clos-slots-ref oslots opos)))))) - (incf opos))) - - ;; Go through all the old shared slots. - (dolist (oclass-slot-and-val oclass-slots) - (let ((name (car oclass-slot-and-val)) - (val (cdr oclass-slot-and-val))) - (let ((npos (posq name nlayout))) - (when npos - (setf (clos-slots-ref nslots npos) val))))) - - ;; Go through all the new local slots to compute the added slots. - (dolist (nlocal nlayout) - (unless (or (memq nlocal olayout) - (assq nlocal oclass-slots)) - (push nlocal added))) - - (swap-wrappers-and-slots instance copy) - - (update-instance-for-redefined-class instance - added - discarded - plist) - nwrapper))) + (copy (allocate-instance class)) ;??? allocate-instance ??? + (oslots (get-slots instance)) + (nslots (get-slots copy)) + (added ()) + (discarded ()) + (plist ()) + (safe (safe-p class))) + + ;; local --> local transfer value, check type + ;; local --> shared discard value, discard slot + ;; local --> -- discard slot + ;; local --> custom XXX + + ;; shared --> local transfer value, check type + ;; shared --> shared -- (cf SHARED-INITIALIZE :AFTER STD-CLASS) + ;; shared --> -- discard value + ;; shared --> custom XXX + + ;; -- --> local add slot + ;; -- --> shared -- + ;; -- --> custom XXX + + (multiple-value-bind (new-instance-slots new-class-slots new-custom-slots) + (classify-slotds (wrapper-slots nwrapper)) + (declare (ignore new-class-slots)) + (multiple-value-bind (old-instance-slots old-class-slots old-custom-slots) + (classify-slotds (wrapper-slots owrapper)) + + (let ((layout (mapcar (lambda (slotd) + ;; Get the names only once. + (cons (slot-definition-name slotd) slotd)) + new-instance-slots))) + + (flet ((set-value (value cell) + (let ((name (car cell)) + (slotd (cdr cell))) + (when (and safe (neq value +slot-unbound+)) + (let ((type (slot-definition-type slotd))) + (assert + (typep value type) (value) + "~@" + name class value type))) + (setf (clos-slots-ref nslots (slot-definition-location slotd)) value + ;; Prune from the list now that it's been dealt with. + layout (remove cell layout))))) + + ;; Go through all the old local slots. + (dolist (old old-instance-slots) + (let* ((name (slot-definition-name old)) + (value (clos-slots-ref oslots (slot-definition-location old)))) + (unless (eq value +slot-unbound+) + (let ((new (assq name layout))) + (cond (new + (set-value value new)) + (t + (push name discarded) + (setf (getf plist name) value))))))) + + ;; Go through all the old shared slots. + (dolist (old old-class-slots) + (let* ((cell (slot-definition-location old)) + (name (car cell)) + (new (assq name layout))) + (when new + (set-value (cdr cell) new)))) + + ;; Go through all custom slots to find added ones. CLHS + ;; doesn't specify what to do about them, and neither does + ;; AMOP. We do want them to get initialized, though, so we + ;; list them in ADDED for the benefit of SHARED-INITIALIZE. + (dolist (new new-custom-slots) + (let* ((name (slot-definition-name new)) + (old (find name old-custom-slots :key #'slot-definition-name))) + (unless old + (push name added)))) + + ;; Go through all the remaining new local slots to compute the added slots. + (dolist (cell layout) + (push (car cell) added)))))) + + (%swap-wrappers-and-slots instance copy) + + (update-instance-for-redefined-class instance + added + discarded + plist) + nwrapper))) -(defun change-class-internal (instance new-class initargs) +(defun %change-class (instance new-class initargs) (let* ((old-class (class-of instance)) - (copy (allocate-instance new-class)) - (new-wrapper (get-wrapper copy)) - (old-wrapper (class-wrapper old-class)) - (old-layout (wrapper-instance-slots-layout old-wrapper)) - (new-layout (wrapper-instance-slots-layout new-wrapper)) - (old-slots (get-slots instance)) - (new-slots (get-slots copy)) - (old-class-slots (wrapper-class-slots old-wrapper))) - - ;; "The values of local slots specified by both the class CTO and - ;; CFROM are retained. If such a local slot was unbound, it - ;; remains unbound." - (let ((new-position 0)) - (dolist (new-slot new-layout) - (let ((old-position (posq new-slot old-layout))) - (when old-position - (setf (clos-slots-ref new-slots new-position) - (clos-slots-ref old-slots old-position)))) - (incf new-position))) - - ;; "The values of slots specified as shared in the class CFROM and - ;; as local in the class CTO are retained." - (dolist (slot-and-val old-class-slots) - (let ((position (posq (car slot-and-val) new-layout))) - (when position - (setf (clos-slots-ref new-slots position) (cdr slot-and-val))))) + (copy (allocate-instance new-class)) + (new-wrapper (get-wrapper copy)) + (old-wrapper (class-wrapper old-class)) + (old-slots (get-slots instance)) + (new-slots (get-slots copy)) + (safe (safe-p new-class))) + (multiple-value-bind (new-instance-slots new-class-slots) + (classify-slotds (wrapper-slots new-wrapper)) + (multiple-value-bind (old-instance-slots old-class-slots) + (classify-slotds (wrapper-slots old-wrapper)) + + (flet ((set-value (value slotd) + (when safe + (assert (typep value (slot-definition-type slotd)) (value) + "~@" + (slot-definition-name slotd) old-class value + (slot-definition-type slotd) new-class)) + (setf (clos-slots-ref new-slots (slot-definition-location slotd)) value))) + + ;; "The values of local slots specified by both the class CTO and + ;; CFROM are retained. If such a local slot was unbound, it + ;; remains unbound." + (dolist (new new-instance-slots) + (let* ((name (slot-definition-name new)) + (old (find name old-instance-slots :key #'slot-definition-name))) + (when old + (set-value (clos-slots-ref old-slots (slot-definition-location old)) + new)))) + + ;; "The values of slots specified as shared in the class CFROM and + ;; as local in the class CTO are retained." + (dolist (old old-class-slots) + (let* ((slot-and-val (slot-definition-location old)) + (new (find (car slot-and-val) new-instance-slots + :key #'slot-definition-name))) + (when new + (set-value (cdr slot-and-val) new))))))) ;; Make the copy point to the old instance's storage, and make the ;; old instance point to the new storage. - (swap-wrappers-and-slots instance copy) + (%swap-wrappers-and-slots instance copy) (apply #'update-instance-for-different-class copy instance initargs) + instance)) -(defmethod change-class ((instance standard-object) - (new-class standard-class) - &rest initargs) - (change-class-internal instance new-class initargs)) +(defmethod change-class ((instance standard-object) (new-class standard-class) + &rest initargs) + (with-world-lock () + (unless (class-finalized-p new-class) + (finalize-inheritance new-class)) + (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 "~@" + :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 instance new-class initargs))) + +(defmethod change-class ((instance forward-referenced-class) + (new-class standard-class) &rest initargs) + (with-world-lock () + (let ((cpl (class-precedence-list new-class))) + (dolist (class cpl + (error 'metaobject-initialization-violation + :format-control + "~@" + :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 instance new-class initargs))) (defmethod change-class ((instance funcallable-standard-object) - (new-class funcallable-standard-class) - &rest initargs) - (change-class-internal instance new-class initargs)) + (new-class funcallable-standard-class) + &rest initargs) + (with-world-lock () + (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 "~@" + :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 instance new-class initargs))) (defmethod change-class ((instance standard-object) - (new-class funcallable-standard-class) - &rest initargs) + (new-class funcallable-standard-class) + &rest initargs) (declare (ignore initargs)) (error "You can't change the class of ~S to ~S~@ - because it isn't already an instance with metaclass ~S." - instance new-class 'standard-class)) + because it isn't already an instance with metaclass ~S." + instance new-class 'standard-class)) (defmethod change-class ((instance funcallable-standard-object) - (new-class standard-class) - &rest initargs) + (new-class standard-class) + &rest initargs) (declare (ignore initargs)) (error "You can't change the class of ~S to ~S~@ - because it isn't already an instance with metaclass ~S." - instance new-class 'funcallable-standard-class)) + because it isn't already an instance with metaclass ~S." + instance new-class 'funcallable-standard-class)) (defmethod change-class ((instance t) (new-class-name symbol) &rest initargs) (apply #'change-class instance (find-class new-class-name) initargs)) @@ -1498,19 +1685,36 @@ ;;;; 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*))) + (or (eq s *the-class-t*) (eq s *the-class-stream*) + ;; FIXME: bad things happen if someone tries to mix in both + ;; FILE-STREAM and STRING-STREAM (as they have the same + ;; layout-depthoid). Is there any way we can provide a useful + ;; error message? -- CSR, 2005-05-03 + (eq s *the-class-file-stream*) (eq s *the-class-string-stream*) + ;; This probably shouldn't be mixed in with certain other + ;; classes, too, but it seems to work both with STANDARD-OBJECT + ;; and FUNCALLABLE-STANDARD-OBJECT + (eq s *the-class-sequence*))) ;;; Some necessary methods for FORWARD-REFERENCED-CLASS (defmethod class-direct-slots ((class forward-referenced-class)) ()) @@ -1524,15 +1728,15 @@ (def class-slots)) (defmethod validate-superclass ((c slot-class) - (f forward-referenced-class)) + (f forward-referenced-class)) t) (defmethod add-dependent ((metaobject dependent-update-mixin) dependent) - (pushnew dependent (plist-value metaobject 'dependents))) + (pushnew dependent (plist-value metaobject 'dependents) :test #'eq)) (defmethod remove-dependent ((metaobject dependent-update-mixin) dependent) (setf (plist-value metaobject 'dependents) - (delete dependent (plist-value metaobject 'dependents)))) + (delete dependent (plist-value metaobject 'dependents)))) (defmethod map-dependents ((metaobject dependent-update-mixin) function) (dolist (dependent (plist-value metaobject 'dependents))