;; wait-event blocks the current thread until an event is available,
;; and then it returns this new event.

(define (wait-event 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!))
    (next-event dpy)))

(define (event-ready? display)
  (char-ready? (display-message-inport display)))

;; creates an event type

(define (complete-event type args)
  (let ((constructor (event-constructor type)))
    (apply constructor (cons type (vector->list args)))))
  
(define (event-constructor type)
  (cond
   ((or (eq? type (event-type key-press))
	(eq? type (event-type key-release))) make-key-event)
   ((or (eq? type (event-type button-press))
	(eq? type (event-type button-release))) make-button-event)
   ((eq? type (event-type motion-notify)) make-motion-event)
   ((or (eq? type (event-type enter-notify))
	(eq? type (event-type leave-notify))) make-crossing-event)
   ((or (eq? type (event-type focus-in))
	(eq? type (event-type focus-out))) make-focus-change-event)
   ((eq? type (event-type keymap-notify)) make-keymap-event)
   ((eq? type (event-type expose)) make-expose-event)
   ((eq? type (event-type graphics-expose)) make-graphics-expose-event)
   ((eq? type (event-type no-expose)) make-no-expose-event)
   ((eq? type (event-type visibility-notify)) make-visibility-event)
   ((eq? type (event-type create-notify)) make-create-window-event)
   ((eq? type (event-type destroy-notify)) make-destroy-window-event)
   ((eq? type (event-type unmap-notify)) make-unmap-event)
   ((eq? type (event-type map-notify)) make-map-event)
   ((eq? type (event-type map-request)) make-map-request-event)
   ((eq? type (event-type reparent-notify)) make-reparent-event)
   ((eq? type (event-type configure-notify)) make-configure-event)
   ((eq? type (event-type configure-request)) make-configure-request-event)
   ((eq? type (event-type gravity-notify)) make-gravity-event)
   ((eq? type (event-type resize-request)) make-resize-request-event)
   ((eq? type (event-type circulate-notify)) make-circulate-event)
   ((eq? type (event-type circulate-request)) make-circulate-request-event)
   ((eq? type (event-type property-notify)) make-property-event)
   ((eq? type (event-type selection-clear)) make-selection-clear-event)
   ((eq? type (event-type selection-request)) make-selection-request-event)
   ((eq? type (event-type selection-notify)) make-selection-event)
   ((eq? type (event-type colormap-notify)) make-colormap-event)
   ((eq? type (event-type client-message)) make-client-message-event)
   ((eq? type (event-type mapping-notify)) make-mapping-event)
   (else (error "message type not supported" type))))

;;event-type-0 event-type-1 ;; those are not defined

(define (next-event display)
  (let ((r (%next-event (display-Xdisplay display))))
    (complete-event (integer->event-type (car r)) (cdr r))))

(import-lambda-definition %next-event (Xdisplay)
  "scx_Next_Event")

(define (peek-event display)
  (let ((r (%peek-event (display-Xdisplay display))))
    (complete-event (integer->event-type (car r))
		    (cdr r))))

(import-lambda-definition %peek-event (Xdisplay)
  "scx_Peek_Event")

(define (events-pending display)
  (%events-pending (display-Xdisplay display)))
;  (if (event-ready? display)
;      (%events-pending (display-Xdisplay display))
;      0))

(import-lambda-definition %events-pending (Xdisplay)
  "scx_Events_Pending")

(define (get-motion-events window from-time to-time)
  (%get-motion-events (display-Xdisplay (window-display window))
		      (window-Xwindow window)
		      from-time to-time))

(import-lambda-definition %get-motion-events (Xdisplay Xwindow from to)
  "scx_Get_Motion_Events")

;;; Only here until scsh provides us with select
(import-lambda-definition add-pending-channel (channel)
  "scx_add_pending_channel")