X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fslots-boot.lisp;h=f7c5b62c9587c52a7699974c534230cf4d453581;hb=5ed095bdfed6d335ccc43ac4b826eeb0bf27963e;hp=36b70d9bdfc18ac119b17eeaf8ed17e58e43a5a5;hpb=157e21959c8023f146d6b03206aea6daa60e7b0d;p=sbcl.git diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index 36b70d9..f7c5b62 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -56,15 +56,21 @@ (setf reader-specializers (mapcar #'find-class reader-specializers)) (setf writer-specializers (mapcar #'find-class writer-specializers)))) +(defmacro quiet-funcall (fun &rest args) + ;; Don't give a style-warning about undefined function here. + `(funcall (locally (declare (muffle-conditions style-warning)) + ,fun) + ,@args)) + (defmacro accessor-slot-value (object slot-name &environment env) (aver (constantp slot-name env)) (let* ((slot-name (constant-form-value slot-name env)) (reader-name (slot-reader-name slot-name))) `(let ((.ignore. (load-time-value (ensure-accessor 'reader ',reader-name ',slot-name)))) - (declare (ignore .ignore.)) - (truly-the (values t &optional) - (funcall #',reader-name ,object))))) + (declare (ignore .ignore.)) + (truly-the (values t &optional) + (quiet-funcall #',reader-name ,object))))) (defmacro accessor-set-slot-value (object slot-name new-value &environment env) (aver (constantp slot-name env)) @@ -82,7 +88,7 @@ (ensure-accessor 'writer ',writer-name ',slot-name))) (.new-value. ,new-value)) (declare (ignore .ignore.)) - (funcall #',writer-name .new-value. ,object) + (quiet-funcall #',writer-name .new-value. ,object) .new-value.))) (if bind-object `(let ,bind-object ,form) @@ -205,20 +211,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 +234,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,9 +464,8 @@ (let* ((initargs (copy-tree (make-method-function (lambda (instance) - (pv-binding1 (.pv. .calls. - (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)))))))) @@ -470,7 +474,7 @@ initargs)) (defun make-std-writer-method-function (class-or-name slot-name) - (let* ((class (when (eq *boot-state* 'complete) + (let* ((class (when (eq **boot-state** 'complete) (if (typep class-or-name 'class) class-or-name (find-class class-or-name nil)))) @@ -489,17 +493,15 @@ (make-method-function (lambda (nv instance) (funcall check-fun nv instance) - (pv-binding1 (.pv. .calls. - (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. .calls. - (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))))))))) @@ -512,9 +514,8 @@ (let* ((initargs (copy-tree (make-method-function (lambda (instance) - (pv-binding1 (.pv. .calls. - (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)))))))) @@ -534,7 +535,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. ;;; @@ -565,21 +566,13 @@ ;;; FUNCALLABLE-STANDARD-CLASS. (defun find-slot-definition (class slot-name) - (declare (symbol slot-name)) - (let* ((vector (class-slot-vector class)) - (index (rem (sxhash slot-name) (length vector)))) - (declare (simple-vector vector) (index index) - (optimize (sb-c::insert-array-bounds-checks 0))) - (do ((plist (the list (svref vector index)) (cdr plist))) - ((not (consp plist))) - (let ((key (car plist))) - (setf plist (cdr plist)) - (when (eq key slot-name) - (return (cddar plist))))))) + (dolist (slotd (class-slots class)) + (when (eq slot-name (slot-definition-name slotd)) + (return slotd)))) -(defun find-slot-cell (class slot-name) +(defun find-slot-cell (wrapper slot-name) (declare (symbol slot-name)) - (let* ((vector (class-slot-vector class)) + (let* ((vector (layout-slot-table wrapper)) (index (rem (sxhash slot-name) (length vector)))) (declare (simple-vector vector) (index index) (optimize (sb-c::insert-array-bounds-checks 0))) @@ -590,30 +583,32 @@ (when (eq key slot-name) (return (car plist))))))) -(defun make-slot-vector (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) (svref vector index)))))) - (if (eq 'complete *boot-state*) + (if (eq 'complete **boot-state**) (dolist (slot slots) (add-to-vector (slot-definition-name slot) slot)) (dolist (slot slots)