CODEWITHSUNDEEP
lispcommon-lispclosmop
leinad
leinad

Reputation: 420

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.

Upvotes: 1

Views: 79

Answers (1)

leinad
leinad

Reputation: 420

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

Upvotes: 3

Related Questions