+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defclass event-class (boxed-class)
+ ((event-type :reader event-class-type)))
+
+ (defmethod validate-superclass ((class event-class) (super standard-class))
+ ;(subtypep (class-name super) 'event)
+ t))
+
+
+(defmethod shared-initialize ((class event-class) names &key name type)
+ (let ((class-name (or name (class-name class))))
+ (unless (eq class-name 'event)
+ (register-type-alias class-name 'event)))
+ (call-next-method)
+ (setf (slot-value class 'event-type) (first type))
+ (setf (gethash (first type) *event-classes*) class))
+
+(let ((reader (reader-function 'event-type)))
+ (defun %event-class (location)
+ (gethash (funcall reader location 0) *event-classes*)))
+
+(defmethod ensure-proxy-instance ((class event-class) location)
+ (declare (ignore class))
+ (let ((class (%event-class location)))
+ (make-instance class :location location)))
+
+
+;;;;