X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fpcl%2Fslots.lisp;h=69232a7ce6ddef929ffcf5aaf541f1bbcc3fc323;hb=ff92598854bf7cae8d57fe49cef4d9a98e1ab345;hp=ac09ca0fd3ba00a396c55242106a586155e3c3fa;hpb=2716573f357f204c5f546d1d34d285dd24ff43a1;p=sbcl.git diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index ac09ca0..69232a7 100644 --- a/src/pcl/slots.lisp +++ b/src/pcl/slots.lisp @@ -26,11 +26,10 @@ ;;;; ANSI CL condition for unbound slots (define-condition unbound-slot (cell-error) - ((instance :reader unbound-slot-instance :initarg :instance) - (slot :reader unbound-slot-slot :initarg :slot)) - (:report (lambda(condition stream) - (format stream "The slot ~S is unbound in the object ~S" - (unbound-slot-slot condition) + ((instance :reader unbound-slot-instance :initarg :instance)) + (:report (lambda (condition stream) + (format stream "The slot ~S is unbound in the object ~S." + (cell-error-name condition) (unbound-slot-instance condition))))) (defmethod wrapper-fetcher ((class standard-class)) @@ -58,7 +57,7 @@ (error "unrecognized instance type")))) (defun swap-wrappers-and-slots (i1 i2) - (without-interrupts + (with-pcl-lock ;FIXME is this sufficient? (cond ((std-instance-p i1) (let ((w1 (std-instance-wrapper i1)) (s1 (std-instance-slots i1))) @@ -76,96 +75,62 @@ (t (error "unrecognized instance type"))))) -(defun get-class-slot-value-1 (object wrapper slot-name) - (let ((entry (assoc slot-name (wrapper-class-slots wrapper)))) - (if (null entry) - (slot-missing (wrapper-class wrapper) object slot-name 'slot-value) - (if (eq (cdr entry) +slot-unbound+) - (slot-unbound (wrapper-class wrapper) object slot-name) - (cdr entry))))) - -(defun set-class-slot-value-1 (new-value object wrapper slot-name) - (let ((entry (assoc slot-name (wrapper-class-slots wrapper)))) - (if (null entry) - (slot-missing (wrapper-class wrapper) - object - slot-name - 'setf - new-value) - (setf (cdr entry) new-value)))) - -(defmethod class-slot-value ((class std-class) slot-name) - (let ((wrapper (class-wrapper class)) - (prototype (class-prototype class))) - (get-class-slot-value-1 prototype wrapper slot-name))) - -(defmethod (setf class-slot-value) (nv (class std-class) slot-name) - (let ((wrapper (class-wrapper class)) - (prototype (class-prototype class))) - (set-class-slot-value-1 nv prototype wrapper slot-name))) - (defun find-slot-definition (class slot-name) (dolist (slot (class-slots class) nil) (when (eql slot-name (slot-definition-name slot)) (return slot)))) +(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) - (slot-missing class object slot-name 'slot-value) + (values (slot-missing class object slot-name 'slot-value)) (slot-value-using-class class object slot-definition)))) -(setf (gdefinition 'slot-value-normal) #'slot-value) - -(define-compiler-macro slot-value (object-form slot-name-form) - (if (and (constantp slot-name-form) - (let ((slot-name (eval slot-name-form))) - (and (symbolp slot-name) (symbol-package slot-name)))) - `(accessor-slot-value ,object-form ,slot-name-form) - `(slot-value-normal ,object-form ,slot-name-form))) +(define-compiler-macro slot-value (&whole form object slot-name) + (if (and (constantp slot-name) + (interned-symbol-p (eval slot-name))) + `(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) - (slot-missing class object slot-name 'setf) + (progn (slot-missing class object slot-name 'setf new-value) + new-value) (setf (slot-value-using-class class object slot-definition) new-value)))) -(setf (gdefinition 'set-slot-value-normal) #'set-slot-value) - -(define-compiler-macro set-slot-value (object-form slot-name-form new-value-form) - (if (and (constantp slot-name-form) - (let ((slot-name (eval slot-name-form))) - (and (symbolp slot-name) (symbol-package slot-name)))) - `(accessor-set-slot-value ,object-form ,slot-name-form ,new-value-form) - `(set-slot-value-normal ,object-form ,slot-name-form ,new-value-form))) - -(defconstant +optimize-slot-boundp+ nil) +(define-compiler-macro set-slot-value (&whole form object slot-name new-value) + (if (and (constantp slot-name) + (interned-symbol-p (eval slot-name))) + `(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) - (slot-missing class object slot-name 'slot-boundp) + (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 (object-form slot-name-form) - (if (and (constantp slot-name-form) - (let ((slot-name (eval slot-name-form))) - (and (symbolp slot-name) (symbol-package slot-name)))) - `(accessor-slot-boundp ,object-form ,slot-name-form) - `(slot-boundp-normal ,object-form ,slot-name-form))) +(define-compiler-macro slot-boundp (&whole form object slot-name) + (if (and (constantp slot-name) + (interned-symbol-p (eval slot-name))) + `(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)))) + (slot-makunbound-using-class class object slot-definition)) + object)) (defun slot-exists-p (object slot-name) (let ((class (class-of object))) @@ -179,82 +144,79 @@ default)) (defun standard-instance-access (instance location) - (%instance-ref (std-instance-slots instance) location)) + (clos-slots-ref (std-instance-slots instance) location)) (defun funcallable-standard-instance-access (instance location) - (%instance-ref (fsc-instance-slots instance) location)) + (clos-slots-ref (fsc-instance-slots instance) location)) (defmethod slot-value-using-class ((class std-class) (object std-object) (slotd standard-effective-slot-definition)) + (check-obsolete-instance object) (let* ((location (slot-definition-location slotd)) (value (typecase location (fixnum (cond ((std-instance-p object) - ;; FIXME: EQ T (WRAPPER-STATE ..) is better done - ;; through INVALID-WRAPPER-P (here and below). - (unless (eq 't (wrapper-state (std-instance-wrapper object))) - (check-wrapper-validity object)) - (%instance-ref (std-instance-slots object) location)) + (clos-slots-ref (std-instance-slots object) + location)) ((fsc-instance-p object) - (unless (eq 't (wrapper-state (fsc-instance-wrapper object))) - (check-wrapper-validity object)) - (%instance-ref (fsc-instance-slots object) location)) + (clos-slots-ref (fsc-instance-slots object) + location)) (t (error "unrecognized instance type")))) (cons (cdr location)) (t - (error "The slot ~S has neither :INSTANCE nor :CLASS allocation, ~@ - so it can't be read by the default ~S method." + (error "~@" slotd 'slot-value-using-class))))) (if (eq value +slot-unbound+) - (slot-unbound class object (slot-definition-name slotd)) + (values (slot-unbound class object (slot-definition-name slotd))) value))) (defmethod (setf slot-value-using-class) (new-value (class std-class) (object std-object) (slotd standard-effective-slot-definition)) + (check-obsolete-instance object) (let ((location (slot-definition-location slotd))) (typecase location (fixnum (cond ((std-instance-p object) - (unless (eq 't (wrapper-state (std-instance-wrapper object))) - (check-wrapper-validity object)) - (setf (%instance-ref (std-instance-slots object) location) new-value)) + (setf (clos-slots-ref (std-instance-slots object) location) + new-value)) ((fsc-instance-p object) - (unless (eq 't (wrapper-state (fsc-instance-wrapper object))) - (check-wrapper-validity object)) - (setf (%instance-ref (fsc-instance-slots object) location) new-value)) + (setf (clos-slots-ref (fsc-instance-slots object) location) + new-value)) (t (error "unrecognized instance type")))) (cons (setf (cdr location) new-value)) (t - (error "The slot ~S has neither :INSTANCE nor :CLASS allocation, ~@ - so it can't be written by the default ~S method." + (error "~@" slotd '(setf slot-value-using-class)))))) (defmethod slot-boundp-using-class ((class std-class) (object std-object) (slotd standard-effective-slot-definition)) + (check-obsolete-instance object) (let* ((location (slot-definition-location slotd)) (value (typecase location (fixnum (cond ((std-instance-p object) - (unless (eq 't (wrapper-state (std-instance-wrapper object))) - (check-wrapper-validity object)) - (%instance-ref (std-instance-slots object) location)) + (clos-slots-ref (std-instance-slots object) + location)) ((fsc-instance-p object) - (unless (eq 't (wrapper-state (fsc-instance-wrapper object))) - (check-wrapper-validity object)) - (%instance-ref (fsc-instance-slots object) location)) + (clos-slots-ref (fsc-instance-slots object) + location)) (t (error "unrecognized instance type")))) (cons (cdr location)) (t - (error "The slot ~S has neither :INSTANCE nor :CLASS allocation, ~@ - so it can't be read by the default ~S method." + (error "~@" slotd 'slot-boundp-using-class))))) (not (eq value +slot-unbound+)))) @@ -262,27 +224,53 @@ ((class std-class) (object std-object) (slotd standard-effective-slot-definition)) + (check-obsolete-instance object) (let ((location (slot-definition-location slotd))) (typecase location (fixnum (cond ((std-instance-p object) - (unless (eq 't (wrapper-state (std-instance-wrapper object))) - (check-wrapper-validity object)) - (setf (%instance-ref (std-instance-slots object) location) + (setf (clos-slots-ref (std-instance-slots object) location) +slot-unbound+)) ((fsc-instance-p object) - (unless (eq 't (wrapper-state (fsc-instance-wrapper object))) - (check-wrapper-validity object)) - (setf (%instance-ref (fsc-instance-slots object) location) + (setf (clos-slots-ref (fsc-instance-slots object) location) +slot-unbound+)) (t (error "unrecognized instance type")))) (cons (setf (cdr location) +slot-unbound+)) (t - (error "The slot ~S has neither :INSTANCE nor :CLASS allocation, ~@ - so it can't be written by the default ~S method." + (error "~@" slotd 'slot-makunbound-using-class)))) - nil) + object) + +(defmethod slot-value-using-class + ((class condition-class) + (object condition) + (slotd condition-effective-slot-definition)) + (let ((fun (slot-definition-reader-function slotd))) + (declare (type function fun)) + (funcall fun object))) + +(defmethod (setf slot-value-using-class) + (new-value + (class condition-class) + (object condition) + (slotd condition-effective-slot-definition)) + (let ((fun (slot-definition-writer-function slotd))) + (declare (type function fun)) + (funcall fun new-value object))) + +(defmethod slot-boundp-using-class + ((class condition-class) + (object condition) + (slotd condition-effective-slot-definition)) + (let ((fun (slot-definition-boundp-function slotd))) + (declare (type function fun)) + (funcall fun object))) + +(defmethod slot-makunbound-using-class ((class condition-class) object slot) + (error "attempt to unbind slot ~S in condition object ~S." + slot object)) (defmethod slot-value-using-class ((class structure-class) @@ -292,7 +280,7 @@ (value (funcall function object))) (declare (type function function)) (if (eq value +slot-unbound+) - (slot-unbound class object (slot-definition-name slotd)) + (values (slot-unbound class object (slot-definition-name slotd))) value))) (defmethod (setf slot-value-using-class) @@ -317,28 +305,31 @@ (defmethod slot-missing ((class t) instance slot-name operation &optional new-value) - (error "When attempting to ~A,~%the slot ~S is missing from the object ~S." + (error "~@" (ecase operation (slot-value "read the slot's value (slot-value)") (setf (format nil - "set the slot's value to ~S (setf of slot-value)" + "set the slot's value to ~S (SETF of SLOT-VALUE)" new-value)) - (slot-boundp "test to see whether slot is bound (slot-boundp)") - (slot-makunbound "make the slot unbound (slot-makunbound)")) + (slot-boundp "test to see whether slot is bound (SLOT-BOUNDP)") + (slot-makunbound "make the slot unbound (SLOT-MAKUNBOUND)")) slot-name instance)) (defmethod slot-unbound ((class t) instance slot-name) - (error 'unbound-slot :slot slot-name :instance instance)) + (error 'unbound-slot :name slot-name :instance instance)) (defun slot-unbound-internal (instance position) - (slot-unbound (class-of instance) instance - (etypecase position - (fixnum - (nth position - (wrapper-instance-slots-layout (wrapper-of instance)))) - (cons - (car position))))) + (values + (slot-unbound + (class-of instance) + instance + (etypecase position + (fixnum + (nth position (wrapper-instance-slots-layout (wrapper-of instance)))) + (cons + (car position)))))) (defmethod allocate-instance ((class standard-class) &rest initargs) (declare (ignore initargs)) @@ -351,3 +342,7 @@ (if constructor (funcall constructor) (error "can't allocate an instance of class ~S" (class-name class))))) + +(defmethod allocate-instance ((class condition-class) &rest initargs) + (declare (ignore initargs)) + (make-condition (class-name class)))