X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fslots-boot.lisp;h=dc7b804b294a492e513c314fa0e931a0a2591106;hb=f3f677703e37f5a335b3be7fa64f7748ad969517;hp=0d3b707f75d76515286653b2af11fd0cedd2b4dd;hpb=3abdab003d4cdb02d7386dcd4bc8d9ac4dafb359;p=sbcl.git diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index 0d3b707..dc7b804 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -78,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)) @@ -134,6 +138,30 @@ (declare (ignore object)) t)) +(define-condition instance-structure-protocol-error + (reference-condition error) + ((slotd :initarg :slotd :reader instance-structure-protocol-error-slotd) + (fun :initarg :fun :reader instance-structure-protocol-error-fun)) + (:report + (lambda (c s) + (format s "~@" + (instance-structure-protocol-error-slotd c) + :instance :class + (cond + ((member (instance-structure-protocol-error-fun c) + '(slot-value-using-class slot-boundp-using-class)) + "read") + (t "written")) + (instance-structure-protocol-error-fun c))))) + +(defun instance-structure-protocol-error (slotd fun) + (error 'instance-structure-protocol-error + :slotd slotd :fun fun + :references (list `(:amop :generic-function ,fun) + '(:amop :section (5 5 3))))) + (defun get-optimized-std-accessor-method-function (class slotd name) (cond ((structure-class-p class) @@ -157,31 +185,38 @@ nil) (t (error "~S is not a STANDARD-CLASS." class)))) (slot-name (slot-definition-name slotd)) - (index (slot-definition-location slotd)) + (location (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))) + ;; KLUDGE: we need this slightly hacky calling convention + ;; for these functions for bootstrapping reasons: see + ;; !BOOTSTRAP-MAKE-SLOT-DEFINITION in braid.lisp. -- CSR, + ;; 2004-07-12 + (value (funcall function fsc-p slotd slot-name location))) (declare (type function function)) - (values value index))))) + (values value (slot-definition-location slotd)))))) -(defun make-optimized-std-reader-method-function (fsc-p slot-name index) +(defun make-optimized-std-reader-method-function + (fsc-p slotd slot-name location) (declare #.*optimize-speed*) (set-fun-name - (etypecase index + (etypecase location (fixnum (if fsc-p (lambda (instance) (check-obsolete-instance instance) - (let ((value (clos-slots-ref (fsc-instance-slots instance) index))) + (let ((value (clos-slots-ref (fsc-instance-slots instance) + location))) (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))) + (let ((value (clos-slots-ref (std-instance-slots instance) + location))) (if (eq value +slot-unbound+) (values (slot-unbound (class-of instance) instance slot-name)) @@ -189,57 +224,74 @@ (cons (lambda (instance) (check-obsolete-instance instance) - (let ((value (cdr index))) + (let ((value (cdr location))) (if (eq value +slot-unbound+) (values (slot-unbound (class-of instance) instance slot-name)) - value))))) + value)))) + (null + (lambda (instance) + (instance-structure-protocol-error slotd 'slot-value-using-class)))) `(reader ,slot-name))) -(defun make-optimized-std-writer-method-function (fsc-p slot-name index) +(defun make-optimized-std-writer-method-function + (fsc-p slotd slot-name location) (declare #.*optimize-speed*) (set-fun-name - (etypecase index + (etypecase location (fixnum (if fsc-p (lambda (nv instance) (check-obsolete-instance instance) - (setf (clos-slots-ref (fsc-instance-slots instance) index) + (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) index) + (setf (clos-slots-ref (std-instance-slots instance) + location) nv)))) - (cons (lambda (nv instance) - (check-obsolete-instance instance) - (setf (cdr index) nv)))) + (cons (lambda (nv instance) + (check-obsolete-instance instance) + (setf (cdr location) nv))) + (null + (lambda (nv instance) + (declare (ignore nv)) + (instance-structure-protocol-error slotd + '(setf slot-value-using-class))))) `(writer ,slot-name))) -(defun make-optimized-std-boundp-method-function (fsc-p slot-name index) +(defun make-optimized-std-boundp-method-function + (fsc-p slotd slot-name location) (declare #.*optimize-speed*) (set-fun-name - (etypecase index + (etypecase location (fixnum (if fsc-p (lambda (instance) (check-obsolete-instance instance) (not (eq (clos-slots-ref (fsc-instance-slots instance) - index) + location) +slot-unbound+))) (lambda (instance) (check-obsolete-instance instance) (not (eq (clos-slots-ref (std-instance-slots instance) - index) + location) +slot-unbound+))))) (cons (lambda (instance) (check-obsolete-instance instance) - (not (eq (cdr index) +slot-unbound+))))) + (not (eq (cdr location) +slot-unbound+)))) + (null + (lambda (instance) + (instance-structure-protocol-error slotd 'slot-boundp-using-class)))) `(boundp ,slot-name))) -(defun make-optimized-structure-slot-value-using-class-method-function (function) +(defun make-optimized-structure-slot-value-using-class-method-function + (function) (declare (type function function)) (lambda (class object slotd) (declare (ignore class slotd)) (funcall function object))) -(defun make-optimized-structure-setf-slot-value-using-class-method-function (function) +(defun make-optimized-structure-setf-slot-value-using-class-method-function + (function) (declare (type function function)) (lambda (nv class object slotd) (declare (ignore class slotd)) @@ -284,8 +336,6 @@ (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 @@ -295,78 +345,95 @@ (boundp #'make-optimized-std-slot-boundp-using-class-method-function)))) (declare (type function function)) - (values (funcall function fsc-p slot-name index) index))))) + (values (funcall function fsc-p slotd) + (slot-definition-location slotd)))))) -(defun make-optimized-std-slot-value-using-class-method-function - (fsc-p slot-name index) +(defun make-optimized-std-slot-value-using-class-method-function (fsc-p slotd) (declare #.*optimize-speed*) - (etypecase index - (fixnum (if fsc-p - (lambda (class instance slotd) - (declare (ignore slotd)) - (check-obsolete-instance instance) - (let ((value (clos-slots-ref (fsc-instance-slots instance) - index))) - (if (eq value +slot-unbound+) - (values (slot-unbound class instance slot-name)) - value))) - (lambda (class instance slotd) - (declare (ignore slotd)) - (check-obsolete-instance instance) - (let ((value (clos-slots-ref (std-instance-slots instance) - index))) - (if (eq value +slot-unbound+) - (values (slot-unbound class instance slot-name)) - value))))) - (cons (lambda (class instance slotd) + (let ((location (slot-definition-location slotd)) + (slot-name (slot-definition-name slotd))) + (etypecase location + (fixnum (if fsc-p + (lambda (class instance slotd) + (declare (ignore slotd)) + (check-obsolete-instance instance) + (let ((value (clos-slots-ref (fsc-instance-slots instance) + location))) + (if (eq value +slot-unbound+) + (values (slot-unbound class instance slot-name)) + value))) + (lambda (class instance slotd) + (declare (ignore slotd)) + (check-obsolete-instance instance) + (let ((value (clos-slots-ref (std-instance-slots instance) + location))) + (if (eq value +slot-unbound+) + (values (slot-unbound class instance slot-name)) + value))))) + (cons (lambda (class instance slotd) (declare (ignore slotd)) (check-obsolete-instance instance) - (let ((value (cdr index))) + (let ((value (cdr location))) (if (eq value +slot-unbound+) (values (slot-unbound class instance slot-name)) - value)))))) + value)))) + (null + (lambda (class instance slotd) + (declare (ignore class instance)) + (instance-structure-protocol-error slotd 'slot-value-using-class)))))) (defun make-optimized-std-setf-slot-value-using-class-method-function - (fsc-p slot-name index) + (fsc-p slotd) (declare #.*optimize-speed*) - (declare (ignore slot-name)) - (etypecase index - (fixnum (if fsc-p - (lambda (nv class instance slotd) - (declare (ignore class slotd)) - (check-obsolete-instance instance) - (setf (clos-slots-ref (fsc-instance-slots instance) index) - nv)) - (lambda (nv class instance slotd) - (declare (ignore class slotd)) - (check-obsolete-instance instance) - (setf (clos-slots-ref (std-instance-slots instance) index) - nv)))) - (cons (lambda (nv class instance slotd) + (let ((location (slot-definition-location slotd))) + (etypecase location + (fixnum + (if fsc-p + (lambda (nv class instance slotd) + (declare (ignore class slotd)) + (check-obsolete-instance instance) + (setf (clos-slots-ref (fsc-instance-slots instance) location) + nv)) + (lambda (nv class instance slotd) (declare (ignore class slotd)) (check-obsolete-instance instance) - (setf (cdr index) nv))))) + (setf (clos-slots-ref (std-instance-slots instance) location) + nv)))) + (cons (lambda (nv class instance slotd) + (declare (ignore class slotd)) + (check-obsolete-instance instance) + (setf (cdr location) nv))) + (null (lambda (nv class instance slotd) + (declare (ignore nv class instance)) + (instance-structure-protocol-error + slotd '(setf slot-value-using-class))))))) (defun make-optimized-std-slot-boundp-using-class-method-function - (fsc-p slot-name index) + (fsc-p slotd) (declare #.*optimize-speed*) - (declare (ignore slot-name)) - (etypecase index - (fixnum (if fsc-p - (lambda (class instance slotd) - (declare (ignore class slotd)) - (check-obsolete-instance instance) - (not (eq (clos-slots-ref (fsc-instance-slots instance) index) - +slot-unbound+))) - (lambda (class instance slotd) - (declare (ignore class slotd)) - (check-obsolete-instance instance) - (not (eq (clos-slots-ref (std-instance-slots instance) index) - +slot-unbound+))))) - (cons (lambda (class instance slotd) + (let ((location (slot-definition-location slotd))) + (etypecase location + (fixnum + (if fsc-p + (lambda (class instance slotd) + (declare (ignore class slotd)) + (check-obsolete-instance instance) + (not (eq (clos-slots-ref (fsc-instance-slots instance) location) + +slot-unbound+))) + (lambda (class instance slotd) + (declare (ignore class slotd)) + (check-obsolete-instance instance) + (not (eq (clos-slots-ref (std-instance-slots instance) location) + +slot-unbound+))))) + (cons (lambda (class instance slotd) (declare (ignore class slotd)) (check-obsolete-instance instance) - (not (eq (cdr index) +slot-unbound+)))))) + (not (eq (cdr location) +slot-unbound+)))) + (null + (lambda (class instance slotd) + (declare (ignore class instance)) + (instance-structure-protocol-error slotd + 'slot-boundp-using-class)))))) (defun get-accessor-from-svuc-method-function (class slotd sdfun name) (macrolet ((emf-funcall (emf &rest args) @@ -465,15 +532,16 @@ initargs))) (defun initialize-internal-slot-gfs (slot-name &optional type) - (macrolet ((frob (type name-fun add-fun) + (macrolet ((frob (type name-fun add-fun ll) `(when (or (null type) (eq type ',type)) (let* ((name (,name-fun slot-name)) - (gf (ensure-generic-function name)) + (gf (ensure-generic-function name + :lambda-list ',ll)) (methods (generic-function-methods gf))) (when (or (null methods) (plist-value gf 'slot-missing-method)) (setf (plist-value gf 'slot-missing-method) nil) (,add-fun *the-class-slot-object* gf slot-name)))))) - (frob reader slot-reader-name add-reader-method) - (frob writer slot-writer-name add-writer-method) - (frob boundp slot-boundp-name add-boundp-method))) + (frob reader slot-reader-name add-reader-method (object)) + (frob writer slot-writer-name add-writer-method (new-value object)) + (frob boundp slot-boundp-name add-boundp-method (object))))