X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fslots-boot.lisp;h=dc7b804b294a492e513c314fa0e931a0a2591106;hb=760349abe9068fe4e5e3c03013f3533b64602a93;hp=998b02bc3dd8b4d90b5abdcb666a33702ea351f4;hpb=26b8ddda97fcfa2e2c0eae3bd2fdb19717c5fa40;p=sbcl.git diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index 998b02b..dc7b804 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -23,54 +23,86 @@ (in-package "SB-PCL") -(defmacro slot-symbol (slot-name type) - `(if (and (symbolp ,slot-name) (symbol-package ,slot-name)) - (or (get ,slot-name ',(ecase type - (reader 'reader-symbol) - (writer 'writer-symbol) - (boundp 'boundp-symbol))) - (intern (format nil "~A ~A slot ~A" - (package-name (symbol-package ,slot-name)) - (symbol-name ,slot-name) - ,(symbol-name type)) - *slot-accessor-name-package*)) - (progn - (error "Non-symbol and non-interned symbol slot name accessors~ - are not yet implemented.") - ;;(make-symbol (format nil "~A ~A" ,slot-name ,type)) - ))) - -(defun slot-reader-symbol (slot-name) - (slot-symbol slot-name reader)) - -(defun slot-writer-symbol (slot-name) - (slot-symbol slot-name writer)) - -(defun slot-boundp-symbol (slot-name) - (slot-symbol slot-name boundp)) - -(defmacro asv-funcall (sym slot-name type &rest args) - (declare (ignore type)) - `(if (fboundp ',sym) - (,sym ,@args) - (no-slot ',sym ',slot-name))) - -(defun no-slot (sym slot-name) - (error "No class has a slot named ~S (~S has no function binding)." - slot-name sym)) +(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) + (values + (slot-missing (class-of obj) obj slot-name + 'slot-value))))) + (slot-boundp + (make-method-function + (lambda (obj) + (not (not + (slot-missing (class-of obj) obj slot-name + 'slot-boundp)))))) + (setf + (make-method-function + (lambda (val obj) + (slot-missing (class-of obj) obj slot-name + 'setf val) + val))))))) + (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 + :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)) + (writer (add-slot-missing-method gf slot-name 'setf))) + (setf (plist-value gf 'slot-missing-method) t)) + t))) (defmacro accessor-slot-value (object slot-name) - (unless (constantp slot-name) - (error "~S requires its slot-name argument to be a constant" - 'accessor-slot-value)) + (aver (constantp slot-name)) (let* ((slot-name (eval slot-name)) - (sym (slot-reader-symbol slot-name))) - `(asv-funcall ,sym ,slot-name reader ,object))) + (reader-name (slot-reader-name slot-name))) + `(let ((.ignore. (load-time-value + (ensure-accessor 'reader ',reader-name ',slot-name)))) + (declare (ignore .ignore.)) + (truly-the (values t &optional) + (funcall #',reader-name ,object))))) (defmacro accessor-set-slot-value (object slot-name new-value &environment env) - (unless (constantp slot-name) - (error "~S requires its slot-name argument to be a constant" - 'accessor-set-slot-value)) + (aver (constantp slot-name)) (setq object (macroexpand object env)) (setq slot-name (macroexpand slot-name env)) (let* ((slot-name (eval slot-name)) @@ -78,236 +110,335 @@ (let ((object-var (gensym))) (prog1 `((,object-var ,object)) (setq object object-var))))) - (sym (slot-writer-symbol slot-name)) - (form `(asv-funcall ,sym ,slot-name writer ,new-value ,object))) + (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.)) + (funcall #',writer-name .new-value. ,object) + .new-value.))) (if bindings `(let ,bindings ,form) form))) -;;; FIXME: Why is this defined in two different places? And what does -;;; it mean anyway? And can we just eliminate it completely (replacing -;;; it with NIL, then hand-eliminating any resulting dead code)? -(defconstant +optimize-slot-boundp+ nil) - (defmacro accessor-slot-boundp (object slot-name) - (unless (constantp slot-name) - (error "~S requires its slot-name argument to be a constant" - 'accessor-slot-boundp)) + (aver (constantp slot-name)) (let* ((slot-name (eval slot-name)) - (sym (slot-boundp-symbol slot-name))) - (if (not +optimize-slot-boundp+) - `(slot-boundp-normal ,object ',slot-name) - `(asv-funcall ,sym ,slot-name boundp ,object)))) - -(defun structure-slot-boundp (object) - (declare (ignore object)) - t) + (boundp-name (slot-boundp-name slot-name))) + `(let ((.ignore. (load-time-value + (ensure-accessor 'boundp ',boundp-name ',slot-name)))) + (declare (ignore .ignore.)) + (funcall #',boundp-name ,object)))) (defun make-structure-slot-boundp-function (slotd) - (let* ((reader (slot-definition-internal-reader-function slotd)) - (fun #'(lambda (object) - (not (eq (funcall reader object) +slot-unbound+))))) - (declare (type function reader)) - fun)) + (declare (ignore slotd)) + (lambda (object) + (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) + (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)) + (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-function-name - (etypecase index - (fixnum (if fsc-p - (lambda (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) - (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) - (let ((value (cdr index))) - (if (eq value +slot-unbound+) - (slot-unbound (class-of instance) instance slot-name) - value))))) + (set-fun-name + (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-function-name - (etypecase index + (set-fun-name + (etypecase location (fixnum (if fsc-p (lambda (nv instance) - (setf (clos-slots-ref (fsc-instance-slots instance) index) + (check-obsolete-instance instance) + (setf (clos-slots-ref (fsc-instance-slots instance) + location) nv)) (lambda (nv instance) - (setf (clos-slots-ref (std-instance-slots instance) index) + (check-obsolete-instance instance) + (setf (clos-slots-ref (std-instance-slots instance) + location) nv)))) - (cons (lambda (nv instance) - (declare (ignore 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-function-name - (etypecase index + (set-fun-name + (etypecase location (fixnum (if fsc-p - #'(lambda (instance) - (not (eq (clos-slots-ref (fsc-instance-slots instance) - index) - +slot-unbound+))) - #'(lambda (instance) - (not (eq (clos-slots-ref (std-instance-slots instance) - index) - +slot-unbound+))))) - (cons #'(lambda (instance) - (declare (ignore instance)) - (not (eq (cdr 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 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) - (let ((value (funcall function object))) - (if (eq value +slot-unbound+) - (slot-unbound class object (slot-definition-name slotd)) - value)))) + (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)) - (funcall function nv object))) + (lambda (nv class object slotd) + (declare (ignore class slotd)) + (funcall function nv object))) -(defun make-optimized-structure-slot-boundp-using-class-method-function (function) - (declare (type function function)) - #'(lambda (class object slotd) - (declare (ignore class slotd)) - (not (eq (funcall function object) +slot-unbound+)))) +(defun make-optimized-structure-slot-boundp-using-class-method-function () + (lambda (class object slotd) + (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 - (slot-definition-internal-writer-function slotd)))) - (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)))) + (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)) - (unless (fsc-instance-p instance) (error "not fsc")) - (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)) - (unless (std-instance-p instance) (error "not std")) - (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) + (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)) - (let ((value (cdr index))) + (check-obsolete-instance instance) + (let ((value (cdr location))) (if (eq value +slot-unbound+) - (slot-unbound class instance slot-name) - value)))))) + (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)) - (setf (clos-slots-ref (fsc-instance-slots instance) index) - nv)) - (lambda (nv class instance slotd) - (declare (ignore class slotd)) - (setf (clos-slots-ref (std-instance-slots instance) index) - nv)))) - (cons (lambda (nv class instance slotd) - (declare (ignore class instance slotd)) - (setf (cdr index) nv))))) + (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 (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)) - (not (eq (clos-slots-ref (fsc-instance-slots instance) index) - +slot-unbound+))) - (lambda (class instance slotd) - (declare (ignore class slotd)) - (not (eq (clos-slots-ref (std-instance-slots instance) index) - +slot-unbound+))))) - (cons (lambda (class instance slotd) - (declare (ignore class instance slotd)) - (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))) - (set-function-name + (set-fun-name (case name (reader (lambda (instance) (emf-funcall sdfun class instance slotd))) @@ -318,7 +449,7 @@ `(,name ,(class-name class) ,(slot-definition-name slotd))))) (defun make-internal-reader-method-function (class-name slot-name) - (list* ':method-spec `(internal-reader-method ,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))) @@ -332,16 +463,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 "~@