X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fslots-boot.lisp;h=8a5993b5808379f50ccacbdb04c3cccffc7e2000;hb=0f3a5f2e8886d18d0b4f6485c38a42be629422ae;hp=274d682def0b21dfaf7779835bed7744193e8048;hpb=2217cdb364e8b48c187b085895bb2a5cbdbd9622;p=sbcl.git diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index 274d682..8a5993b 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -23,103 +23,83 @@ (in-package "SB-PCL") -(defun ensure-accessor (type fun-name slot-name) - (labels ((slot-missing-fun (slot-name type) - (let* ((method-type (ecase type - (slot-value 'reader-method) - (setf 'writer-method) - (slot-boundp 'boundp-method))) - (initargs - (copy-tree - (ecase type - (slot-value - (make-method-function - (lambda (obj) - (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)))) - (setf - (make-method-function - (lambda (val obj) - (declare (ignore val)) - (slot-missing (class-of obj) obj slot-name - 'setf)))))))) - (setf (getf (getf initargs :plist) :slot-name-lists) - (list (list nil slot-name))) - (setf (getf (getf initargs :plist) :pv-table-symbol) - (gensym)) - (list* :method-spec (list method-type 'slot-object slot-name) - initargs))) - (add-slot-missing-method (gf slot-name type) - (multiple-value-bind (class lambda-list specializers) - (ecase type - (slot-value - (values 'standard-reader-method - '(object) - (list *the-class-slot-object*))) - (slot-boundp - (values 'standard-boundp-method - '(object) - (list *the-class-slot-object*))) - (setf - (values 'standard-writer-method - '(new-value object) - (list *the-class-t* *the-class-slot-object*)))) - (add-method gf (make-a-method class - () - lambda-list - specializers - (slot-missing-fun slot-name type) - "generated slot-missing method" - slot-name))))) - (unless (fboundp fun-name) - (let ((gf (ensure-generic-function fun-name))) - (ecase type - (reader (add-slot-missing-method gf slot-name 'slot-value)) - (boundp (add-slot-missing-method gf slot-name 'slot-boundp)) - (writer (add-slot-missing-method gf slot-name 'setf))) - (setf (plist-value gf 'slot-missing-method) t)) - t))) +(let ((reader-specializers '(slot-object)) + (writer-specializers '(t slot-object))) + (defun ensure-accessor (type fun-name slot-name) + (unless (fboundp fun-name) + (multiple-value-bind (lambda-list specializers method-class initargs doc) + (ecase type + ;; FIXME: change SLOT-OBJECT here to T to get SLOT-MISSING + ;; behaviour for non-slot-objects too? + (reader + (values '(object) reader-specializers 'global-reader-method + (make-std-reader-method-function 'slot-object slot-name) + "automatically-generated reader method")) + (writer + (values '(new-value object) writer-specializers + 'global-writer-method + (make-std-writer-method-function 'slot-object slot-name) + "automatically-generated writer method")) + (boundp + (values '(object) reader-specializers 'global-boundp-method + (make-std-boundp-method-function 'slot-object slot-name) + "automatically-generated boundp method"))) + (let ((gf (ensure-generic-function fun-name :lambda-list lambda-list))) + (add-method gf (make-a-method method-class + () lambda-list specializers + initargs doc :slot-name slot-name))))) + t) + ;; KLUDGE: this is maybe PCL bootstrap mechanism #6 or #7, invented + ;; by CSR in June 2007. Making the bootstrap sane is getting higher + ;; on the "TODO: URGENT" list. + (defun !fix-ensure-accessor-specializers () + (setf reader-specializers (mapcar #'find-class reader-specializers)) + (setf writer-specializers (mapcar #'find-class writer-specializers)))) -(defmacro accessor-slot-value (object slot-name) - (aver (constantp slot-name)) - (let* ((slot-name (eval slot-name)) - (reader-name (slot-reader-name slot-name))) +(defmacro quiet-funcall (fun &rest args) + ;; Don't give a style-warning about undefined function here. + `(funcall (locally (declare (muffle-conditions style-warning)) + ,fun) + ,@args)) + +(defmacro accessor-slot-value (object slot-name &environment env) + (aver (constantp slot-name env)) + (let* ((slot-name (constant-form-value slot-name env)) + (reader-name (slot-reader-name slot-name))) `(let ((.ignore. (load-time-value - (ensure-accessor 'reader ',reader-name ',slot-name)))) - (declare (ignore .ignore.)) - (funcall #',reader-name ,object)))) + (ensure-accessor 'reader ',reader-name ',slot-name)))) + (declare (ignore .ignore.)) + (truly-the (values t &optional) + (quiet-funcall #',reader-name ,object))))) (defmacro accessor-set-slot-value (object slot-name new-value &environment env) - (aver (constantp slot-name)) - (setq object (macroexpand object env)) - (setq slot-name (macroexpand slot-name env)) - (let* ((slot-name (eval slot-name)) - (bindings (unless (or (constantp new-value) (atom new-value)) - (let ((object-var (gensym))) - (prog1 `((,object-var ,object)) - (setq object object-var))))) - (writer-name (slot-writer-name slot-name)) - (form - `(let ((.ignore. - (load-time-value - (ensure-accessor 'writer ',writer-name ',slot-name)))) - (declare (ignore .ignore.)) - (funcall #',writer-name ,new-value ,object)))) - (if bindings - `(let ,bindings ,form) - form))) + (aver (constantp slot-name env)) + (setq object (%macroexpand object env)) + (let* ((slot-name (constant-form-value slot-name env)) + (bind-object (unless (or (constantp new-value env) (atom new-value)) + (let* ((object-var (gensym)) + (bind `((,object-var ,object)))) + (setf object object-var) + bind))) + (writer-name (slot-writer-name slot-name)) + (form + `(let ((.ignore. + (load-time-value + (ensure-accessor 'writer ',writer-name ',slot-name))) + (.new-value. ,new-value)) + (declare (ignore .ignore.)) + (quiet-funcall #',writer-name .new-value. ,object) + .new-value.))) + (if bind-object + `(let ,bind-object ,form) + form))) -(defmacro accessor-slot-boundp (object slot-name) - (aver (constantp slot-name)) - (let* ((slot-name (eval slot-name)) - (boundp-name (slot-boundp-name slot-name))) +(defmacro accessor-slot-boundp (object slot-name &environment env) + (aver (constantp slot-name env)) + (let* ((slot-name (constant-form-value slot-name env)) + (boundp-name (slot-boundp-name slot-name))) `(let ((.ignore. (load-time-value - (ensure-accessor 'boundp ',boundp-name ',slot-name)))) + (ensure-accessor 'boundp ',boundp-name ',slot-name)))) (declare (ignore .ignore.)) (funcall #',boundp-name ,object)))) @@ -129,103 +109,205 @@ (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) - (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) + (let ((info (slot-definition-info slotd))) + (ecase name + (reader (slot-info-reader info)) + (writer (slot-info-writer info)) + (boundp (slot-info-boundp info))))) + (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)) + (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))) + ;; 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 (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 - (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))))) + (etypecase location + (fixnum + (if fsc-p + (lambda (instance) + (check-obsolete-instance instance) + (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) + location))) + (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 location))) + (if (eq value +slot-unbound+) + (values (slot-unbound (class-of instance) instance slot-name)) + 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 - (fixnum (if fsc-p - (lambda (nv instance) - (check-obsolete-instance instance) - (setf (clos-slots-ref (fsc-instance-slots instance) index) - nv)) - (lambda (nv instance) - (check-obsolete-instance instance) - (setf (clos-slots-ref (std-instance-slots instance) index) - nv)))) - (cons (lambda (nv instance) - (check-obsolete-instance instance) - (setf (cdr index) nv)))) - `(writer ,slot-name))) + ;; The (WHEN SLOTD ...) gunk is for building early slot definitions. + (let* ((class (when slotd (slot-definition-class slotd))) + (safe-p (when slotd (safe-p class))) + (orig-wrapper (when safe-p (class-wrapper class))) + (info (when safe-p (slot-definition-info slotd))) + (writer-fun (etypecase location + ;; In SAFE-P case the typechecking already validated the instance. + (fixnum + (if fsc-p + (if safe-p + (lambda (nv instance) + (setf (clos-slots-ref (fsc-instance-slots instance) + location) + nv)) + (lambda (nv instance) + (check-obsolete-instance instance) + (setf (clos-slots-ref (fsc-instance-slots instance) + location) + nv))) + (if safe-p + (lambda (nv instance) + (setf (clos-slots-ref (std-instance-slots instance) + location) + nv)) + (lambda (nv instance) + (check-obsolete-instance instance) + (setf (clos-slots-ref (std-instance-slots instance) + location) + nv))))) + (cons + (if safe-p + (lambda (nv instance) + (setf (cdr location) nv)) + (lambda (nv instance) + (check-obsolete-instance instance) + (setf (cdr location) nv)))) + (null + (lambda (nv instance) + (declare (ignore nv instance)) + (instance-structure-protocol-error + slotd + '(setf slot-value-using-class)))))) + (checking-fun (when safe-p + (lambda (new-value instance) + ;; If we have a TYPE-CHECK-FUNCTION, call it. + (let* (;; Note that the class of INSTANCE here is not + ;; neccessarily the SLOT-DEFINITION-CLASS of + ;; the SLOTD passed to M-O-S-W-M-F, since it's + ;; e.g. possible for a subclass to define a + ;; slot of the same name but with no + ;; accessors. So we may need to fetch the + ;; right SLOT-INFO from the wrapper instead of + ;; just closing over it. + (wrapper (valid-wrapper-of instance)) + (typecheck + (slot-info-typecheck + (if (eq wrapper orig-wrapper) + info + (cdr (find-slot-cell wrapper slot-name)))))) + (when typecheck + (funcall typecheck new-value))) + ;; Then call the real writer. + (funcall writer-fun new-value instance))))) + (set-fun-name (if safe-p + checking-fun + writer-fun) + `(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) - +slot-unbound+))) - (lambda (instance) - (check-obsolete-instance instance) - (not (eq (clos-slots-ref (std-instance-slots instance) - index) - +slot-unbound+))))) + (lambda (instance) + (check-obsolete-instance instance) + (not (eq (clos-slots-ref (fsc-instance-slots instance) + location) + +slot-unbound+))) + (lambda (instance) + (check-obsolete-instance instance) + (not (eq (clos-slots-ref (std-instance-slots instance) + location) + +slot-unbound+))))) (cons (lambda (instance) - (check-obsolete-instance instance) - (not (eq (cdr index) +slot-unbound+))))) + (check-obsolete-instance instance) + (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)) @@ -236,209 +318,349 @@ (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) + (let ((info (slot-definition-info slotd))) + (ecase name + (reader + (let ((fun (slot-info-reader info))) + (lambda (class object slotd) + (declare (ignore class slotd)) + (funcall fun object)))) + (writer + (let ((fun (slot-info-writer info))) + (lambda (new-value class object slotd) + (declare (ignore class slotd)) + (funcall fun new-value object)))) + (boundp + (let ((fun (slot-info-boundp info))) + (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)))) + (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 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+) - (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+) - (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) - value)))))) + (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 location))) + (if (eq value +slot-unbound+) + (values (slot-unbound class instance slot-name)) + 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) - (declare (ignore class slotd)) - (check-obsolete-instance instance) - (setf (cdr index) nv))))) + (let* ((location (slot-definition-location slotd)) + (class (slot-definition-class slotd)) + (typecheck + (when (safe-p class) + (slot-info-typecheck (slot-definition-info slotd))))) + (macrolet ((make-mf-lambda (&body body) + `(lambda (nv class instance slotd) + (declare (ignore class slotd)) + (check-obsolete-instance instance) + ,@body)) + (make-mf-lambdas (&body body) + ;; Having separate lambdas for the NULL / not-NULL cases of + ;; TYPE-CHECK-FUNCTION is done to avoid runtime overhead + ;; for CLOS typechecking when it's not in use. + `(if typecheck + (make-mf-lambda + (funcall (the function typecheck) nv) + ,@body) + (make-mf-lambda + ,@body)))) + (etypecase location + (fixnum + (if fsc-p + (make-mf-lambdas + (setf (clos-slots-ref (fsc-instance-slots instance) location) + nv)) + (make-mf-lambdas + (setf (clos-slots-ref (std-instance-slots instance) location) + nv)))) + (cons + (make-mf-lambdas (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) - (declare (ignore class slotd)) - (check-obsolete-instance instance) - (not (eq (cdr index) +slot-unbound+)))))) + (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 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) - `(invoke-effective-method-function ,emf nil ,@args))) + `(invoke-effective-method-function ,emf nil + :required-args ,args))) (set-fun-name (case name (reader (lambda (instance) - (emf-funcall sdfun class instance slotd))) + (emf-funcall sdfun class instance slotd))) (writer (lambda (nv instance) - (emf-funcall sdfun nv class instance slotd))) + (emf-funcall sdfun nv class instance slotd))) (boundp (lambda (instance) - (emf-funcall sdfun class instance slotd)))) + (emf-funcall sdfun class instance slotd)))) `(,name ,(class-name class) ,(slot-definition-name slotd))))) + +(defun maybe-class (class-or-name) + (when (eq **boot-state** 'complete) + (if (typep class-or-name 'class) + class-or-name + (find-class class-or-name nil)))) + +(defun make-std-reader-method-function (class-or-name slot-name) + (declare (ignore class-or-name)) + (ecase (slot-access-strategy (maybe-class class-or-name) slot-name 'reader t) + (:standard + (let* ((initargs (copy-tree + (make-method-function + (lambda (instance) + (pv-binding1 ((bug "Please report this") + (instance) (instance-slots)) + (instance-read-standard + .pv. instance-slots 0 + (slot-value instance slot-name)))))))) + (setf (getf (getf initargs 'plist) :slot-name-lists) + (list (list nil slot-name))) + initargs)) + ((:custom :accessor) + (let* ((initargs (copy-tree + (make-method-function + (lambda (instance) + (pv-binding1 ((bug "Please report this") + (instance) nil) + (instance-read-custom .pv. 0 instance))))))) + (setf (getf (getf initargs 'plist) :slot-name-lists) + (list (list nil slot-name))) + initargs)))) + +(defun make-std-writer-method-function (class-or-name slot-name) + (let ((class (maybe-class class-or-name))) + (ecase (slot-access-strategy class slot-name 'writer t) + (:standard + (let ((initargs (copy-tree + (if (and class (safe-p class)) + (make-method-function + (lambda (nv instance) + (pv-binding1 ((bug "Please report this") + (instance) (instance-slots)) + (instance-write-standard + .pv. instance-slots 0 nv + (setf (slot-value instance slot-name) .good-new-value.) + nil t)))) + (make-method-function + (lambda (nv instance) + (pv-binding1 ((bug "Please report this") + (instance) (instance-slots)) + (instance-write-standard + .pv. instance-slots 0 nv + (setf (slot-value instance slot-name) .good-new-value.))))))))) + (setf (getf (getf initargs 'plist) :slot-name-lists) + (list nil (list nil slot-name))) + initargs)) + ((:custom :accessor) + (let ((initargs (copy-tree + (make-method-function + (lambda (nv instance) + (pv-binding1 ((bug "Please report this") + (instance) nil) + (instance-write-custom .pv. 0 instance nv))))))) + (setf (getf (getf initargs 'plist) :slot-name-lists) + (list nil (list nil slot-name))) + initargs))))) -(defun make-internal-reader-method-function (class-name slot-name) - (list* :method-spec `(internal-reader-method ,class-name ,slot-name) - (make-method-function - (lambda (instance) - (let ((wrapper (get-instance-wrapper-or-nil instance))) - (if wrapper - (let* ((class (wrapper-class* wrapper)) - (index (or (instance-slot-index wrapper slot-name) - (assq slot-name - (wrapper-class-slots wrapper))))) - (typecase index - (fixnum - (let ((value (clos-slots-ref (get-slots instance) - index))) - (if (eq value +slot-unbound+) - (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) - value))) - (t - (error "~@" - class slot-name)))) - (slot-value instance slot-name))))))) +(defun make-std-boundp-method-function (class-or-name slot-name) + (declare (ignore class-or-name)) + (ecase (slot-access-strategy (maybe-class class-or-name) slot-name 'boundp t) + (:standard + (let ((initargs (copy-tree + (make-method-function + (lambda (instance) + (pv-binding1 ((bug "Please report this") + (instance) (instance-slots)) + (instance-boundp-standard + .pv. instance-slots 0 + (slot-boundp instance slot-name)))))))) + (setf (getf (getf initargs 'plist) :slot-name-lists) + (list (list nil slot-name))) + initargs)) + ((:custom :accessor) + (let ((initargs (copy-tree + (make-method-function + (lambda (instance) + (pv-binding1 ((bug "Please report this") + (instance) nil) + (instance-boundp-custom .pv. 0 instance))))))) + (setf (getf (getf initargs 'plist) :slot-name-lists) + (list (list nil slot-name))) + initargs)))) -(defun make-std-reader-method-function (class-name slot-name) - (let* ((pv-table-symbol (gensym)) - (initargs (copy-tree - (make-method-function - (lambda (instance) - (pv-binding1 (.pv. .calls. - (symbol-value pv-table-symbol) - (instance) (instance-slots)) - (instance-read-internal - .pv. instance-slots 1 - (slot-value instance slot-name)))))))) - (setf (getf (getf initargs :plist) :slot-name-lists) - (list (list nil slot-name))) - (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol) - (list* :method-spec `(reader-method ,class-name ,slot-name) - initargs))) +;;;; FINDING SLOT DEFINITIONS +;;; +;;; Historical PCL found slot definitions by iterating over +;;; CLASS-SLOTS, which is O(N) for number of slots, and moreover +;;; requires a GF call (for SLOT-DEFINITION-NAME) for each slot in +;;; list up to the desired one. +;;; +;;; Current SBCL hashes the effective slot definitions, and some +;;; information pulled out from them into a simple-vector, with bucket +;;; chains made out of plists keyed by the slot names. This fixes +;;; gives O(1) performance, and avoid the GF calls. +;;; +;;; MAKE-SLOT-TABLE constructs the hashed vector out of a list of +;;; effective slot definitions and the class they pertain to, and +;;; FIND-SLOT-DEFINITION knows how to look up slots in that vector. +;;; +;;; The only bit of cleverness in the implementation is to make the +;;; vectors fairly tight, but always longer then 0 elements: +;;; +;;; -- We don't want to waste huge amounts of space no these vectors, +;;; which are mostly required by things like SLOT-VALUE with a +;;; variable slot name, so a constant extension over the minimum +;;; size seems like a good choise. +;;; +;;; -- As long as the vector always has a length > 0 +;;; FIND-SLOT-DEFINITION doesn't need to handle the rare case of an +;;; empty vector separately: it just returns a NIL. +;;; +;;; In addition to the slot-definition we also store the slot-location +;;; and type-check function for instances of standard metaclasses, so +;;; that SLOT-VALUE &co using variable slot names can get at them +;;; without additional GF calls. +;;; +;;; Notes: +;;; It would be probably better to store the vector in wrapper +;;; instead: one less memory indirection, one less CLOS slot +;;; access to get at it. +;;; +;;; It would also be nice to have STANDARD-INSTANCE-STRUCTURE-P +;;; generic instead of checking versus STANDARD-CLASS and +;;; FUNCALLABLE-STANDARD-CLASS. -(defun make-std-writer-method-function (class-name slot-name) - (let* ((pv-table-symbol (gensym)) - (initargs (copy-tree - (make-method-function - (lambda (nv instance) - (pv-binding1 (.pv. .calls. - (symbol-value pv-table-symbol) - (instance) (instance-slots)) - (instance-write-internal - .pv. instance-slots 1 nv - (setf (slot-value instance slot-name) nv)))))))) - (setf (getf (getf initargs :plist) :slot-name-lists) - (list nil (list nil slot-name))) - (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol) - (list* :method-spec `(writer-method ,class-name ,slot-name) - initargs))) +(defun find-slot-definition (class slot-name &optional errorp) + (unless (class-finalized-p class) + (or (try-finalize-inheritance class) + (if errorp + (error "Cannot look up slot-definition for ~S in ~S (too early to finalize.)" + slot-name class) + (return-from find-slot-definition (values nil nil))))) + (dolist (slotd (class-slots class) + (if errorp + (error "No slot called ~S in ~S." slot-name class) + (values nil t))) + (when (eq slot-name (slot-definition-name slotd)) + (return (values slotd t))))) -(defun make-std-boundp-method-function (class-name slot-name) - (let* ((pv-table-symbol (gensym)) - (initargs (copy-tree - (make-method-function - (lambda (instance) - (pv-binding1 (.pv. .calls. - (symbol-value pv-table-symbol) - (instance) (instance-slots)) - (instance-boundp-internal - .pv. instance-slots 1 - (slot-boundp instance slot-name)))))))) - (setf (getf (getf initargs :plist) :slot-name-lists) - (list (list nil slot-name))) - (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol) - (list* :method-spec `(boundp-method ,class-name ,slot-name) - initargs))) +(defun find-slot-cell (wrapper slot-name) + (declare (symbol slot-name)) + (let* ((vector (layout-slot-table wrapper)) + (index (rem (sxhash slot-name) (length vector)))) + (declare (simple-vector vector) (index index) + (optimize (sb-c::insert-array-bounds-checks 0))) + (do ((plist (the list (svref vector index)) (cdr plist))) + ((not (consp plist))) + (let ((key (car plist))) + (setf plist (cdr plist)) + (when (eq key slot-name) + (return (car plist))))))) -(defun initialize-internal-slot-gfs (slot-name &optional type) - (macrolet ((frob (type name-fun add-fun) - `(when (or (null type) (eq type ',type)) - (let* ((name (,name-fun slot-name)) - (gf (ensure-generic-function name)) - (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))) +(defun make-slot-table (class slots &optional bootstrap) + (let* ((n (+ (length slots) 2)) + (vector (make-array n :initial-element nil))) + (flet ((add-to-vector (name slot) + (declare (symbol name) + (optimize (sb-c::insert-array-bounds-checks 0))) + (let ((index (rem (sxhash name) n))) + (setf (svref vector index) + (list* name + (cons (when (or bootstrap + (and (standard-class-p class) + (slot-accessor-std-p slot 'all))) + (if bootstrap + (early-slot-definition-location slot) + (slot-definition-location slot))) + (the slot-info + (if bootstrap + (early-slot-definition-info slot) + (slot-definition-info slot)))) + (svref vector index)))))) + (if (eq 'complete **boot-state**) + (dolist (slot slots) + (add-to-vector (slot-definition-name slot) slot)) + (dolist (slot slots) + (add-to-vector (early-slot-definition-name slot) slot)))) + vector))