X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fslots-boot.lisp;h=43bf09ae619e5a43a4032d662152a11914714b64;hb=304c44d731bea3b9ce3c47d864d90eac92ba604e;hp=274d682def0b21dfaf7779835bed7744193e8048;hpb=2217cdb364e8b48c187b085895bb2a5cbdbd9622;p=sbcl.git diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index 274d682..43bf09a 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -35,19 +35,21 @@ (slot-value (make-method-function (lambda (obj) - (slot-missing (class-of obj) obj slot-name - 'slot-value)))) + (values + (slot-missing (class-of obj) obj slot-name + 'slot-value))))) (slot-boundp (make-method-function (lambda (obj) - (slot-missing (class-of obj) obj slot-name - 'slot-boundp)))) + (not (not + (slot-missing (class-of obj) obj slot-name + 'slot-boundp)))))) (setf (make-method-function (lambda (val obj) - (declare (ignore val)) (slot-missing (class-of obj) obj slot-name - 'setf)))))))) + 'setf val) + val))))))) (setf (getf (getf initargs :plist) :slot-name-lists) (list (list nil slot-name))) (setf (getf (getf initargs :plist) :pv-table-symbol) @@ -76,8 +78,12 @@ (slot-missing-fun slot-name type) "generated slot-missing method" slot-name))))) - (unless (fboundp fun-name) - (let ((gf (ensure-generic-function fun-name))) + (unless (fboundp fun-name) + (let ((gf (ensure-generic-function + fun-name + :lambda-list (ecase type + ((reader boundp) '(object)) + (writer '(new-value object)))))) (ecase type (reader (add-slot-missing-method gf slot-name 'slot-value)) (boundp (add-slot-missing-method gf slot-name 'slot-boundp)) @@ -92,7 +98,8 @@ `(let ((.ignore. (load-time-value (ensure-accessor 'reader ',reader-name ',slot-name)))) (declare (ignore .ignore.)) - (funcall #',reader-name ,object)))) + (truly-the (values t &optional) + (funcall #',reader-name ,object))))) (defmacro accessor-set-slot-value (object slot-name new-value &environment env) (aver (constantp slot-name)) @@ -107,9 +114,11 @@ (form `(let ((.ignore. (load-time-value - (ensure-accessor 'writer ',writer-name ',slot-name)))) + (ensure-accessor 'writer ',writer-name ',slot-name))) + (.new-value. ,new-value)) (declare (ignore .ignore.)) - (funcall #',writer-name ,new-value ,object)))) + (funcall #',writer-name .new-value. ,object) + .new-value.))) (if bindings `(let ,bindings ,form) form))) @@ -130,55 +139,64 @@ t)) (defun get-optimized-std-accessor-method-function (class slotd name) - (if (structure-class-p class) - (ecase name - (reader (slot-definition-internal-reader-function slotd)) - (writer (slot-definition-internal-writer-function slotd)) - (boundp (make-structure-slot-boundp-function slotd))) - (let* ((fsc-p (cond ((standard-class-p class) nil) - ((funcallable-standard-class-p class) t) - ((std-class-p class) - ;; Shouldn't be using the optimized-std-accessors - ;; in this case. - #+nil (format t "* warning: ~S ~S~% ~S~%" - name slotd class) - nil) - (t (error "~S is not a STANDARD-CLASS." class)))) - (slot-name (slot-definition-name slotd)) - (index (slot-definition-location slotd)) - (function (ecase name - (reader #'make-optimized-std-reader-method-function) - (writer #'make-optimized-std-writer-method-function) - (boundp #'make-optimized-std-boundp-method-function))) - (value (funcall function fsc-p slot-name index))) - (declare (type function function)) - (values value index)))) + (cond + ((structure-class-p class) + (ecase name + (reader (slot-definition-internal-reader-function slotd)) + (writer (slot-definition-internal-writer-function slotd)) + (boundp (make-structure-slot-boundp-function slotd)))) + ((condition-class-p class) + (ecase name + (reader (slot-definition-reader-function slotd)) + (writer (slot-definition-writer-function slotd)) + (boundp (slot-definition-boundp-function slotd)))) + (t + (let* ((fsc-p (cond ((standard-class-p class) nil) + ((funcallable-standard-class-p class) t) + ((std-class-p class) + ;; Shouldn't be using the optimized-std-accessors + ;; in this case. + #+nil (format t "* warning: ~S ~S~% ~S~%" + name slotd class) + nil) + (t (error "~S is not a STANDARD-CLASS." class)))) + (slot-name (slot-definition-name slotd)) + (index (slot-definition-location slotd)) + (function (ecase name + (reader #'make-optimized-std-reader-method-function) + (writer #'make-optimized-std-writer-method-function) + (boundp #'make-optimized-std-boundp-method-function))) + (value (funcall function fsc-p slot-name index))) + (declare (type function function)) + (values value index))))) (defun make-optimized-std-reader-method-function (fsc-p slot-name index) (declare #.*optimize-speed*) (set-fun-name (etypecase index - (fixnum (if fsc-p - (lambda (instance) - (check-obsolete-instance instance) - (let ((value (clos-slots-ref (fsc-instance-slots instance) - index))) - (if (eq value +slot-unbound+) - (slot-unbound (class-of instance) instance slot-name) - value))) - (lambda (instance) - (check-obsolete-instance instance) - (let ((value (clos-slots-ref (std-instance-slots instance) - index))) - (if (eq value +slot-unbound+) - (slot-unbound (class-of instance) instance slot-name) - value))))) - (cons (lambda (instance) - (check-obsolete-instance instance) - (let ((value (cdr index))) - (if (eq value +slot-unbound+) - (slot-unbound (class-of instance) instance slot-name) - value))))) + (fixnum + (if fsc-p + (lambda (instance) + (check-obsolete-instance instance) + (let ((value (clos-slots-ref (fsc-instance-slots instance) index))) + (if (eq value +slot-unbound+) + (values + (slot-unbound (class-of instance) instance slot-name)) + value))) + (lambda (instance) + (check-obsolete-instance instance) + (let ((value (clos-slots-ref (std-instance-slots instance) index))) + (if (eq value +slot-unbound+) + (values + (slot-unbound (class-of instance) instance slot-name)) + value))))) + (cons + (lambda (instance) + (check-obsolete-instance instance) + (let ((value (cdr index))) + (if (eq value +slot-unbound+) + (values (slot-unbound (class-of instance) instance slot-name)) + value))))) `(reader ,slot-name))) (defun make-optimized-std-writer-method-function (fsc-p slot-name index) @@ -236,31 +254,52 @@ (declare (ignore class object slotd)) t)) -(defun get-optimized-std-slot-value-using-class-method-function (class - slotd - name) - (if (structure-class-p class) - (ecase name - (reader (make-optimized-structure-slot-value-using-class-method-function - (slot-definition-internal-reader-function slotd))) - (writer (make-optimized-structure-setf-slot-value-using-class-method-function - (slot-definition-internal-writer-function slotd))) - (boundp (make-optimized-structure-slot-boundp-using-class-method-function))) - (let* ((fsc-p (cond ((standard-class-p class) nil) - ((funcallable-standard-class-p class) t) - (t (error "~S is not a standard-class" class)))) - (slot-name (slot-definition-name slotd)) - (index (slot-definition-location slotd)) - (function - (ecase name - (reader - #'make-optimized-std-slot-value-using-class-method-function) - (writer - #'make-optimized-std-setf-slot-value-using-class-method-function) - (boundp - #'make-optimized-std-slot-boundp-using-class-method-function)))) - (declare (type function function)) - (values (funcall function fsc-p slot-name index) index)))) +(defun get-optimized-std-slot-value-using-class-method-function + (class slotd name) + (cond + ((structure-class-p class) + (ecase name + (reader (make-optimized-structure-slot-value-using-class-method-function + (slot-definition-internal-reader-function slotd))) + (writer (make-optimized-structure-setf-slot-value-using-class-method-function + (slot-definition-internal-writer-function slotd))) + (boundp (make-optimized-structure-slot-boundp-using-class-method-function)))) + ((condition-class-p class) + (ecase name + (reader + (let ((fun (slot-definition-reader-function slotd))) + (declare (type function fun)) + (lambda (class object slotd) + (declare (ignore class slotd)) + (funcall fun object)))) + (writer + (let ((fun (slot-definition-writer-function slotd))) + (declare (type function fun)) + (lambda (new-value class object slotd) + (declare (ignore class slotd)) + (funcall fun new-value object)))) + (boundp + (let ((fun (slot-definition-boundp-function slotd))) + (declare (type function fun)) + (lambda (class object slotd) + (declare (ignore class slotd)) + (funcall fun object)))))) + (t + (let* ((fsc-p (cond ((standard-class-p class) nil) + ((funcallable-standard-class-p class) t) + (t (error "~S is not a standard-class" class)))) + (slot-name (slot-definition-name slotd)) + (index (slot-definition-location slotd)) + (function + (ecase name + (reader + #'make-optimized-std-slot-value-using-class-method-function) + (writer + #'make-optimized-std-setf-slot-value-using-class-method-function) + (boundp + #'make-optimized-std-slot-boundp-using-class-method-function)))) + (declare (type function function)) + (values (funcall function fsc-p slot-name index) index))))) (defun make-optimized-std-slot-value-using-class-method-function (fsc-p slot-name index) @@ -273,7 +312,7 @@ (let ((value (clos-slots-ref (fsc-instance-slots instance) index))) (if (eq value +slot-unbound+) - (slot-unbound class instance slot-name) + (values (slot-unbound class instance slot-name)) value))) (lambda (class instance slotd) (declare (ignore slotd)) @@ -281,14 +320,14 @@ (let ((value (clos-slots-ref (std-instance-slots instance) index))) (if (eq value +slot-unbound+) - (slot-unbound class instance slot-name) + (values (slot-unbound class instance slot-name)) value))))) (cons (lambda (class instance slotd) (declare (ignore slotd)) (check-obsolete-instance instance) (let ((value (cdr index))) (if (eq value +slot-unbound+) - (slot-unbound class instance slot-name) + (values (slot-unbound class instance slot-name)) value)))))) (defun make-optimized-std-setf-slot-value-using-class-method-function @@ -361,16 +400,16 @@ (let ((value (clos-slots-ref (get-slots instance) index))) (if (eq value +slot-unbound+) - (slot-unbound (class-of instance) - instance - slot-name) + (values (slot-unbound (class-of instance) + instance + slot-name)) value))) (cons (let ((value (cdr index))) (if (eq value +slot-unbound+) - (slot-unbound (class-of instance) - instance - slot-name) + (values (slot-unbound (class-of instance) + instance + slot-name)) value))) (t (error "~@