CL-STM

Transactional classes 

Metaclasses 

(defclass transactional-class (standard-class)
  ()
  (:documentation "The metaclass for transactional classes.

Classes defined with this metaclass have extra slot options,
see the class TRANSACTIONAL-DIRECT-SLOT for details."))

(defclass transactional-direct-slot (standard-direct-slot-definition)
  ((transactional :accessor slot-transactional
                  :initarg :transactional
                  :initform t))
  (:documentation "The class for direct slots of transactional
classes.

Other than the initargs for standard slots the following
options can be passed to component slots:

:transactional [ T | NIL ] - Specify that this slot is a
transactional slot and that all reads and writes should be
committed to log."))

(defclass transactional-effective-slot (standard-effective-slot-definition)
  ((transactional :accessor slot-transactional
                  :initarg :transactional))
  (:documentation "The class for effective slots of transactional
classes.

Exactly like TRANSACTIONAL-EFFECTIVE-SLOT."))

Inheritance 

(defmethod validate-superclass ((sub transactional-class)
                                (sup standard-class))
  (declare (ignore sub sup))
  t)

Slot definitions 

(defmethod direct-slot-definition-class ((class transactional-class)
                                         &rest initargs)
  (declare (ignore initargs))
  (find-class 'transactional-direct-slot))

(defmethod effective-slot-definition-class ((class transactional-class)
                                            &rest initargs)
  (declare (ignore initargs))
  (find-class 'transactional-effective-slot))

(defmethod compute-effective-slot-definition ((class transactional-class)
                                              slot-name direct-slots)
  (declare (ignore slot-name))
  (let ((effective-slot (call-next-method))
        (direct-slots (remove-if-not [typep _ 'transactional-direct-slot] direct-slots)))
    (unless (null (cdr direct-slots))
      (error "More than one :transactional specifier"))
    (let1 direct-slot (car direct-slots)
      (setf (slot-transactional effective-slot)
            (slot-transactional direct-slot)))
    effective-slot))

Slot access 

(defmethod slot-value-using-class ((class transactional-class) instance
                                   (slot transactional-effective-slot))
  (declare (ignore instance))
  (if (and (slot-transactional slot) (recording-p))
      ;; Record the reading of the tvar (which is found with
      ;; `call-next-method') to the current tlog.
      (read-tvar (call-next-method) (current-tlog))
      ;; Return the normal value which should be a tvar.
      (call-next-method)))

(defmethod (setf slot-value-using-class) (value    (class transactional-class)
                                          instance (slot transactional-effective-slot))
  (if (and (slot-transactional slot) (recording-p))
      ;; We turn off recording here so `slot-value-using-class'
      ;; returns the tvar, not the value inside the tvar, so it can be
      ;; written to with `write-tvar'.
      (without-recording
        (write-tvar (slot-value-using-class class instance slot) (current-tlog) value))
      ;; Write the slot normally.
      (call-next-method)))

(defmethod slot-boundp-using-class ((class transactional-class) instance
                                    (slot transactional-effective-slot))
  (if (and (slot-transactional slot) (recording-p))
      ;; We turn off recording here so `slot-value-using-class'
      ;; returns the tvar, not the value inside the tvar, so it can be
      ;; check to see if the `value' slot of the tvar is bound.
      (without-recording
        (slot-boundp (slot-value-using-class class instance slot) 'value))
      ;; Test the slot normally.
      (call-next-method)))

(defmethod slot-makunbound-using-class ((class transactional-class) instance
                                        (slot transactional-effective-slot))
  (if (and (slot-transactional slot) (recording-p))
      ;; We turn off recording here so `slot-value-using-class'
      ;; returns the tvar, not the value inside the tvar, so its
      ;; `value' slot can be unbound.
      (without-recording
        (slot-makunbound (slot-value-using-class class instance slot) 'value))
      ;; Unbind the slot normally.
      (call-next-method)))

Transactional objects 

(defclass transactional-object ()
  ()
  (:metaclass transactional-class)
  (:documentation "Superclass of all transactional objects."))

Defining 

(defmacro deftclass (class (&rest superclasses) (&rest slots) &rest class-options)
  "Define a new transactional class caleed CLASS.

DEFTCLASS is just like DEFCLASS except the default metaclass is
transactional class, slots are transactional, and it inherits
from TRANSACTIONAL-OBJECT by default."
  (let1 superclasses (or superclasses '(transactional-object))
    `(eval-always
       (defclass ,class ,superclasses
         ,slots
         ,@class-options
         (:metaclass transactional-class))
       ',class)))

Initializing 

(defmethod shared-initialize ((instance transactional-object)
                              slot-name &rest initargs)
  (declare (ignore initargs slot-name))
  ;; We turn off recording in the initialization so that any slot
  ;; changes are NOT recorded to the log.
  (without-recording
    (prog1
        (call-next-method)
      ;; For every transactional slot we turn its value into a tvar.
      (dolist (slotd (class-slots (class-of instance)))
        (let1 slot-name (slot-definition-name slotd)
          ;; Only initialize those where `slot-transactional' is true.
          (when (and (typep slotd 'transactional-effective-slot)
                     (slot-transactional slotd))
            (setf (slot-value instance slot-name)
                  ;; Check if the initarg was specified.
                  (if (slot-boundp instance slot-name)
                      (new 'standard-tvar :value (slot-value instance slot-name))
                      (new 'standard-tvar)))))))))