X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fslots.lisp;h=b6282b991cc33f85da281c99372952d1ca4d7fcc;hb=9b1fade83db8453b75b8c7380eb12ce41b5b889c;hp=1b1326be3792057048474ac7b365d118987a8e77;hpb=903f4432362a1e7764dfed46d35894625cc085d8;p=sbcl.git diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index 1b1326b..b6282b9 100644 --- a/src/pcl/slots.lisp +++ b/src/pcl/slots.lisp @@ -75,62 +75,149 @@ (t (error "unrecognized instance type"))))) -(defun find-slot-definition (class slot-name) - (dolist (slot (class-slots class) nil) - (when (eql slot-name (slot-definition-name slot)) - (return slot)))) +;;;; STANDARD-INSTANCE-ACCESS + +(declaim (inline standard-instance-access (setf standard-instance-access) + funcallable-standard-instance-access + (setf funcallable-standard-instance-access))) + +(defun standard-instance-access (instance location) + (clos-slots-ref (std-instance-slots instance) location)) + +(defun (setf standard-instance-access) (new-value instance location) + (setf (clos-slots-ref (std-instance-slots instance) location) new-value)) + +(defun funcallable-standard-instance-access (instance location) + (clos-slots-ref (fsc-instance-slots instance) location)) + +(defun (setf funcallable-standard-instance-access) (new-value instance location) + (setf (clos-slots-ref (fsc-instance-slots instance) location) new-value)) + +;;;; SLOT-VALUE, (SETF SLOT-VALUE), SLOT-BOUNDP, SLOT-MAKUNBOUND (declaim (ftype (sfunction (t symbol) t) slot-value)) (defun slot-value (object slot-name) - (let* ((class (class-of object)) - (slot-definition (find-slot-definition class slot-name))) - (if (null slot-definition) - (values (slot-missing class object slot-name 'slot-value)) - (slot-value-using-class class object slot-definition)))) - -(define-compiler-macro slot-value (&whole form object slot-name) - (if (and (constantp slot-name) - (interned-symbol-p (constant-form-value slot-name))) + (let* ((wrapper (valid-wrapper-of object)) + (cell (find-slot-cell wrapper slot-name)) + (location (car cell)) + (value + (cond ((fixnump location) + (if (std-instance-p object) + (standard-instance-access object location) + (funcallable-standard-instance-access object location))) + ((consp location) + (cdr location)) + ((not cell) + (return-from slot-value + (values (slot-missing (wrapper-class* wrapper) object slot-name + 'slot-value)))) + ((not location) + (return-from slot-value + (slot-value-using-class (wrapper-class* wrapper) object (cddr cell)))) + (t + (bug "Bogus slot cell in SLOT-VALUE: ~S" cell))))) + (if (eq +slot-unbound+ value) + (slot-unbound (wrapper-class* wrapper) object slot-name) + value))) + +(define-compiler-macro slot-value (&whole form object slot-name + &environment env) + (if (and (constantp slot-name env) + (interned-symbol-p (constant-form-value slot-name env))) `(accessor-slot-value ,object ,slot-name) form)) (defun set-slot-value (object slot-name new-value) - (let* ((class (class-of object)) - (slot-definition (find-slot-definition class slot-name))) - (if (null slot-definition) - (progn (slot-missing class object slot-name 'setf new-value) - new-value) - (setf (slot-value-using-class class object slot-definition) - new-value)))) - -(define-compiler-macro set-slot-value (&whole form object slot-name new-value) - (if (and (constantp slot-name) - (interned-symbol-p (constant-form-value slot-name))) + (let* ((wrapper (valid-wrapper-of object)) + (cell (find-slot-cell wrapper slot-name)) + (location (car cell)) + (type-check-function (cadr cell))) + (when type-check-function + (funcall (the function type-check-function) new-value)) + (cond ((fixnump location) + (if (std-instance-p object) + (setf (standard-instance-access object location) new-value) + (setf (funcallable-standard-instance-access object location) + new-value))) + ((consp location) + (setf (cdr location) new-value)) + ((not cell) + (slot-missing (wrapper-class* wrapper) object slot-name 'setf new-value)) + ((not location) + (setf (slot-value-using-class (wrapper-class* wrapper) object (cddr cell)) + new-value)) + (t + (bug "Bogus slot-cell in SET-SLOT-VALUE: ~S" cell)))) + new-value) + +;;; A version of SET-SLOT-VALUE for use in safe code, where we want to +;;; check types when writing to slots: +;;; * Doesn't have an optimizing compiler-macro +;;; * Isn't special-cased in WALK-METHOD-LAMBDA +(defun safe-set-slot-value (object slot-name new-value) + (set-slot-value object slot-name new-value)) + +(define-compiler-macro set-slot-value (&whole form object slot-name new-value + &environment env) + (if (and (constantp slot-name env) + (interned-symbol-p (constant-form-value slot-name env)) + ;; We can't use the ACCESSOR-SET-SLOT-VALUE path in safe + ;; code, since it'll use the global automatically generated + ;; accessor, which won't do typechecking. (SLOT-OBJECT + ;; won't have been compiled with SAFETY 3, so SAFE-P will + ;; be NIL in MAKE-STD-WRITER-METHOD-FUNCTION). + (not (safe-code-p env))) `(accessor-set-slot-value ,object ,slot-name ,new-value) form)) (defun slot-boundp (object slot-name) - (let* ((class (class-of object)) - (slot-definition (find-slot-definition class slot-name))) - (if (null slot-definition) - (not (not (slot-missing class object slot-name 'slot-boundp))) - (slot-boundp-using-class class object slot-definition)))) - -(setf (gdefinition 'slot-boundp-normal) #'slot-boundp) - -(define-compiler-macro slot-boundp (&whole form object slot-name) - (if (and (constantp slot-name) - (interned-symbol-p (constant-form-value slot-name))) + (let* ((wrapper (valid-wrapper-of object)) + (cell (find-slot-cell wrapper slot-name)) + (location (car cell)) + (value + (cond ((fixnump location) + (if (std-instance-p object) + (standard-instance-access object location) + (funcallable-standard-instance-access object location))) + ((consp location) + (cdr location)) + ((not cell) + (return-from slot-boundp + (and (slot-missing (wrapper-class* wrapper) object slot-name + 'slot-boundp) + t))) + ((not location) + (return-from slot-boundp + (slot-boundp-using-class (wrapper-class* wrapper) object (cddr cell)))) + (t + (bug "Bogus slot cell in SLOT-VALUE: ~S" cell))))) + (not (eq +slot-unbound+ value)))) + +(define-compiler-macro slot-boundp (&whole form object slot-name + &environment env) + (if (and (constantp slot-name env) + (interned-symbol-p (constant-form-value slot-name env))) `(accessor-slot-boundp ,object ,slot-name) form)) (defun slot-makunbound (object slot-name) - (let* ((class (class-of object)) - (slot-definition (find-slot-definition class slot-name))) - (if (null slot-definition) - (slot-missing class object slot-name 'slot-makunbound) - (slot-makunbound-using-class class object slot-definition)) - object)) + (let* ((wrapper (valid-wrapper-of object)) + (cell (find-slot-cell wrapper slot-name)) + (location (car cell))) + (cond ((fixnump location) + (if (std-instance-p object) + (setf (standard-instance-access object location) +slot-unbound+) + (setf (funcallable-standard-instance-access object location) + +slot-unbound+))) + ((consp location) + (setf (cdr location) +slot-unbound+)) + ((not cell) + (slot-missing (wrapper-class* wrapper) object slot-name 'slot-makunbound)) + ((not location) + (slot-makunbound-using-class (wrapper-class* wrapper) object (cddr cell))) + (t + (bug "Bogus slot-cell in SLOT-MAKUNBOUND: ~S" cell)))) + object) (defun slot-exists-p (object slot-name) (let ((class (class-of object))) @@ -145,16 +232,12 @@ (if (slot-boundp object slot-name) (slot-value object slot-name) default)) - -(defun standard-instance-access (instance location) - (clos-slots-ref (std-instance-slots instance) location)) - -(defun funcallable-standard-instance-access (instance location) - (clos-slots-ref (fsc-instance-slots instance) location)) (defmethod slot-value-using-class ((class std-class) (object standard-object) (slotd standard-effective-slot-definition)) + ;; FIXME: Do we need this? SLOT-VALUE checks for obsolete + ;; instances. Are users allowed to call this directly? (check-obsolete-instance object) (let* ((location (slot-definition-location slotd)) (value @@ -181,28 +264,39 @@ (new-value (class std-class) (object standard-object) (slotd standard-effective-slot-definition)) + ;; FIXME: Do we need this? SET-SLOT-VALUE checks for obsolete + ;; instances. Are users allowed to call this directly? (check-obsolete-instance object) - (let ((location (slot-definition-location slotd))) - (typecase location - (fixnum - (cond ((std-instance-p object) - (setf (clos-slots-ref (std-instance-slots object) location) - new-value)) - ((fsc-instance-p object) - (setf (clos-slots-ref (fsc-instance-slots object) location) - new-value)) - (t (bug "unrecognized instance type in ~S" - '(setf slot-value-using-class))))) - (cons - (setf (cdr location) new-value)) - (t - (instance-structure-protocol-error slotd - '(setf slot-value-using-class)))))) + (let ((location (slot-definition-location slotd)) + (type-check-function + (when (safe-p class) + (slot-definition-type-check-function slotd)))) + (flet ((check (new-value) + (when type-check-function + (funcall (the function type-check-function) new-value)) + new-value)) + (typecase location + (fixnum + (cond ((std-instance-p object) + (setf (clos-slots-ref (std-instance-slots object) location) + (check new-value))) + ((fsc-instance-p object) + (setf (clos-slots-ref (fsc-instance-slots object) location) + (check new-value))) + (t (bug "unrecognized instance type in ~S" + '(setf slot-value-using-class))))) + (cons + (setf (cdr location) (check new-value))) + (t + (instance-structure-protocol-error + slotd '(setf slot-value-using-class))))))) (defmethod slot-boundp-using-class ((class std-class) (object standard-object) (slotd standard-effective-slot-definition)) + ;; FIXME: Do we need this? SLOT-BOUNDP checks for obsolete + ;; instances. Are users allowed to call this directly? (check-obsolete-instance object) (let* ((location (slot-definition-location slotd)) (value @@ -282,6 +376,8 @@ (let* ((function (slot-definition-internal-reader-function slotd)) (value (funcall function object))) (declare (type function function)) + ;; FIXME: Is this really necessary? Structure slots should surely + ;; never be unbound! (if (eq value +slot-unbound+) (values (slot-unbound class object (slot-definition-name slotd))) value))) @@ -368,3 +464,11 @@ (defmethod allocate-instance ((class built-in-class) &rest initargs) (declare (ignore initargs)) (error "Cannot allocate an instance of ~S." class)) ; So sayeth AMOP + +;;; AMOP says that CLASS-SLOTS signals an error for unfinalized classes. +(defmethod class-slots :before ((class slot-class)) + (unless (class-finalized-p class) + (error 'simple-reference-error + :format-control "~S called on ~S, which is not yet finalized." + :format-arguments (list 'class-slots class) + :references (list '(:amop :generic-function class-slots)))))