scsh-conservatory
/
scx
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

- added wait-event 

- event-args now returns an alist of the event fields.
This commit is contained in:
frese 2001-10-09 15:40:01 +00:00
parent b4fb3ffd9f
commit 231afe173a
1 changed files with 69 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
scheme/xlib/event.scm
View File

@ -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")
"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))))