check-slot-writes.lisp

; adapted from https://groups.google.com/d/msg/comp.lang.lisp/TsmbsOK32DM/9Q7prvFV9YsJ , Pascal Costanza

;;;; checking CLOS slot writes at runtime for the correct type

;;; LispWorks

(defclass slot-writes-checking-class (standard-class)
  ())

(defmethod validate-superclass
           ((class slot-writes-checking-class)
            (superclass standard-class))
   t)

(defmethod (setf clos:slot-value-using-class) :before (new-value (class slot-writes-checking-class) object slot)
  (let ((slot-definition (find slot (class-slots class) :key #'slot-definition-name)))
    (assert (and slot-definition (typep new-value (slot-definition-type slot-definition )))
        ()
      "new value ~a is not of type ~a in object ~a slot ~a"
      new-value (slot-definition-type slot-definition) object slot)))

(defclass foo-class ()
  ((bar :initarg :bar :type list))
  (:metaclass slot-writes-checking-class)
  (:optimize-slot-access nil))


;;; SBCL


(defclass slot-writes-checking-class (standard-class)
  ())

(defmethod sb-mop:validate-superclass
           ((class slot-writes-checking-class)
            (superclass standard-class))
   t)

(defmethod (setf sb-mop:slot-value-using-class) :before (new-value (class slot-writes-checking-class) object slot)
  (assert (typep new-value (sb-mop:slot-definition-type slot))
      ()
    "new value ~a is not of type ~a in object ~a slot ~a"
    new-value (sb-mop:slot-definition-type slot) object slot))

(defclass foo-class ()
  ((bar :initarg :bar :type list))
  (:metaclass slot-writes-checking-class))


#|
; example

(setf (slot-value (make-instance 'foo-class :bar 42) 'bar) 10)
|#