+;;;; Metaclass for event classes
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar *event-classes* (make-hash-table))
+
+ (defclass event-class (boxed-class)
+ ((event-type :reader event-class-type :initform nil)))
+
+ (defmethod validate-superclass ((class event-class) (super standard-class))
+ ;(subtypep (class-name super) 'event)
+ t)
+
+ (defmethod shared-initialize ((class event-class) names &key name event-type)
+ (declare (ignore names))
+ (register-type-alias (or name (class-name class)) 'event)
+ (call-next-method)
+ (when event-type
+ (setf (slot-value class 'event-type) (first event-type))
+ (setf (gethash (first event-type) *event-classes*) class))))
+
+(let ((reader (reader-function 'event-type)))
+ (defun %event-class (location)
+ (gethash (funcall reader location 0) *event-classes*)))
+
+(defmethod make-proxy-instance :around ((class event-class) location
+ &rest initargs)
+ (let ((class (%event-class location)))
+ (apply #'call-next-method class location initargs)))
+