`(let ,bindings ,form)
form)))
-(defconstant *optimize-slot-boundp* nil)
+;;; 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)
'accessor-slot-boundp))
(let* ((slot-name (eval slot-name))
(sym (slot-boundp-symbol slot-name)))
- (if (not *optimize-slot-boundp*)
+ (if (not +optimize-slot-boundp+)
`(slot-boundp-normal ,object ',slot-name)
`(asv-funcall ,sym ,slot-name boundp ,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*)))))
+ (not (eq (funcall reader object) +slot-unbound+)))))
(declare (type function reader))
fun))
(set-function-name
(etypecase index
(fixnum (if fsc-p
- #'(lambda (instance)
- (let ((value (%instance-ref (fsc-instance-slots instance) index)))
- (if (eq value *slot-unbound*)
- (slot-unbound (class-of instance) instance slot-name)
- value)))
- #'(lambda (instance)
- (let ((value (%instance-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)))))
+ (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)))))
`(reader ,slot-name)))
(defun make-optimized-std-writer-method-function (fsc-p slot-name index)
(set-function-name
(etypecase index
(fixnum (if fsc-p
- #'(lambda (nv instance)
- (setf (%instance-ref (fsc-instance-slots instance) index) nv))
- #'(lambda (nv instance)
- (setf (%instance-ref (std-instance-slots instance) index) nv))))
- (cons #'(lambda (nv instance)
- (declare (ignore instance))
- (setf (cdr index) nv))))
+ (lambda (nv instance)
+ (setf (clos-slots-ref (fsc-instance-slots instance) index)
+ nv))
+ (lambda (nv instance)
+ (setf (clos-slots-ref (std-instance-slots instance) index)
+ nv))))
+ (cons (lambda (nv instance)
+ (declare (ignore instance))
+ (setf (cdr index) nv))))
`(writer ,slot-name)))
(defun make-optimized-std-boundp-method-function (fsc-p slot-name index)
(etypecase index
(fixnum (if fsc-p
#'(lambda (instance)
- (not (eq (%instance-ref (fsc-instance-slots instance)
+ (not (eq (clos-slots-ref (fsc-instance-slots instance)
index)
- *slot-unbound*)))
+ +slot-unbound+)))
#'(lambda (instance)
- (not (eq (%instance-ref (std-instance-slots instance)
+ (not (eq (clos-slots-ref (std-instance-slots instance)
index)
- *slot-unbound*)))))
+ +slot-unbound+)))))
(cons #'(lambda (instance)
(declare (ignore instance))
- (not (eq (cdr index) *slot-unbound*)))))
+ (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))))
+ (lambda (class object slotd)
+ (let ((value (funcall function object)))
+ (if (eq value +slot-unbound+)
+ (slot-unbound class object (slot-definition-name slotd))
+ value))))
(defun make-optimized-structure-setf-slot-value-using-class-method-function (function)
(declare (type function function))
(declare (type function function))
#'(lambda (class object slotd)
(declare (ignore class slotd))
- (not (eq (funcall function object) *slot-unbound*))))
+ (not (eq (funcall function object) +slot-unbound+))))
-(defun get-optimized-std-slot-value-using-class-method-function (class slotd name)
+(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
(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 (%instance-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 (%instance-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))
- (let ((value (cdr index)))
- (if (eq value *slot-unbound*)
- (slot-unbound class instance slot-name)
- value))))))
+ (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)
+ (declare (ignore slotd))
+ (let ((value (cdr index)))
+ (if (eq value +slot-unbound+)
+ (slot-unbound class instance slot-name)
+ value))))))
(defun make-optimized-std-setf-slot-value-using-class-method-function
(fsc-p slot-name index)
(declare (ignore slot-name))
(etypecase index
(fixnum (if fsc-p
- #'(lambda (nv class instance slotd)
- (declare (ignore class slotd))
- (setf (%instance-ref (fsc-instance-slots instance) index) nv))
- #'(lambda (nv class instance slotd)
- (declare (ignore class slotd))
- (setf (%instance-ref (std-instance-slots instance) index) nv))))
- (cons #'(lambda (nv class instance slotd)
- (declare (ignore class instance slotd))
- (setf (cdr index) nv)))))
+ (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)))))
(defun make-optimized-std-slot-boundp-using-class-method-function
(fsc-p slot-name index)
(declare (ignore slot-name))
(etypecase index
(fixnum (if fsc-p
- #'(lambda (class instance slotd)
- (declare (ignore class slotd))
- (not (eq (%instance-ref (fsc-instance-slots instance)
- index)
- *slot-unbound* )))
- #'(lambda (class instance slotd)
- (declare (ignore class slotd))
- (not (eq (%instance-ref (std-instance-slots instance)
- index)
- *slot-unbound* )))))
- (cons #'(lambda (class instance slotd)
- (declare (ignore class instance slotd))
- (not (eq (cdr index) *slot-unbound*))))))
+ (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+))))))
(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
(case name
- (reader #'(lambda (instance) (emf-funcall sdfun class instance slotd)))
- (writer #'(lambda (nv instance) (emf-funcall sdfun nv class instance slotd)))
- (boundp #'(lambda (instance) (emf-funcall sdfun class instance slotd))))
+ (reader (lambda (instance)
+ (emf-funcall sdfun class instance slotd)))
+ (writer (lambda (nv instance)
+ (emf-funcall sdfun nv class instance slotd)))
+ (boundp (lambda (instance)
+ (emf-funcall sdfun class instance slotd))))
`(,name ,(class-name class) ,(slot-definition-name slotd)))))
(defun make-internal-reader-method-function (class-name slot-name)
(if wrapper
(let* ((class (wrapper-class* wrapper))
(index (or (instance-slot-index wrapper slot-name)
- (assq slot-name (wrapper-class-slots wrapper)))))
+ (assq slot-name
+ (wrapper-class-slots wrapper)))))
(typecase index
(fixnum
- (let ((value (%instance-ref (get-slots instance) index)))
- (if (eq value *slot-unbound*)
- (slot-unbound (class-of instance) instance slot-name)
+ (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)
+ (if (eq value +slot-unbound+)
+ (slot-unbound (class-of instance)
+ instance
+ slot-name)
value)))
(t
- (error "The wrapper for class ~S does not have the slot ~S"
+ (error "~@<The wrapper for class ~S does not have ~
+ the slot ~S~@:>"
class slot-name))))
(slot-value instance slot-name)))))))
\f
(gf (ensure-generic-function name)))
(unless (generic-function-methods gf)
(add-writer-method *the-class-slot-object* gf slot-name))))
- (when (and *optimize-slot-boundp*
+ (when (and +optimize-slot-boundp+
(or (null type) (eq type 'boundp)))
(let* ((name (slot-boundp-symbol slot-name))
(gf (ensure-generic-function name)))
projects / sbcl.git / blobdiff