[Openmcl-devel] [off-topic] Adding a slot to a class using the MOP

[Raymond Wiker]

On Apr 22, 2013, at 19:32 , Ron Garret <ron at flownet.com> wrote:
> Apologies for the non-CCL-related question, but c.l.l. is slow today and I'm really stuck on this.
> 
> I need to dynamically add a slot to a class using the MOP.  There doesn't seem to be a standard add-slot method, so I figure I need to use something like ensure-class.  To do that, I need to reconstruct the argument to :direct-slots from the existing class definition so I can add a slot without disturbing the existing slots.  Before I went down this rabbit hole I thought I'd ask: is there a better/easier way to do this?  Surely I'm not the first person to want to do this.
> 
> Many thanks,
> rg
> 

I did something like the following - but I think I haven't tested it sufficiently to make any guarantees that it works. Requires closer-mop, as a cursory inspection should show :-)



(defclass on-demand-base ()
  ())

(defun slot-definition->list (slot-definition)
  (list :name (closer-mop:slot-definition-name slot-definition)
	:readers (closer-mop:slot-definition-readers slot-definition)
	:writers (closer-mop:slot-definition-writers slot-definition)
	:initargs (closer-mop:slot-definition-initargs slot-definition)
	:initform (closer-mop:slot-definition-initform slot-definition)
	:allocation (closer-mop:slot-definition-allocation slot-definition)
	:type (closer-mop:slot-definition-type slot-definition)
	:documentation (documentation slot-definition t)))

(defun add-slot-to-class (class slot-name)
  (closer-mop:ensure-class 
   (class-name class)
   :metaclass (class-of (class-of class))
   :direct-superclasses (closer-mop:class-direct-superclasses class)
   :direct-slots (cons `(:name ,slot-name
			       :initargs (,(intern (symbol-name slot-name) 
						   (find-package :keyword))))
		       (mapcar #'slot-definition->list 
			       (closer-mop:class-direct-slots class)))
   :direct-default-initargs (closer-mop:class-direct-default-initargs class)))

(defmethod slot-missing (class
			 (object on-demand-base) 
			 slot-name operation &optional new-value)
  (add-slot-to-class class slot-name)
  (ecase operation
    (setf (setf (slot-value object slot-name) new-value))
    (slot-boundp (slot-boundp object slot-name))
    (slot-makunbound (slot-makunbound object slot-name))
    (slot-value (slot-value object slot-name))))