X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fslots-boot.lisp;h=273805b18a62b64af1c28ddbd8968c0f1d865f21;hb=e47ffa8855d4139f88f5982fe4b82a05c3498ed3;hp=bad2c3ae08c7c224fc504fff9e843c74bf8e7da9;hpb=ed7ba4dad8a79726fdfeba5aa12e276ea852c540;p=sbcl.git diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index bad2c3a..273805b 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -23,32 +23,6 @@ (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) @@ -91,16 +65,8 @@ (let ((slot-name (eval slot-name))) `(slot-boundp-normal ,object ',slot-name))) -(defun structure-slot-boundp (object) - (declare (ignore object)) - t) - (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)) + (lambda (object) (declare (ignore object)) t)) (defun get-optimized-std-accessor-method-function (class slotd name) (if (structure-class-p class) @@ -133,18 +99,21 @@ (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) @@ -157,13 +126,15 @@ (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) - (declare (ignore instance)) + (check-obsolete-instance instance) (setf (cdr index) nv)))) `(writer ,slot-name))) @@ -173,25 +144,25 @@ (etypecase index (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+))))) (cons (lambda (instance) - (declare (ignore instance)) + (check-obsolete-instance instance) (not (eq (cdr index) +slot-unbound+))))) `(boundp ,slot-name))) (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) (declare (type function function)) @@ -199,11 +170,10 @@ (declare (ignore class slotd)) (funcall function nv object))) -(defun make-optimized-structure-slot-boundp-using-class-method-function (function) - (declare (type function function)) +(defun make-optimized-structure-slot-boundp-using-class-method-function () (lambda (class object slotd) - (declare (ignore class slotd)) - (not (eq (funcall function object) +slot-unbound+)))) + (declare (ignore class object slotd)) + t)) (defun get-optimized-std-slot-value-using-class-method-function (class slotd @@ -214,8 +184,7 @@ (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)))) + (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)))) @@ -239,7 +208,7 @@ (fixnum (if fsc-p (lambda (class instance slotd) (declare (ignore slotd)) - (unless (fsc-instance-p instance) (error "not fsc")) + (check-obsolete-instance instance) (let ((value (clos-slots-ref (fsc-instance-slots instance) index))) (if (eq value +slot-unbound+) @@ -247,7 +216,7 @@ value))) (lambda (class instance slotd) (declare (ignore slotd)) - (unless (std-instance-p instance) (error "not std")) + (check-obsolete-instance instance) (let ((value (clos-slots-ref (std-instance-slots instance) index))) (if (eq value +slot-unbound+) @@ -255,6 +224,7 @@ 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) @@ -268,14 +238,17 @@ (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 instance slotd)) + (declare (ignore class slotd)) + (check-obsolete-instance instance) (setf (cdr index) nv))))) (defun make-optimized-std-slot-boundp-using-class-method-function @@ -286,14 +259,17 @@ (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 instance slotd)) + (declare (ignore class slotd)) + (check-obsolete-instance instance) (not (eq (cdr index) +slot-unbound+)))))) (defun get-accessor-from-svuc-method-function (class slotd sdfun name) @@ -310,7 +286,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))) @@ -352,10 +328,10 @@ (instance-read-internal .pv. instance-slots 1 (slot-value instance slot-name)))))))) - (setf (getf (getf initargs ':plist) ':slot-name-lists) + (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) + (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol) + (list* :method-spec `(reader-method ,class-name ,slot-name) initargs))) (defun make-std-writer-method-function (class-name slot-name) @@ -369,10 +345,10 @@ (instance-write-internal .pv. instance-slots 1 nv (setf (slot-value instance slot-name) nv)))))))) - (setf (getf (getf initargs ':plist) ':slot-name-lists) + (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) + (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol) + (list* :method-spec `(writer-method ,class-name ,slot-name) initargs))) (defun make-std-boundp-method-function (class-name slot-name) @@ -386,10 +362,10 @@ (instance-boundp-internal .pv. instance-slots 1 (slot-boundp instance slot-name)))))))) - (setf (getf (getf initargs ':plist) ':slot-name-lists) + (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) + (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol) + (list* :method-spec `(boundp-method ,class-name ,slot-name) initargs))) (defun initialize-internal-slot-gfs (slot-name &optional type)