defclass-mop-question.lisp

(ql:quickload :closer-mop)

;;; As an example of what I'm trying to do, let's create a metaclass that will
;;; allow you to attach functions to slots and call a `tick` function on the
;;; object to tick all of the slots.  This might be useful for updating objects
;;; in a video game loop or something similar.  Example:
;;;
;;; (defclass animal ()
;;;   ((age :initform 0 :accessor age :tick 1+)
;;;    (guts :initform nil :accessor guts :tick butlast))
;;;   (:metaclass ticking-class))
;;;
;;; (defmethod print-object ((o animal) s)
;;;   (print-unreadable-object (o s :type t)
;;;     (format s "age ~S guts ~:S" (age o) (guts o))))
;;;
;;; (defparameter *bob* (make-instance 'animal))
;;;
;;; (push 'cheese (guts *bob*))
;;; (push 'spaghetti (guts *bob*))
;;; (push 'cat-food (guts *bob*))
;;;
;;; (print *bob*)
;;; ; => #<ANIMAL age 0 guts (CAT-FOOD SPAGHETTI CHEESE)>
;;;
;;; (tick *bob*)
;;; (print *bob*)
;;; ; => #<ANIMAL age 1 guts (CAT-FOOD SPAGHETTI)>
;;;
;;; (tick *bob*)
;;; (print *bob*)
;;; ; => #<ANIMAL age 2 guts (CAT-FOOD)>

;;;; Metaclass ----------------------------------------------------------------
;;; Define the metaclass.

(defclass ticking-class (standard-class) ())

(defmethod c2mop:validate-superclass ((class ticking-class) (superclass standard-class))
  t)


;;;; Slot Classes -------------------------------------------------------------
;;; Define the slot classes and some helper functions.

(defclass ticking-direct-slot-definition (c2mop:standard-direct-slot-definition)
  ((tick :initarg :tick)))

(defclass ticking-effective-slot-definition (c2mop:standard-effective-slot-definition)
  ((tick :initarg :tick)))

(defun ticking-direct-slot-p (direct-slot)
  (typep direct-slot 'ticking-direct-slot-definition))

(defun ticking-effective-slot-p (direct-slot)
  (typep direct-slot 'ticking-effective-slot-definition))


;;;; MOP ----------------------------------------------------------------------
;;; Now we need to hook everything up through the MOP.

(defmethod c2mop:direct-slot-definition-class ((class ticking-class) &rest initargs)
  (if (getf initargs :tick)
    (find-class 'ticking-direct-slot-definition)
    (call-next-method)))

(defvar *effective-slot-definition-class* nil)

(defmethod c2mop:effective-slot-definition-class ((class ticking-class) &rest initargs)
  (declare (ignore initargs))
  ;; I'm not sure why we need to use this hack here, but for some reason
  ;; initargs doesn't contain the slot options like :tick here like it does in
  ;; direct-slot-definition-class.  So we need another way to know which class
  ;; to use here.
  (or *effective-slot-definition-class* (call-next-method)))

(defmethod c2mop:compute-effective-slot-definition ((class ticking-class) name direct-slots)
  (if (not (some #'ticking-direct-slot-p direct-slots))
    (call-next-method)
    (let* ((*effective-slot-definition-class* (find-class 'ticking-effective-slot-definition))
           (eslot (call-next-method))
           (dslot (find-if #'ticking-direct-slot-p direct-slots)))
      (setf (slot-value eslot 'tick) (slot-value dslot 'tick))
      eslot)))


;;;; Tick Function ------------------------------------------------------------
;;; And now the tick function, while finds all the tickable slots and updates them.

(defun tick (object)
  (let ((class (class-of object)))
    (assert (typep class 'ticking-class))
    (map nil (lambda (slot &aux (name (c2mop:slot-definition-name slot)))
               (setf (slot-value object name)
                     (funcall (slot-value slot 'tick)
                              (slot-value object name))))
         (remove-if-not #'ticking-effective-slot-p (c2mop:class-slots class)))))


;;;; Basic Example ------------------------------------------------------------
;;; Now our basic example works.

(defclass animal ()
  ((age :initform 0 :accessor age :tick 1+)
   (guts :initform nil :accessor guts :tick butlast))
  (:metaclass ticking-class))

(defmethod print-object ((o animal) s)
  (print-unreadable-object (o s :type t)
    (format s "age ~S guts ~:S" (age o) (guts o))))

(defparameter *bob* (make-instance 'animal))

(push 'cheese (guts *bob*))
(push 'spaghetti (guts *bob*))
(push 'cat-food (guts *bob*))

(print *bob*)
; => #<ANIMAL age 0 guts (CAT-FOOD SPAGHETTI CHEESE)>

(tick *bob*)
(print *bob*)
; => #<ANIMAL age 1 guts (CAT-FOOD SPAGHETTI)>

(tick *bob*)
(print *bob*)
; => #<ANIMAL age 2 guts (CAT-FOOD)>

;;;; Next Example -------------------------------------------------------------
;;; However, when defclass parses the slot definitions, it doesn't do any kind
;;; of evaluation on the slot arguments.  So our :tick 1+ just passes the symbol
;;; 1+ along.  For our basic example this was fine, because 1+ names a function,
;;; so funcalling it is fine.  But something like this will not work.

(defclass foo ()
  ((contents :initform nil
             :accessor contents
             :tick (lambda (list) (remove nil list)))) ; broken
  (:metaclass ticking-class))

(defmethod print-object ((o foo) s)
  (print-unreadable-object (o s :type t)
    (format s "contents ~:S" (contents o))))

(defparameter *foo* (make-instance 'foo))

(print *foo*)
; => #<FOO contents ()>

(setf (contents *foo*) '(1 nil 2))

(print *foo*)
; => #<FOO contents (1 NIL 2)> 

(tick *foo*)
; =>
; The value
;   (LAMBDA (LIST) (REMOVE NIL LIST))
; is not of type
;   (OR FUNCTION SYMBOL)
;    [Condition of type TYPE-ERROR]

;; defclass didn't evaluate the lambda form, it just passed the list (lambda
;; ...) along, and you can't funcall a list.

;;;; Fixing with Eval ---------------------------------------------------------
;;; We can fix this particular example by evaluating the :tick value before
;;; storing it.

(defmethod c2mop:compute-effective-slot-definition ((class ticking-class) name direct-slots)
  (if (not (some #'ticking-direct-slot-p direct-slots))
    (call-next-method)
    (let* ((*effective-slot-definition-class* (find-class 'ticking-effective-slot-definition))
           (eslot (call-next-method))
           (dslot (find-if #'ticking-direct-slot-p direct-slots)))
      (setf (slot-value eslot 'tick)
            (eval (slot-value dslot 'tick))) ;; NEW: evaluate the tick form
      eslot)))

;; Now we need to quote our symbols, but this is reasonable.

(defclass animal ()
  ((age :initform 0 :accessor age :tick '1+) ;; need to quote the symbols now
   (guts :initform nil :accessor guts :tick 'butlast))
  (:metaclass ticking-class))

(defparameter *bob* (make-instance 'animal))
(tick *bob*)
(print *bob*)
; => #<ANIMAL age 1 guts ()>

;; And now the lambda works fine too.
(defclass foo ()
  ((contents :initform nil :accessor contents :tick (lambda (list) (remove nil list))))
  (:metaclass ticking-class))

(defparameter *foo* (make-instance 'foo))
(setf (contents *foo*) '(1 nil 2))
(tick *foo*)
(print *foo*)
; => #<FOO contents (1 2)>

;;;; Broken Example -----------------------------------------------------------
;;; We still haven't fully fixed the problem though, because eval evaluates the
;;; form in the null lexical environment.  So if you try to e.g. wrap a flet
;;; around the defclass, that still won't work.

(flet ((sanitize (list)
         (remove nil list)))
  (defclass bar ()
    ((contents :initform nil :accessor contents :tick #'sanitize)) ;; Broken, eval'ed in null lexical environment
    (:metaclass ticking-class)))
; =>
; The function COMMON-LISP-USER::SANITIZE is undefined.
;    [Condition of type UNDEFINED-FUNCTION]

;; I have not been able to figure out how to make this work.  Is there something
;; I'm missing, or is this simply not possible with defclass and the MOP?

I have run into this issue in the past. It is an omission in the MOP standard afaict. The Clossette implementation in the AMOP book has canonicalize-slot-option for this purpose but it didn't make it into the standard. Lispworks has an extension that handles this case. process-a-slot-option. SBCL on the other hand decides to treat the any non-standard option as a literal. A workaround would be to provide your own defclass* macro that processes the options you want.

http://www.lispworks.com/documentation/lw60/LW/html/lw-529.htm
https://github.com/sbcl/sbcl/blob/5f9d19d4aa14bf7a79af90b1f51714267cb5edc8/src/pcl/defclass.lisp#L254

Okay, that's what I figured. I'll probably go with the eval version and just accept that it won't work with lexical stuff. Thanks.