64 lines
1.6 KiB
Racket
64 lines
1.6 KiB
Racket
#lang racket/base
|
|
(require ffi/unsafe
|
|
"utils.rkt"
|
|
"types.rkt"
|
|
"const.rkt"
|
|
"../../lock.rkt"
|
|
"../common/queue.rkt")
|
|
|
|
(provide win32-start-event-pump
|
|
|
|
;; from common/queue:
|
|
current-eventspace
|
|
queue-event
|
|
queue-refresh-event
|
|
yield)
|
|
|
|
;; ------------------------------------------------------------
|
|
;; Win32 event pump
|
|
|
|
(define _LPMSG _pointer)
|
|
|
|
(define-cstruct _MSG ([hwnd _HWND]
|
|
[message _UINT]
|
|
[wParam _WPARAM]
|
|
[lParam _LPARAM]
|
|
[time _DWORD]
|
|
[pt _POINT]))
|
|
|
|
(define-user32 GetQueueStatus (_wfun _UINT -> _DWORD))
|
|
(define-user32 GetMessageW (_wfun _LPMSG _HWND _UINT _UINT -> _BOOL))
|
|
(define-user32 PeekMessageW (_wfun _LPMSG _HWND _UINT _UINT _UINT -> _BOOL))
|
|
(define-user32 TranslateMessage (_wfun _LPMSG -> _BOOL))
|
|
(define-user32 DispatchMessageW (_wfun _LPMSG -> _LRESULT))
|
|
(define-user32 PostQuitMessage (_wfun _int -> _void))
|
|
|
|
(define-mz scheme_add_fd_eventmask (_fun _pointer _int -> _void))
|
|
|
|
(define msg (malloc _MSG 'raw))
|
|
|
|
(define (events-ready?)
|
|
(not (zero? (GetQueueStatus QS_ALLINPUT))))
|
|
|
|
(define (install-wakeup fds)
|
|
(pre-event-sync #t)
|
|
(scheme_add_fd_eventmask fds QS_ALLINPUT))
|
|
|
|
(set-check-queue! events-ready?)
|
|
(set-queue-wakeup! install-wakeup)
|
|
|
|
(define (dispatch-all-ready)
|
|
(pre-event-sync #f)
|
|
(let ([v (PeekMessageW msg #f 0 0 PM_REMOVE)])
|
|
(when v
|
|
(TranslateMessage msg)
|
|
(DispatchMessageW msg)
|
|
(dispatch-all-ready))))
|
|
|
|
(define (win32-start-event-pump)
|
|
(thread (lambda ()
|
|
(let loop ()
|
|
(sync queue-evt)
|
|
(as-entry dispatch-all-ready)
|
|
(loop)))))
|