scx/scheme/xlib/event.scm

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

(define (complete-event event)
  (let* ((type (event-type event))
	 (args (event-args event))
	 (comp (lambda (idx func)
		 (vector-set! args idx
			      (func (vector-ref args idx))))))
    ;; for all types
    (comp 2 (lambda (Xdisplay) ;; Display the event was read from
	      (make-display Xdisplay #f)))
    (comp 3 (lambda (Xwin) ;; event-window it is reported relative to
	      (make-window Xwin (vector-ref args 2) #f)))
    (let* ((display (vector-ref args 2))
	   (window (vector-ref args 3))
	   (sidx 4) ;; start index of event-dependand fields
	   (make-window* (lambda (Xwindow)
			   (make-window Xwindow display #f))))
      ;; special entries
      (case type
	((key-press key-release button-press button-release motion-notify) 
	 ;; root window that the event occured on
	 (comp (+ sidx 0) make-window*)
	 ;; child window
	 (comp (+ sidx 1) make-window*))
	 ;; time in milliseconds ?? ...
	((enter-notify leave-notify)
	 (comp (+ sidx 0) make-window*) ;; root window
	 (comp (+ sidx 1) make-window*));; subwindow
	 ;; time??
	((create-notify destroy-notify unmap-notify map-notify map-request 
	  gravity-notify circulate-request)
	 (comp (+ sidx 0) make-window*))
	((reparent-notify configure-request)
	 (comp (+ sidx 0) make-window*)
	 (comp (+ sidx 1) make-window*))
	((property-notify selection-clear)
	 (comp (+ sidx 0) make-atom)) ;;??
	 ;; time??
	((selection-request)
	 (comp (+ sidx 0) make-window*)
	 (comp (+ sidx 1) make-atom) ;;??
	 (comp (+ sidx 2) make-atom)
	 (comp (+ sidx 3) make-atom))
	((selection-notify)
	 (comp (+ sidx 0) make-atom)
	 (comp (+ sidx 1) make-atom)
	 (comp (+ sidx 2) make-atom))
	((colormap-notify) ;;??
	 (comp (+ sidx 0) (lambda (Xcolormap)
			    (make-colormap Xcolormap #f))))
	((client-message)
	 (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)
				(cdr r)))))

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

(define (peek-event display)
  (let ((r (%peek-event (display-Xdisplay display))))
    (complete-event (make-event (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")

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

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