From: Alex Mizrahi
Subject: meta
Date:
Message-ID: <bm4pq2$ivmnp$1@ID-177567.news.uni-berlin.de>
Hello, All!
i'm trying to do some metaclass stuff(just as an exercise) - i want slots to
keep track when they are modified via accessor.
i've managed to create some code, but it looks too hacky.. maybe it can be
improved?
(defclass my-metaclass (standard-class)
())
(defmethod initialize-instance :around ((class my-metaclass) &rest all-keys)
(let ((slots (getf all-keys :direct-slots))
(new-slot-defs nil)
(affected-slots nil)
(my-keys (copy-list all-keys)))
(dolist (slot slots)
(when (getf slot :writers)
(let* ((old-sym (getf slot :name))
(old-name (symbol-name old-sym ))
(mod-sym (intern (concatenate 'string old-name
"-MODIFIED"))))
(push (list (car (getf slot :writers)) old-sym mod-sym)
affected-slots)
(push `(:NAME ,mod-sym :READERS (,mod-sym) :INITFORM NIL
:INITFUNCTION ,(constantly nil) )
new-slot-defs))))
(nconc new-slot-defs slots)
(setf (getf my-keys :direct-slots) new-slot-defs)
(apply #'call-next-method (cons class my-keys))
(setf (find-class (getf all-keys :name)) class)
(dolist (slot-def affected-slots)
(eval `(defmethod ,(first slot-def) ((new-val t) (object ,(getf
all-keys :name)))
(setf (slot-value object ',(third slot-def)) t)
(setf (slot-value object ',(second slot-def)) new-val)))
)))
and for testing:
(defclass my-udo ()
((udof :initarg :udof
:initform nil
:accessor udof))
(:metaclass my-metaclass))
(setq lamo1 (make-instance 'my-udo :udof 33))
(udof-modified lamo1) => NIL
(udof lamo1) => 33
(setf (udof lamo1) 55) => 55
(udof-modified lamo1) => T
so it appears to work on allegro, lispworks and corman..
so, is (mod-sym (intern (concatenate 'string old-name "-MODIFIED"))) ok?
can (eval `(defmethod part be done w/o eval and `?
can i avoid doing (setf (find-class (getf all-keys :name)) class)? it's
needed to pass class name to defmethod..
With best regards, Alex Mizrahi.