common-lisp
Protocolo de metaobjetos CLOS

Obtener los nombres de tragamonedas de una clase

Digamos que tenemos una clase como

(defclass person ()
  (name email age))

Para obtener los nombres de las ranuras de la clase usamos la función class-slots. Esto se puede encontrar en el paquete de fregona más cercana, proporcionado por el sistema de fregona más cercana. Para cargar la imagen lisp que utilizamos (ql:quickload :closer-mop) . También debemos asegurarnos de que la clase esté finalizada antes de llamar a los espacios de clase.

(let ((class (find-class 'person)))
  (c2mop:ensure-finalized class)
  (c2mop:class-slots class))

que devuelve una lista de objetos de definición de ranura efectivos :

(#<SB-MOP:STANDARD-EFFECTIVE-SLOT-DEFINITION S/TRANSFORMATIONS::NAME>
 #<SB-MOP:STANDARD-EFFECTIVE-SLOT-DEFINITION S/TRANSFORMATIONS::EMAIL>
 #<SB-MOP:STANDARD-EFFECTIVE-SLOT-DEFINITION S/TRANSFORMATIONS::AGE>)

Actualizar una ranura cuando se modifica otra ranura

CLOS MOP proporciona la clase de uso de valor de ranura de gancho, que se llama cuando se accede, lee o modifica una ranura. Debido a que solo nos preocupamos por las modificaciones en este caso, definimos un método para (setf slot-value-using-class) .

(defclass document ()
  ((id :reader id :documentation "A hash computed with the contents of every other slot")
   (title :initarg :title :accessor title)
   (body :initarg :body :accessor body)))

(defmethod (setf c2mop:slot-value-using-class) :after
    (new class (object document) (slot c2mop:standard-effective-slot-definition))
  ;; To avoid this method triggering a call to itself, we check that the slot
  ;; the modification occurred in is not the slot we are updating.
  (unless (eq (slot-definition-name slot) 'id)
    (setf (slot-value object 'id) (hash-slots object))))

Tenga en cuenta que debido a que en la creación de la instancia no se llama slot-value , puede ser necesario duplicar el código en la initialize-instance :after método

(defmethod initialize-instance :after ((obj document) &key)
  (setf (slot-value obj 'id)
        (hash-slots obj)))