hi does anyone have experience using MOP to put callbacks on slot
modification. I want to do something like the following.
I'd like the callback method to be called whenever i set the
value of the slot to a value that is not eql to the current value.
(defclass myclass nil
(( slot1 :callback meth1)
( slot2 :callback meth1) ;; came cb as slot1
( slot3 :callback meth3))
(:metaclass mymetaclass)
)
(defmethod meth1 (( self myclass) s_slot)
...)
(defmethod meth3 (( self myclass) s_slot)
...)
(let (( obj (make-instance 'myclass)))
;; should set slot1 and then evaluate (meth1 obj 'slot1)
(setf (slot-value obj 'slot1) 1)
;; should do nothing because slot1 value is already 1
(setf (slot-value obj 'slot1) 1)
;; do not call callback on read operation.
(slot-value obj 'slot1)
;; should set slot2 and then evaluate (meth1 obj 'slot2)
(setf (slot-value obj 'slot2) 2)
;; should set slot3 and then evaluate (meth3 obj 'slot3)
(setf (slot-value obj 'slot3) 3)
.
.
.
)
If anyone has done something like this before, i'm interesrted
to know how you make the defclass understand the new keyword
e.g., :callback. Plus perhaps there are other gochas which
one needs to watch out for.
Jim Newton wrote:
> If anyone has done something like this before, i'm interesrted
> to know how you make the defclass understand the new keyword
> e.g., :callback. Plus perhaps there are other gochas which
> one needs to watch out for.
The way that seems to work best is this. First, of course, one has to
understand the respective subprotocols. Slots are represented as
so-called direct slot definitions on the one hand, and effective slot
definitions on the other hand. Direct slot definitions are those that
are textually mentioned in a defclass form, whereas effective slot
definitions are those that are, well, effective for the actual class -
i.e., they include all the inherited slots, and their properties are in
general combinations of the properties all the slots with the same names
across the class precedence list.
The slot options given for a slot in a defclass - for example, :initarg,
:initform, :accessor, and so on - are passed as initialization arguments
to initialize-instance called on the respective direct slot definition
metaobject. So the important step here is to sneak in one's own slot
definition class.
Here is how I add a :special option to special classes in my AspectL
package. I define a slot-definition-mixin class, like this:
(defclass special-class-slot-definition-mixin ()
((special-slot-p :accessor special-slot-p
:initarg :special
:initform nil)))
Then, you can define your own subclass of standard-direct-slot-definition:
(defclass special-class-direct-slot-definition
(special-class-slot-definition-mixin
standard-direct-slot-definition)
())
The direct-slot-definition-class allows you to tell the MOP that it
should use that class for your own classes. Here, I have previously
defined a special-class-mixin that allows me to create a subclass
special-class of standard-class:
(defmethod direct-slot-definition-class
((class special-class-mixin)
&key &allow-other-keys)
(find-class 'special-class-direct-slot-definition))
This function is passed the slot options as keyword arguments so that
you have a chance to be more specific what kind of direct slot
definition class you want. In general, you can just return your own and
handle everything there.
You do the same thing for special-class-effective-slot-definition and
the effective-slot-definition-class method specialized on
special-class-mixin.
As a last step, you need to tell the MOP how to combine the new slot
option from several direct slot definitions. You do this via
compute-effective-slot-definition. In my case, I just use the setting of
the most specific direct slot definition:
(defmethod compute-effective-slot-definition
((class special-class-mixin)
slot-name
direct-slot-definitions)
(declare (ignore slot-name))
(let ((effective-slotd (call-next-method)))
(setf (special-slot-p effective-slotd)
(special-slot-p (first direct-slot-definitions)))
effective-slotd))
One further detail: I have defined the accessor special-slot-p for my
special slots. Since in the rest of my code I sometimes have to deal
with plain standard slots, but don't want to add conditionals to
distinguish between them, I have added the following generic function
declaration:
(defgeneric special-slot-p (slotd)
(:documentation "Is the :special flag set for slotd?")
(:method ((slotd slot-definition)) nil))
And don't forget to define a method for validate-superclass! ;)
Apart from that, that's all you need to know for adding slot options.
The rest depends on the functionality you actually want add.
I hope this helps.
Pascal
--
Tyler: "How's that working out for you?"
Jack: "Great."
Tyler: "Keep it up, then."
On Tue, 13 Jul 2004 21:42:42 +0200, Jim Newton <·····@rdrop.com> wrote:
> hi does anyone have experience using MOP to put callbacks on slot
> modification. I want to do something like the following.
> I'd like the callback method to be called whenever i set the
> value of the slot to a value that is not eql to the current value.
>
> (defclass myclass nil
> (( slot1 :callback meth1)
> ( slot2 :callback meth1) ;; came cb as slot1
> ( slot3 :callback meth3))
>
> (:metaclass mymetaclass)
> )
>
> (defmethod meth1 (( self myclass) s_slot)
> ...)
>
> (defmethod meth3 (( self myclass) s_slot)
> ...)
>
>
> (let (( obj (make-instance 'myclass)))
> ;; should set slot1 and then evaluate (meth1 obj 'slot1)
> (setf (slot-value obj 'slot1) 1)
>
> ;; should do nothing because slot1 value is already 1
> (setf (slot-value obj 'slot1) 1)
>
> ;; do not call callback on read operation.
> (slot-value obj 'slot1)
>
> ;; should set slot2 and then evaluate (meth1 obj 'slot2)
> (setf (slot-value obj 'slot2) 2)
>
> ;; should set slot3 and then evaluate (meth3 obj 'slot3)
> (setf (slot-value obj 'slot3) 3)
>
> .
> .
> .
> )
>
> If anyone has done something like this before, i'm interesrted
> to know how you make the defclass understand the new keyword
> e.g., :callback. Plus perhaps there are other gochas which
> one needs to watch out for.
Below is my take at this. But you better listen to the MOP gurus, I've
never done any serious work with it.
Cheers,
Edi.
···@bird:/tmp$ cat foo.lisp
(in-package :cl-user)
(defun sans (plist &rest keys)
"Returns PLIST with keyword arguments from KEYS removed."
;; stolen from Usenet posting <················@naggum.no> by
;; Erik Naggum
(let ((sans ()))
(loop
(let ((tail (nth-value 2 (get-properties plist keys))))
;; this is how it ends
(unless tail
(return (nreconc sans plist)))
;; copy all the unmatched keys
(loop until (eq plist tail) do
(push (pop plist) sans)
(push (pop plist) sans))
;; skip the matched key
(setq plist (cddr plist))))))
(defclass mymetaclass (standard-class)
((callbacks :initform nil
:accessor callbacks)))
(defmethod pcl:validate-superclass ((super-class mymetaclass)
(class standard-class))
t)
(defmethod shared-initialize :around ((class mymetaclass) slot-names
&rest initargs)
(let ((direct-slots (getf initargs :direct-slots))
(initargs-copy (copy-list initargs)))
(remf initargs-copy :direct-slots)
(setf (getf initargs-copy :direct-slots)
(append (mapcar #'(lambda (direct-slot)
(sans direct-slot :callback))
direct-slots)))
(prog1
(apply #'call-next-method class slot-names initargs-copy)
(loop for direct-slot in direct-slots
for name = (getf direct-slot :name)
for callback = (getf direct-slot :callback)
when callback
do (setf (getf (callbacks class) name) callback)
else
do (remf (callbacks class) name)))))
(defmethod (setf pcl:slot-value-using-class) :around
(new-value (class mymetaclass) object slot)
(let* ((slot-name (pcl:slot-definition-name slot))
(slot-boundp-before (slot-boundp object slot-name))
(old-value (and slot-boundp-before
(slot-value object slot-name)))
(callback (getf (callbacks class) slot-name)))
(prog1
(call-next-method)
(when (and callback
(not (and slot-boundp-before
(eql new-value old-value))))
(funcall callback object slot)))))
···@bird:/tmp$ cat bar.lisp
(in-package :cl-user)
(defun meth1 (object slot)
(let ((slot-name (pcl:slot-definition-name slot)))
(format t "METH1: the value of slot ~A of object ~S is now ~A~%"
slot-name object (slot-value object slot-name))))
(defun meth3 (object slot)
(let ((slot-name (pcl:slot-definition-name slot)))
(format t "METH3: the value of slot ~A of object ~S is now ~A~%"
slot-name object (slot-value object slot-name))))
(defclass myclass ()
((slot1 :callback meth1)
(slot2 :callback meth1)
(slot3 :callback meth3)
(slot4))
(:metaclass mymetaclass))
(defparameter *a* (make-instance 'myclass))
(defun test (slot-name new-value)
(format t "Setting slot ~A to ~A~%"
slot-name new-value)
(setf (slot-value *a* slot-name) new-value))
(test 'slot1 42)
(test 'slot2 42)
(test 'slot3 42)
(test 'slot4 42)
(test 'slot1 42)
(test 'slot2 43)
(format t "Now redefining class MYCLASS~%")
(defclass myclass ()
((slot1)
(slot2 :callback meth3)
(slot3 :callback meth3)
(slot4))
(:metaclass mymetaclass))
(test 'slot1 44)
(test 'slot2 44)
(test 'slot3 44)
(test 'slot4 44)
(test 'slot2 44)
(test 'slot3 45)
···@bird:/tmp$ cmucl
; Loading #p"/home/edi/.cmucl-init".
CMU Common Lisp 19a-pre3, running on bird.agharta.de
With core: /usr/local/lib/cmucl/lib/lisp.core
Dumped on: Wed, 2004-06-30 19:13:25+02:00 on lorien
See <http://www.cons.org/cmucl/> for support information.
Loaded subsystems:
Python 1.1, target Intel x86
CLOS based on Gerd's PCL 2004/04/14 03:32:47
* (load "foo.lisp")
; Compiling LAMBDA (PCL::.PV-CELL. PCL::.NEXT-METHOD-CALL. SUPER-CLASS CLASS):
; Compiling Top-Level Form:
; Compiling LAMBDA (PCL::.PV-CELL. PCL::.NEXT-METHOD-CALL. CLASS SLOT-NAMES PCL::.REST-ARG.):
; Compiling Top-Level Form:
; Compiling LAMBDA (PCL::.PV-CELL. PCL::.NEXT-METHOD-CALL. NEW-VALUE CLASS OBJECT SLOT):
; Compiling Top-Level Form:
T
* (load "bar.lisp")
Setting slot SLOT1 to 42
METH1: the value of slot SLOT1 of object #<MYCLASS {582E1E4D}> is now 42
Setting slot SLOT2 to 42
METH1: the value of slot SLOT2 of object #<MYCLASS {582E1E4D}> is now 42
Setting slot SLOT3 to 42
METH3: the value of slot SLOT3 of object #<MYCLASS {582E1E4D}> is now 42
Setting slot SLOT4 to 42
Setting slot SLOT1 to 42
Setting slot SLOT2 to 43
METH1: the value of slot SLOT2 of object #<MYCLASS {582E1E4D}> is now 43
Now redefining class MYCLASS
Setting slot SLOT1 to 44
Setting slot SLOT2 to 44
METH3: the value of slot SLOT2 of object #<MYCLASS {582E1E4D}> is now 44
Setting slot SLOT3 to 44
METH3: the value of slot SLOT3 of object #<MYCLASS {582E1E4D}> is now 44
Setting slot SLOT4 to 44
Setting slot SLOT2 to 44
Setting slot SLOT3 to 45
METH3: the value of slot SLOT3 of object #<MYCLASS {582E1E4D}> is now 45
T
*
--
"Lisp doesn't look any deader than usual to me."
(David Thornley, reply to a question older than most languages)
Real email: (replace (subseq ·········@agharta.de" 5) "edi")
Jim Newton <·····@rdrop.com> writes:
> hi does anyone have experience using MOP to put callbacks on slot
> modification. I want to do something like the following.
> I'd like the callback method to be called whenever i set the
> value of the slot to a value that is not eql to the current value.
What about around/:AFTER methods on slot writers/accessors?
Paolo
--
Why Lisp? http://alu.cliki.net/RtL%20Highlight%20Film
Recommended Common Lisp libraries/tools (Google for info on each):
- ASDF/ASDF-INSTALL: system building/installation
- CL-PPCRE: regular expressions
- UFFI: Foreign Function Interface
Jim Newton wrote:
> hi does anyone have experience using MOP to put callbacks on slot
> modification. I want to do something like the following.
> I'd like the callback method to be called whenever i set the
> value of the slot to a value that is not eql to the current value.
What about the following, without getting into MOP and extra things?
(defclass foo ()
((s :accessor foo-s)))
(defmethod (setf foo-s) :before (v (the-foo foo))
(unless (eq v (slot-value the-foo 's))
(callback the-foo)))
You can do more things with :around. It is up to you.
--
Cheers
marco
>
> (defclass myclass nil
> (( slot1 :callback meth1)
> ( slot2 :callback meth1) ;; came cb as slot1
> ( slot3 :callback meth3))
>
> (:metaclass mymetaclass)
> )
>
> (defmethod meth1 (( self myclass) s_slot)
> ...)
>
> (defmethod meth3 (( self myclass) s_slot)
> ...)
>
>
> (let (( obj (make-instance 'myclass)))
> ;; should set slot1 and then evaluate (meth1 obj 'slot1)
> (setf (slot-value obj 'slot1) 1)
>
> ;; should do nothing because slot1 value is already 1
> (setf (slot-value obj 'slot1) 1)
>
> ;; do not call callback on read operation.
> (slot-value obj 'slot1)
>
> ;; should set slot2 and then evaluate (meth1 obj 'slot2)
> (setf (slot-value obj 'slot2) 2)
>
> ;; should set slot3 and then evaluate (meth3 obj 'slot3)
> (setf (slot-value obj 'slot3) 3)
>
> .
> .
> .
> )
>
> If anyone has done something like this before, i'm interesrted
> to know how you make the defclass understand the new keyword
> e.g., :callback. Plus perhaps there are other gochas which
> one needs to watch out for.
>
Jim Newton <·····@rdrop.com> writes:
> hi does anyone have experience using MOP to put callbacks on slot
> modification.
We have code that does this. Others have posted relevant examples.
If I had to reimplement our code, I would look into auto-generating
secondary accessors, as suggested by Marco. This is conceptually
simpler, though possibly inelegant depending on the need. It is also
likely to be more portable in practice than the MOP approach.
--
John M. Adams