X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fslots-boot.lisp;h=c9fa2208ff5500972de06b6b087d50e5392987f0;hb=d25e3478acccec70402ff32554669a982be8e281;hp=90a592b1d209dd6371462053d27ab3dd9638210c;hpb=e5cf6f26b24a3c85bd3258dd9cac9d9a26d510f3;p=sbcl.git diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index 90a592b..c9fa220 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -64,7 +64,10 @@ (ensure-accessor 'reader ',reader-name ',slot-name)))) (declare (ignore .ignore.)) (truly-the (values t &optional) - (funcall #',reader-name ,object))))) + ;; Don't give a style-warning about undefined function here. + (funcall (locally (declare (muffle-conditions style-warning)) + #',reader-name) + ,object))))) (defmacro accessor-set-slot-value (object slot-name new-value &environment env) (aver (constantp slot-name env)) @@ -205,20 +208,22 @@ (slot-definition-class slotd) (safe-p (slot-definition-class slotd)))) (writer-fun (etypecase location - (fixnum (if fsc-p - (lambda (nv instance) - (check-obsolete-instance instance) - (setf (clos-slots-ref (fsc-instance-slots instance) - location) - nv)) - (lambda (nv instance) - (check-obsolete-instance instance) - (setf (clos-slots-ref (std-instance-slots instance) - location) - nv)))) - (cons (lambda (nv instance) - (check-obsolete-instance instance) - (setf (cdr location) nv))) + (fixnum + (if fsc-p + (lambda (nv instance) + (check-obsolete-instance instance) + (setf (clos-slots-ref (fsc-instance-slots instance) + location) + nv)) + (lambda (nv instance) + (check-obsolete-instance instance) + (setf (clos-slots-ref (std-instance-slots instance) + location) + nv)))) + (cons + (lambda (nv instance) + (check-obsolete-instance instance) + (setf (cdr location) nv))) (null (lambda (nv instance) (declare (ignore nv instance)) @@ -226,21 +231,18 @@ slotd '(setf slot-value-using-class)))))) (checking-fun (lambda (new-value instance) - (check-obsolete-instance instance) - ;; If the SLOTD had a TYPE-CHECK-FUNCTION, call it. - (let* (;; Note that this CLASS is not neccessarily - ;; the SLOT-DEFINITION-CLASS of the - ;; SLOTD passed to M-O-S-W-M-F, since it's - ;; e.g. possible for a subclass to define - ;; a slot of the same name but with no - ;; accessors. So we need to fetch the SLOTD - ;; when CHECKING-FUN is called, instead of - ;; just closing over it. - (class (class-of instance)) - (slotd (find-slot-definition class slot-name)) + ;; If we have a TYPE-CHECK-FUNCTION, call it. + (let* (;; Note that the class of INSTANCE here is not + ;; neccessarily the SLOT-DEFINITION-CLASS of + ;; the SLOTD passed to M-O-S-W-M-F, since it's + ;; e.g. possible for a subclass to define a + ;; slot of the same name but with no accessors. + ;; So we need to fetch the right type check function + ;; from the wrapper instead of just closing over it. + (wrapper (valid-wrapper-of instance)) (type-check-function - (when slotd - (slot-definition-type-check-function slotd)))) + (cadr (find-slot-cell wrapper slot-name)))) + (declare (type (or function null) type-check-function)) (when type-check-function (funcall type-check-function new-value))) ;; Then call the real writer. @@ -459,8 +461,8 @@ (let* ((initargs (copy-tree (make-method-function (lambda (instance) - (pv-binding1 (.pv. (bug "Please report this") - (instance) (instance-slots)) + (pv-binding1 ((bug "Please report this") + (instance) (instance-slots)) (instance-read-internal .pv. instance-slots 0 (slot-value instance slot-name)))))))) @@ -488,15 +490,15 @@ (make-method-function (lambda (nv instance) (funcall check-fun nv instance) - (pv-binding1 (.pv. (bug "Please report this") - (instance) (instance-slots)) + (pv-binding1 ((bug "Please report this") + (instance) (instance-slots)) (instance-write-internal .pv. instance-slots 0 nv (setf (slot-value instance slot-name) nv))))) (make-method-function (lambda (nv instance) - (pv-binding1 (.pv. (bug "Please report this") - (instance) (instance-slots)) + (pv-binding1 ((bug "Please report this") + (instance) (instance-slots)) (instance-write-internal .pv. instance-slots 0 nv (setf (slot-value instance slot-name) nv))))))))) @@ -509,8 +511,8 @@ (let* ((initargs (copy-tree (make-method-function (lambda (instance) - (pv-binding1 (.pv. (bug "Please report this") - (instance) (instance-slots)) + (pv-binding1 ((bug "Please report this") + (instance) (instance-slots)) (instance-boundp-internal .pv. instance-slots 0 (slot-boundp instance slot-name)))))))) @@ -530,7 +532,7 @@ ;;; chains made out of plists keyed by the slot names. This fixes ;;; gives O(1) performance, and avoid the GF calls. ;;; -;;; MAKE-SLOT-VECTOR constructs the hashed vector out of a list of +;;; MAKE-SLOT-TABLE constructs the hashed vector out of a list of ;;; effective slot definitions and the class they pertain to, and ;;; FIND-SLOT-DEFINITION knows how to look up slots in that vector. ;;; @@ -578,25 +580,27 @@ (when (eq key slot-name) (return (car plist))))))) -(defun make-slot-table (class slots) +(defun make-slot-table (class slots &optional bootstrap) (let* ((n (+ (length slots) 2)) (vector (make-array n :initial-element nil)) (save-slot-location-p - (when (eq 'complete *boot-state*) - (let ((metaclass (class-of class))) - (or (eq metaclass *the-class-standard-class*) - (eq metaclass *the-class-funcallable-standard-class*))))) - (save-type-check-function-p (and save-slot-location-p (safe-p class)))) + (or bootstrap + (when (eq 'complete *boot-state*) + (let ((metaclass (class-of class))) + (or (eq metaclass *the-class-standard-class*) + (eq metaclass *the-class-funcallable-standard-class*)))))) + (save-type-check-function-p + (unless bootstrap + (and (eq 'complete *boot-state*) (safe-p class))))) (flet ((add-to-vector (name slot) (declare (symbol name) (optimize (sb-c::insert-array-bounds-checks 0))) (let ((index (rem (sxhash name) n))) (setf (svref vector index) - (list* name (list* (if save-slot-location-p - (slot-definition-location slot) - ;; T tells SLOT-VALUE & SET-SLOT-VALUE - ;; that this is a non-standard class. - t) + (list* name (list* (when save-slot-location-p + (if bootstrap + (early-slot-definition-location slot) + (slot-definition-location slot))) (when save-type-check-function-p (slot-definition-type-check-function slot)) slot)