71 lines
2.3 KiB
Scheme
71 lines
2.3 KiB
Scheme
;; Thread-safe event reading *****************************************
|
|
|
|
;; wait-event blocks the current thread until an event is available,
|
|
;; and then it returns this new event.
|
|
|
|
(define (wait-event dpy)
|
|
(if (not (> (events-queued dpy (queued-mode after-flush)) 0))
|
|
(block-on-message-inport dpy))
|
|
(next-event dpy))
|
|
|
|
(define (block-on-message-inport dpy)
|
|
(let ((port (display-message-inport dpy)))
|
|
(call-with-values
|
|
(lambda () (select (vector port) (vector) (vector)))
|
|
(lambda (ready-read ready-write ex)
|
|
(if (not (member port (vector->list ready-read)))
|
|
(block-on-message-inport dpy))))))
|
|
|
|
;(define (block-on-message-inport dpy) ; needs ports, locks
|
|
; (let ((port (display-message-inport dpy)))
|
|
; (disable-interrupts!)
|
|
; (if (not (char-ready? port))
|
|
; (begin
|
|
; (obtain-lock (port-lock port))
|
|
; (add-pending-channel (port->channel port))
|
|
; (wait-for-channel (port->channel port)) ;; enables interrupts
|
|
; (release-lock (port-lock port)))
|
|
; (enable-interrupts!))))
|
|
|
|
;;;; Only here until scsh provides us with select
|
|
;(import-lambda-definition add-pending-channel (channel)
|
|
; "scx_add_pending_channel")
|
|
|
|
;; How to find out if there are events available *********************
|
|
|
|
(define-enumerated-type queued-mode :queued-mode
|
|
queued-mode? queued-modes queued-mode-name queued-mode-index
|
|
(already after-reading after-flush))
|
|
|
|
(define-exported-binding "scx-queued-mode" :queued-mode)
|
|
|
|
(import-lambda-definition events-queued (display mode)
|
|
"scx_Events_Queued")
|
|
|
|
(define (event-ready? display)
|
|
(or (> (events-queued display (queued-mode already)) 0)
|
|
(char-ready? (display-message-inport display))))
|
|
|
|
;; events-pending is identical to events-queued with after-flush
|
|
;; mode.
|
|
|
|
(import-lambda-definition events-pending (display)
|
|
"scx_Events_Pending")
|
|
|
|
;; Other event reading ***********************************************
|
|
|
|
(import-lambda-definition next-event (display)
|
|
"scx_Next_Event")
|
|
|
|
(import-lambda-definition peek-event (display)
|
|
"scx_Peek_Event")
|
|
|
|
;; returns a list of (time . (x . y)) elements
|
|
(import-lambda-definition get-motion-events (display window from to)
|
|
"scx_Get_Motion_Events")
|
|
|
|
;; Sending events ****************************************************
|
|
|
|
(import-lambda-definition send-event (display window propagate mask event)
|
|
"scx_Send_Event")
|