scx/scheme/xlib/event.scm

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