X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fstd-class.lisp;h=c7869ec1fb0e2bf4f37e926187bdbe1492ca23d1;hb=d5e1f093b8ca643ce4f39554232e0a1688e85b7c;hp=84fcda4efb72004f9a86b1441294bb285c0d3709;hpb=95f17ca63742f8c164309716b35bc25545a849a6;p=sbcl.git diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 84fcda4..c7869ec 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -69,8 +69,8 @@ (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))) (dolist (type '(reader writer boundp)) @@ -79,6 +79,33 @@ (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) + ;; 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)) + (let* ((name (slot-value slotd 'name))) + (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: @@ -98,12 +125,9 @@ (defmethod compute-slot-accessor-info ((slotd effective-slot-definition) type gf) (let* ((name (slot-value slotd 'name)) - (class (slot-value slotd '%class)) - (old-slotd (when (class-finalized-p class) - (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) + (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) @@ -181,13 +205,13 @@ (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-spinlock (*specializer-lock*) + (sb-thread::with-recursive-system-spinlock (*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-spinlock (*specializer-lock*) + (sb-thread::with-recursive-system-spinlock (*specializer-lock*) (call-next-method))) (defmethod add-direct-method ((specializer class) (method method)) @@ -353,7 +377,7 @@ (without-package-locks (setf (find-class name) class)))) ;; After boot (SETF FIND-CLASS) does this. - (unless (eq *boot-state* 'complete) + (unless (eq **boot-state** 'complete) (%set-class-type-translation class name)) class) @@ -367,7 +391,7 @@ (without-package-locks (setf (find-class name) class)))) ;; After boot (SETF FIND-CLASS) does this. - (unless (eq *boot-state* 'complete) + (unless (eq **boot-state** 'complete) (%set-class-type-translation class name)) class) @@ -615,7 +639,7 @@ (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 @@ -628,51 +652,59 @@ (defun make-structure-class-defstruct-form (name direct-slots include) (let* ((conc-name (format-symbol *package* "~S structure class " name)) (constructor (format-symbol *package* "~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 + (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))) + (values defstruct-form constructor reader-names writer-names)))) (defun make-defstruct-allocation-function (name) ;; FIXME: Why don't we go class->layout->info == dd @@ -1087,7 +1119,7 @@ (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)