diff --git a/scheme/xlib/event.scm b/scheme/xlib/event.scm index b499e4c..f3787f2 100644 --- a/scheme/xlib/event.scm +++ b/scheme/xlib/event.scm @@ -54,8 +54,63 @@ (comp (+ sidx 0) make-atom)) ;;?? ) ;; case end + (event-set-args! event (event-args->alist event)) event))) +(define (event-args->alist event) + (let ((type (event-type event))) + (map cons + (append + ;; these fields belong to all events + '(serial send-event? display) ; the window is named differently + (case type + ((key-press key-release button-press button-release motion-notify) + (append '(window root-window sub-window time x y x-root y-root + state) + (case type + ((key-press key-release) '(key-code)) + ((button-press button-release) '(button)) + ((motion-notify) '(is-hint?))) + '(same-screen?))) + ((enter-notify leave-notify) + '(window root-window sub-window time x y x-root y-root cross-mode + cross-detail same-screen? focus? button-mask)) + ((focus-in focus-out) '(window cross-mode focus-detail)) + ((keymap-notify) '(window keymap)) + ((expose) '(window x y width height count)) + ((graphics-expose) '(window x y width height count major-code + minor-code)) + ((no-expose) '(window major-code minor-code)) + ((visibility-notify) '(window visibility-state)) + ((create-notify) '(root-window window x y width height border-width + override-redirect?)) + ((destroy-notify) '(event-window window)) + ((unmap-notify) '(event-window window from-configure)) + ((map-notify) '(event-window window override-redirect?)) + ((map-request) '(parent-window window)) + ((reparent-notify) '(event-window parent-window window x y + override-redirect?)) + ((configure-notify) '(event-window window x y width height + border-width above-window + override-redirect?)) + ((configure-request) '(parent-window window x y width height + border-width above-window + override-redirect?)) + ((gravity-notify) '(event-window window x y)) + ((resize-request) '(window width height)) + ((circulate-notify) '(event-window window place)) + ((circulate-request) '(parent-window window place)) + ((property-notify) '(window atom time property-state)) + ((selection-clear) '(window selection-atom time)) + ((selection-request) '(owner-window requestor-window selection-atom + target-atom property-atom time)) + ((selection-notify) '(requestor-window selection-atom target-atom + property-atom time)) + ((colormap-notify) '(window colormap new? colormap-installed?)) + ((client-message) '(window message-type message-data)) + ((mapping-notify) '(window request keycode count)))) + (vector->list (event-args event))))) + (define (next-event display) (let ((r (%next-event (display-Xdisplay display)))) (complete-event (make-event (car r) @@ -87,4 +142,17 @@ from-time to-time)) (import-lambda-definition %get-motion-events (Xdisplay Xwindow from to) - "scx_Get_Motion_Events") \ No newline at end of file + "scx_Get_Motion_Events") + +;; wait-event blocks the current thread until an event is available, +;; and then it returns this new event. +;; In future releases this should be done with a select. But for now +;; we just do a loop with event-ready? and next-event. On this machine +;; that uses an acceptable amount of about 1% CPU-Time. + +(define (wait-event display) + (if (event-ready? display) + (next-event display) + (begin + (sleep 20) ; sleep for 20 ms + (wait-event display))))