Update of /cvsroot/scsh/scx/scheme/xlib
In directory usw-pr-cvs1:/tmp/cvs-serv6411/scheme/xlib
Modified Files:
event.scm
Log Message:
- added wait-event
- event-args now returns an alist of the event fields.
Index: event.scm
===================================================================
RCS file: /cvsroot/scsh/scx/scheme/xlib/event.scm,v
retrieving revision 1.5
retrieving revision 1.6
diff -C2 -r1.5 -r1.6
*** event.scm 2001/08/21 14:57:08 1.5
--- event.scm 2001/10/09 15:40:01 1.6
***************
*** 55,60 ****
--- 55,115 ----
) ;; 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))))
***************
*** 88,90 ****
(import-lambda-definition %get-motion-events (Xdisplay Xwindow from to)
! "scx_Get_Motion_Events")
\ No newline at end of file
--- 143,158 ----
(import-lambda-definition %get-motion-events (Xdisplay Xwindow from to)
! "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))))
|