X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fslots.lisp;h=b6282b991cc33f85da281c99372952d1ca4d7fcc;hb=74a1797f60e26c7adbc491840f89bbaab08e504d;hp=b9ee30958f3337b6f66aed386633323f9ddd2d29;hpb=a556288505e2687ac333e1b0a8deebb13c76a60c;p=sbcl.git diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index b9ee309..b6282b9 100644 --- a/src/pcl/slots.lisp +++ b/src/pcl/slots.lisp @@ -75,18 +75,50 @@ (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)))) + (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) @@ -96,13 +128,27 @@ 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)))) + (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: @@ -125,13 +171,27 @@ 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) + (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) @@ -141,12 +201,23 @@ 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))) @@ -161,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 @@ -197,6 +264,8 @@ (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)) (type-check-function @@ -226,6 +295,8 @@ ((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 @@ -305,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))) @@ -392,3 +465,10 @@ (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)))))