Commit e8db9fee authored by csr21's avatar csr21
Browse files

make event-key type extensible

Typechecking lisps mean that for every new implemented extension, the type
EVENT-KEY in the main body of CLX needs alteration.  Instead, define a
suitable function for use as a SATISFIES checker, and use it in the type and
in the code.

parent 70aa2320
......@@ -639,15 +639,16 @@
(deftype event-key ()
'(member :key-press :key-release :button-press :button-release :motion-notify
:enter-notify :leave-notify :focus-in :focus-out :keymap-notify
:exposure :graphics-exposure :no-exposure :visibility-notify
:create-notify :destroy-notify :unmap-notify :map-notify :map-request
:reparent-notify :configure-notify :gravity-notify :resize-request
:configure-request :circulate-notify :circulate-request :property-notify
:selection-clear :selection-request :selection-notify
:colormap-notify :client-message :mapping-notify
:shape-notify :xfree86-vidmode-notify :glx-pbuffer-clobber))
'(or (member :key-press :key-release :button-press :button-release
:motion-notify :enter-notify :leave-notify :focus-in :focus-out
:keymap-notify :exposure :graphics-exposure :no-exposure
:visibility-notify :create-notify :destroy-notify :unmap-notify
:map-notify :map-request :reparent-notify :configure-notify
:gravity-notify :resize-request :configure-request :circulate-notify
:circulate-request :property-notify :selection-clear
:selection-request :selection-notify :colormap-notify :client-message
(satisfies extension-event-key-p)))
(deftype error-key ()
'(member :access :alloc :atom :colormap :cursor :drawable :font :gcontext :id-choice
......@@ -106,6 +106,11 @@
(declare (clx-values event-key))
(kintern event)))
(defun extension-event-key-p (key)
(dolist (extension *extensions* nil)
(when (member key (second extension))
(return t))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun allocate-extension-event-code (name)
;; Allocate an event-code for an extension. This is executed at
......@@ -117,9 +122,7 @@
(declare (type (or null card8) event-code))
(unless event-code
;; First ensure the name is for a declared extension
(unless (dolist (extension *extensions*)
(when (member name (second extension))
(return t)))
(unless (extension-event-key-p name)
(x-type-error name 'event-key))
(setq event-code (position nil *event-key-vector*
:start *first-extension-event-code*))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment