Search code examples
lispcommon-lispclosmop

How to define a common lisp slot definition metaobject?


I would like to define a common lisp slot definition metaobject in order to allow for providing new options when writing the details of a slot on a class.

For example

(defclass test3 ()
  ((world :my-new-option T)))

Just like :initform could be provided, I want to be able to provide a new option for that slot. Furthermore, I would then like to be able to have a function that, given class, can then return the value of the provided option.

Example:

(my-new-option-value (find-class 'test3))
=> T

I tried defining it as a subclass of c2mop:standard-direct-slot-definition, but didn't really know where to go from there to use it.


Solution

  • Based on additional properties to slot definition by @RainerJoswig with some modifications so that it works in SBCL and probably in all Common Lisps that support c2mop.

    (defclass foo-meta-class (c2mop:standard-class) ())
    
    (defclass foo-standard-direct-slot-definition (c2mop:standard-direct-slot-definition)
      ((foo :initform nil :initarg :foo
            :accessor foo-slot-value
            )))
    
    (defclass foo-standard-effective-slot-definition (c2mop:standard-effective-slot-definition)
      ((foo :initform nil :initarg :foo
            :accessor foo-slot-value
            )))
    
    (defmethod c2mop:direct-slot-definition-class ((class foo-meta-class) &rest initargs)
      (find-class 'foo-standard-direct-slot-definition))
    
    (defmethod c2mop:effective-slot-definition-class ((class foo-meta-class) &rest initargs)
      (find-class 'foo-standard-effective-slot-definition))
    
    (defmethod c2mop:validate-superclass ((class foo-meta-class) (superclass c2mop:standard-class))
      t)
    
    (defclass foo ()
      ((a :initarg :a :foo :bar))
      (:metaclass foo-meta-class))
    
    
    (inspect (c2mop:class-direct-slots (find-class 'foo)))
    

    Now, given a slot, we can check the value of the :foo option like this:

    (foo-slot-value given-slot)
    

    So for example:

    (foo-slot-value (car (c2mop:class-direct-slots (find-class 'foo))))
    => :BAR