[pro] Initialization of shared slots

[Pascal Costanza]

On 10 Jan 2011, at 19:58, Samium Gromoff wrote:

> On Mon, 10 Jan 2011 18:33:17 GMT, Martin Simmons <martin at lispworks.com> wrote:
>> Another reason why this won't work is that you only have one slot -- the same
>> value is shared between every subclass of vcs-type-mixin.  Adding a separate
>> slot to each subclass is a pain.
> 
> Oh, right, my fault here.  I remember elaborate macros, from my other
> attempts to use shared slots for this purpose, which solved exactly this
> problem of excess manual specification of "please make the sublattice
> rooted at this class a separate subdomain for this shared slot".

You don't need shared slots, but class properties. ;) Here is a sketch (this assumes Closer to MOP is present, but should actually work without it in most CL implementations - warning, this is only lightly tested):

(in-package :closer-common-lisp-user)

(defclass property-class (standard-class)
  ((properties :initform '() :initarg :properties)))

(defmethod validate-superclass
           ((class property-class)
            (superclass standard-class))
  t)

(defgeneric class-getf (class indicator &optional default)
  (:method ((class symbol) indicator &optional default)
   (class-getf (find-class class) indicator default))
  (:method ((class property-class) indicator &optional default)
   (ensure-finalized class)
   (loop for class in (class-precedence-list class) do
         (multiple-value-bind
             (indicator value tail)
             (get-properties 
              (slot-value class 'properties)
              (list indicator))
           (when (or indicator value tail)
             (return value)))
         finally (return default))))

(defgeneric (setf class-getf) (new-value class indicater &optional default)
  (:method (new-value (class symbol) indicator &optional default)
   (declare (ignore default))
   (setf (class-getf (find-class class) indicator)
         new-value))
  (:method (new-value (class property-class) indicator &optional default)
   (declare (ignore default))
   (setf (getf (slot-value class 'properties) indicator)
         new-value)))

(defclass test () ()
  (:metaclass property-class)
  (:properties :a 1 :b 2))

(defclass test2 (test) ()
  (:metaclass property-class)
  (:properties :a 3 :c 4))

C2CL-USER 21 > (class-getf 'test :a)
1

C2CL-USER 22 > (class-getf 'test :b)
2

C2CL-USER 23 > (class-getf 'test2 :a)
3

C2CL-USER 24 > (class-getf 'test2 :b)
2

C2CL-USER 27 > (class-getf 'test2 :c)
4

C2CL-USER 28 > (setf (class-getf 'test2 :b) 42)
42

C2CL-USER 29 > (class-getf 'test2 :b)
42

C2CL-USER 30 > (class-getf 'test :b)
2

This can probably be improved. I especially don't like the call to ensure-finalized - you could probably avoid that by first looking at the class itself before requesting the class precedence list, or so. I could have used alists, or 'real' slots, but plists are very convenient here because they mesh well with class metaobject initialization, and they don't require the heavy lifting of defining new metaclasses for new slots. One can imagine adding new methods on slot-value-using-class and friends that access class-getf behind the scenes, so you could actually access the class properties from plain class instances. Etc., etc. - you get the idea...


Best,
Pascal

-- 
Pascal Costanza, mailto:pc at p-cos.net, http://p-cos.net
Vrije Universiteit Brussel
Software Languages Lab
Pleinlaan 2, B-1050 Brussel, Belgium