|
|
|
|
|
(in-package mito-transactions.dev)
|
|
|
|
|
|
(defmacro ensure-superclass-for-metaclass (metaclass superclass)
|
|
|
"From https://cliki.net/MOP design patterns"
|
|
|
(check-type metaclass symbol)
|
|
|
(check-type superclass symbol)
|
|
|
`(progn
|
|
|
(defmethod initialize-instance :around
|
|
|
((class ,metaclass) &rest initargs
|
|
|
&key direct-superclasses)
|
|
|
(declare (dynamic-extent initargs))
|
|
|
(if (some (lambda (c) (subtypep c (find-class ',superclass)))
|
|
|
direct-superclasses)
|
|
|
(call-next-method)
|
|
|
(apply #'call-next-method
|
|
|
class
|
|
|
:direct-superclasses (cons (find-class ',superclass)
|
|
|
direct-superclasses)
|
|
|
initargs)))
|
|
|
(defmethod reinitialize-instance :around
|
|
|
((class ,metaclass) &rest initargs
|
|
|
&key (direct-superclasses '() direct-superclasses-p))
|
|
|
(declare (dynamic-extent initargs))
|
|
|
(if direct-superclasses-p
|
|
|
(if (loop for class in direct-superclasses
|
|
|
thereis (subtypep class (find-class ',superclass)))
|
|
|
(call-next-method)
|
|
|
(apply #'call-next-method
|
|
|
class
|
|
|
:direct-superclasses
|
|
|
(cons (find-class ',superclass)
|
|
|
direct-superclasses)
|
|
|
initargs))
|
|
|
(call-next-method)))))
|
|
|
|
|
|
;;; Following based on MOP utilities found in https://github.com/fukamachi/mito
|
|
|
|
|
|
(defun map-all-superclasses (fn class &key (key #'identity))
|
|
|
(labels ((main (class &optional main-objects)
|
|
|
(loop for superclass in (c2mop:class-direct-superclasses class)
|
|
|
if (eq (class-of superclass) (find-class 'standard-class))
|
|
|
append (if (eq superclass (find-class 'standard-object))
|
|
|
(append (funcall fn class) main-objects)
|
|
|
(funcall fn class))
|
|
|
else
|
|
|
append (main superclass
|
|
|
(append (funcall fn class)
|
|
|
main-objects)))))
|
|
|
(delete-duplicates
|
|
|
(main class)
|
|
|
:test #'eq
|
|
|
:key key
|
|
|
:from-end t)))
|
|
|
|
|
|
(defun class-direct-slots (slot-type)
|
|
|
(lambda (class)
|
|
|
(remove-if-not (lambda (slot)
|
|
|
(typep slot slot-type))
|
|
|
(c2mop:class-direct-slots class))))
|
|
|
|
|
|
(defun all-direct-slots (class slot-type)
|
|
|
(map-all-superclasses (class-direct-slots slot-type)
|
|
|
class
|
|
|
:key #'c2mop:slot-definition-name))
|
|
|
|
