suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

win32 basic canvas, key handling, and eventspaces

Browse Source 
original commit: ee30013098c51c0b5cc75ac3ca2bf7058cf6dc63
This commit is contained in:
Matthew Flatt 2010-09-22 06:00:58 -06:00
parent 80e2b57c53
commit bc8b9d562f
17 changed files with 900 additions and 123 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/mred/private/wx/common/queue.rkt
View File

@ -30,6 +30,7 @@
main-eventspace?
eventspace-handler-thread
eventspace-wait-cursor-count
eventspace-extra-table
queue-callback
middle-queue-key
@ -151,7 +152,8 @@
done-evt
[shutdown? #:mutable]
done-sema
[wait-cursor-count #:mutable])
[wait-cursor-count #:mutable]
extra-table)
#:property prop:evt (lambda (v)
(wrap-evt (eventspace-done-evt v)
(lambda (_) v))))
@ -315,7 +317,8 @@
(semaphore-peek-evt done-sema)
#f
done-sema
0)]
0
(make-hash))]
[cb-box (box #f)])
(parameterize ([current-cb-box cb-box])
(scheme_add_managed (current-custodian)

4
collects/mred/private/wx/win32/button.rkt
View File

@ -15,13 +15,13 @@
(init parent cb label x y w h style font)
(super-new [parent parent]
[win32
[hwnd
(CreateWindowExW 0
"BUTTON"
label
(bitwise-ior BS_PUSHBUTTON WS_CHILD WS_CLIPSIBLINGS)
0 0 0 0
(send parent get-win32)
(send parent get-hwnd)
#f
hInstance
#f)]

121
collects/mred/private/wx/win32/canvas.rkt
View File

@ -18,7 +18,29 @@
(define-user32 GetDC (_wfun _HWND -> _HDC))
(define-user32 BeginPaint (_wfun _HWND _pointer -> _HDC))
(define-user32 EndPaint (_wfun _HDC _pointer -> _BOOL))
(define-user32 InvalidateRect (_wfun _HWND (_or-null _RECT-pointer) _BOOL -> _BOOL))
(define-user32 InvalidateRect (_wfun _HWND (_or-null _RECT-pointer) _BOOL -> (r : _BOOL)
-> (unless r (failed 'InvalidateRect))))
(define-user32 ShowScrollBar (_wfun _HWND _int _BOOL -> (r : _BOOL)
-> (unless r (failed 'ShowScrollbar))))
(define-cstruct _SCROLLINFO
([cbSize _UINT]
[fMask _UINT]
[nMin _int]
[nMax _int]
[nPage _UINT]
[nPos _int]
[nTrackPos _int]))
(define-user32 SetScrollInfo (_wfun _HWND _int _SCROLLINFO-pointer _BOOL -> _int))
(define-user32 GetScrollPos (_wfun _HWND _int -> _int))
(define-user32 SetScrollPos (_wfun _HWND _int _BOOL -> _int))
(define-user32 GetScrollInfo (_wfun _HWND _int (i : _SCROLLINFO-pointer
= (make-SCROLLINFO (ctype-sizeof _SCROLLINFO)
(bitwise-ior SIF_RANGE SIF_POS SIF_PAGE)
0 0 0 0 0))
-> (r : _BOOL)
-> (if r i (error 'GetScrollInfo "failed"))))
(define canvas%
(canvas-mixin
@ -29,14 +51,14 @@
[ignored-name #f]
[gl-config #f])
(inherit get-win32
(inherit get-hwnd
get-client-size)
(define hscroll? (memq 'hscroll style))
(define vscroll? (memq 'vscroll style))
(super-new [parent parent]
[win32
[hwnd
(CreateWindowExW 0
"PLTCanvas"
#f
@ -44,13 +66,13 @@
(if hscroll? WS_HSCROLL 0)
(if vscroll? WS_VSCROLL 0))
0 0 w h
(send parent get-win32)
(send parent get-hwnd)
#f
hInstance
#f)]
[style style])
(define win32 (get-win32))
(define hwnd (get-hwnd))
(define/override (wndproc w msg wparam lparam)
(cond
@ -66,9 +88,13 @@
[else (super wndproc w msg wparam lparam)]))
(define dc (new dc% [canvas this]))
(send dc start-backing-retained)
(define/public (get-dc) dc)
(define/override (on-resized)
(send dc reset-backing-retained))
;; The `queue-paint' and `paint-children' methods
;; are defined by `canvas-mixin' from ../common/canvas-mixin
(define/public (queue-paint) (void))
@ -79,7 +105,7 @@
(define/public (queue-canvas-refresh-event thunk)
(queue-window-refresh-event this thunk))
(define/public (get-flush-window) win32)
(define/public (get-flush-window) hwnd)
(define/public (begin-refresh-sequence)
(send dc suspend-flush))
@ -90,7 +116,7 @@
(define/override (refresh) (queue-paint))
(define/public (queue-backing-flush)
(void (InvalidateRect win32 #f #t)))
(InvalidateRect hwnd #f #t))
(define/public (make-compatible-bitmap w h)
(send dc make-backing-bitmap w h))
@ -114,19 +140,78 @@
bg-col))
(define/public (set-canvas-background col) (set! bg-col col))
(define h-scroll-visible? hscroll?)
(define v-scroll-visible? vscroll?)
(define/public (show-scrollbars h? v?)
(when hscroll?
(atomically
(set! h-scroll-visible? (and h? #t))
(ShowScrollBar hwnd SB_HORZ h?)))
(when vscroll?
(atomically
(set! v-scroll-visible? (and v? #t))
(ShowScrollBar hwnd SB_VERT v?))))
(define/public (set-scrollbars h-step v-step
h-len v-len
h-page v-page
h-pos v-pos
auto?)
(define (make-info len page pos vis?)
(make-SCROLLINFO (ctype-sizeof _SCROLLINFO)
(bitwise-ior (if vis? SIF_DISABLENOSCROLL 0)
SIF_RANGE
SIF_POS
SIF_PAGE)
0 (+ len page -1) page pos 0))
(when hscroll?
(SetScrollInfo hwnd SB_HORZ (make-info h-len h-page h-pos h-scroll-visible?) #t))
(when vscroll?
(SetScrollInfo hwnd SB_VERT (make-info v-len v-page v-pos v-scroll-visible?) #t)))
(def/public-unimplemented set-background-to-gray)
(def/public-unimplemented on-scroll)
(def/public-unimplemented set-scroll-page)
(def/public-unimplemented set-scroll-range)
(def/public-unimplemented set-scroll-pos)
(def/public-unimplemented get-scroll-page)
(def/public-unimplemented get-scroll-range)
(def/public-unimplemented get-scroll-pos)
(define/public (get-scroll-pos which)
(GetScrollPos hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ)))
(define/public (get-scroll-range which)
(let ([i (GetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))])
(+ (SCROLLINFO-nMax i)
(SCROLLINFO-nPage i)
1)))
(define/public (get-scroll-page which)
(let ([i (GetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))])
(SCROLLINFO-nPage i)))
(define/public (set-scroll-pos which v)
(void (SetScrollPos hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) v #t)))
(define/public (set-scroll-range which v)
(let ([i (GetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))])
(set-SCROLLINFO-fMask! i (bitwise-ior SIF_RANGE
(if (if (eq? which 'vertical)
v-scroll-visible?
h-scroll-visible?)
SIF_DISABLENOSCROLL
0)))
(set-SCROLLINFO-nMax! i (- v (SCROLLINFO-nPage i) -1))
(SetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) i #t)))
(define/public (set-scroll-page which v)
(let ([i (GetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))])
(set-SCROLLINFO-fMask! i (bitwise-ior SIF_RANGE SIF_PAGE
(if (if (eq? which 'vertical)
v-scroll-visible?
h-scroll-visible?)
SIF_DISABLENOSCROLL
0)))
(set-SCROLLINFO-nMax! i (- (+ (SCROLLINFO-nMax i) (SCROLLINFO-nPage i))
v))
(set-SCROLLINFO-nPage! i v)
(SetScrollInfo hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) i #t)))
(define/override (definitely-wants-event? e)
#t)
(def/public-unimplemented scroll)
(def/public-unimplemented warp-pointer)
(def/public-unimplemented view-start)
(def/public-unimplemented set-resize-corner)
(def/public-unimplemented show-scrollbars)
(def/public-unimplemented set-scrollbars)
(def/public-unimplemented on-char)
(def/public-unimplemented on-event))))
(def/public-unimplemented set-resize-corner))))

139
collects/mred/private/wx/win32/const.rkt
View File

@ -411,3 +411,142 @@
(define MB_YESNOCANCEL #x00000003)
(define MB_YESNO #x00000004)
(define MB_RETRYCANCEL #x00000005)
(define SIZE_RESTORED 0)
(define SIZE_MINIMIZED 1)
(define SIZE_MAXIMIZED 2)
(define SIZE_MAXSHOW 3)
(define SIZE_MAXHIDE 4)
(define SB_HORZ 0)
(define SB_VERT 1)
(define SB_CTL 2)
(define SB_BOTH 3)
(define SIF_RANGE #x0001)
(define SIF_PAGE #x0002)
(define SIF_POS #x0004)
(define SIF_DISABLENOSCROLL #x0008)
(define SIF_TRACKPOS #x0010)
(define SIF_ALL (bitwise-ior SIF_RANGE SIF_PAGE SIF_POS SIF_TRACKPOS))
(define VK_LBUTTON #x01)
(define VK_RBUTTON #x02)
(define VK_CANCEL #x03)
(define VK_MBUTTON #x04)
(define VK_XBUTTON1 #x05)
(define VK_XBUTTON2 #x06)
(define VK_BACK #x08)
(define VK_TAB #x09)
(define VK_CLEAR #x0C)
(define VK_RETURN #x0D)
(define VK_SHIFT #x10)
(define VK_CONTROL #x11)
(define VK_MENU #x12)
(define VK_PAUSE #x13)
(define VK_CAPITAL #x14)
(define VK_KANA #x15)
(define VK_HANGUL #x15)
(define VK_JUNJA #x17)
(define VK_FINAL #x18)
(define VK_HANJA #x19)
(define VK_KANJI #x19)
(define VK_ESCAPE #x1B)
(define VK_CONVERT #x1C)
(define VK_NONCONVERT #x1D)
(define VK_ACCEPT #x1E)
(define VK_MODECHANGE #x1F)
(define VK_SPACE #x20)
(define VK_PRIOR #x21)
(define VK_NEXT #x22)
(define VK_END #x23)
(define VK_HOME #x24)
(define VK_LEFT #x25)
(define VK_UP #x26)
(define VK_RIGHT #x27)
(define VK_DOWN #x28)
(define VK_SELECT #x29)
(define VK_PRINT #x2A)
(define VK_EXECUTE #x2B)
(define VK_SNAPSHOT #x2C)
(define VK_INSERT #x2D)
(define VK_DELETE #x2E)
(define VK_HELP #x2F)
(define VK_LWIN #x5B)
(define VK_RWIN #x5C)
(define VK_APPS #x5D)
(define VK_SLEEP #x5F)
(define VK_NUMPAD0 #x60)
(define VK_NUMPAD1 #x61)
(define VK_NUMPAD2 #x62)
(define VK_NUMPAD3 #x63)
(define VK_NUMPAD4 #x64)
(define VK_NUMPAD5 #x65)
(define VK_NUMPAD6 #x66)
(define VK_NUMPAD7 #x67)
(define VK_NUMPAD8 #x68)
(define VK_NUMPAD9 #x69)
(define VK_MULTIPLY #x6A)
(define VK_ADD #x6B)
(define VK_SEPARATOR #x6C)
(define VK_SUBTRACT #x6D)
(define VK_DECIMAL #x6E)
(define VK_DIVIDE #x6F)
(define VK_F1 #x70)
(define VK_F2 #x71)
(define VK_F3 #x72)
(define VK_F4 #x73)
(define VK_F5 #x74)
(define VK_F6 #x75)
(define VK_F7 #x76)
(define VK_F8 #x77)
(define VK_F9 #x78)
(define VK_F10 #x79)
(define VK_F11 #x7A)
(define VK_F12 #x7B)
(define VK_F13 #x7C)
(define VK_F14 #x7D)
(define VK_F15 #x7E)
(define VK_F16 #x7F)
(define VK_F17 #x80)
(define VK_F18 #x81)
(define VK_F19 #x82)
(define VK_F20 #x83)
(define VK_F21 #x84)
(define VK_F22 #x85)
(define VK_F23 #x86)
(define VK_F24 #x87)
(define VK_NUMLOCK #x90)
(define VK_SCROLL #x91)
(define VK_LSHIFT #xA0)
(define VK_RSHIFT #xA1)
(define VK_LCONTROL #xA2)
(define VK_RCONTROL #xA3)
(define VK_LMENU #xA4)
(define VK_RMENU #xA5)
(define VK_OEM_1 #xBA)
(define VK_OEM_PLUS #xBB)
(define VK_OEM_COMMA #xBC)
(define VK_OEM_MINUS #xBD)
(define VK_OEM_PERIOD #xBE)
(define VK_OEM_2 #xBF)
(define VK_OEM_3 #xC0)
(define VK_OEM_4 #xDB)
(define VK_OEM_5 #xDC)
(define VK_OEM_6 #xDD)
(define VK_OEM_7 #xDE)
(define VK_OEM_8 #xDF)
(define KF_EXTENDED #x0100)
(define KF_DLGMODE #x0800)
(define KF_MENUMODE #x1000)
(define KF_ALTDOWN #x2000)
(define KF_REPEAT #x4000)
(define KF_UP #x8000)
(define GW_HWNDFIRST 0)
(define GW_HWNDLAST 1)
(define GW_HWNDNEXT 2)
(define GW_HWNDPREV 3)
(define GW_OWNER 4)
(define GW_CHILD 5)

10
collects/mred/private/wx/win32/dc.rkt
View File

@ -18,18 +18,18 @@
cancel-flush-delay)
(define-user32 GetDC (_wfun _HWND -> _HDC))
(define-user32 ReleaseDC (_wfun _HDC -> _void))
(define-user32 ReleaseDC (_wfun _HDC -> _int))
(define win32-bitmap%
(class bitmap%
(init w h win32)
(init w h hwnd)
(super-make-object (make-alternate-bitmap-kind w h))
(define s
(if (not win32)
(if (not hwnd)
(cairo_win32_surface_create_with_dib CAIRO_FORMAT_RGB24 w h)
(atomically
(let ([hdc (GetDC win32)])
(let ([hdc (GetDC hwnd)])
(begin0
(cairo_win32_surface_create_with_ddb hdc
CAIRO_FORMAT_RGB24 w h)
@ -56,7 +56,7 @@
(define/override (make-backing-bitmap w h)
(if (send canvas get-canvas-background)
(make-object win32-bitmap% w h (send canvas get-win32))
(make-object win32-bitmap% w h (send canvas get-hwnd))
(super make-backing-bitmap w h)))
(define/override (get-backing-size xb yb)

85
collects/mred/private/wx/win32/frame.rkt
View File

@ -1,5 +1,7 @@
#lang racket/base
(require racket/class
(only-in racket/list last)
ffi/unsafe
"../../syntax.rkt"
"../common/queue.rkt"
"utils.ss"
@ -11,6 +13,8 @@
(provide frame%)
(define-user32 SetLayeredWindowAttributes (_wfun _HWND _COLORREF _BYTE _DWORD -> _BOOL))
(define-user32 GetActiveWindow (_wfun -> _HWND))
(define-user32 SetFocus (_wfun _HWND -> _HWND))
(defclass frame% window%
(init parent
@ -18,13 +22,15 @@
x y w h
style)
(inherit get-win32
(inherit get-hwnd
is-shown?
get-eventspace)
get-eventspace
on-size
pre-on-char pre-on-event)
(super-new [parent #f]
[win32
(CreateWindowExW (bitwise-ior WS_EX_LAYERED)
[hwnd
(CreateWindowExW 0 ; (bitwise-ior WS_EX_LAYERED)
"PLTFrame"
(if label label "")
WS_OVERLAPPEDWINDOW
@ -35,8 +41,8 @@
#f)]
[style (cons 'invisible style)])
(define win32 (get-win32))
(SetLayeredWindowAttributes win32 0 255 LWA_ALPHA)
(define hwnd (get-hwnd))
(SetLayeredWindowAttributes hwnd 0 255 LWA_ALPHA)
(define/public (is-dialog?) #f)
@ -56,14 +62,33 @@
(register-frame-shown this on?)
(super direct-show on?))
(define/override (wndproc w msg wparam lparam)
(define/private (stdret f d)
(if (is-dialog?) d f))
(define/override (wndproc w msg wParam lParam)
(cond
[(= msg WM_CLOSE)
(queue-window-event this (lambda ()
(when (on-close)
(direct-show #f))))
0]
[else (super wndproc w msg wparam lparam)]))
[(= msg WM_SIZE)
(unless (= wParam SIZE_MINIMIZED)
(queue-window-event this (lambda () (on-size 0 0))))
(stdret 0 1)]
[(= msg WM_MOVE)
(queue-window-event this (lambda () (on-size 0 0)))
0]
[(= msg WM_ACTIVATE)
(let ([state (LOWORD wParam)]
[minimized (HIWORD wParam)])
(unless (not (zero? minimized))
(let ([on? (or (= state WA_ACTIVE)
(= state WA_CLICKACTIVE))])
(when on? (set-frame-focus))
(queue-window-event this (lambda () (on-activate on?))))))
0]
[else (super wndproc w msg wParam lParam)]))
(define/public (on-close) (void))
@ -73,9 +98,9 @@
#t)
(define/override (get-x)
(RECT-left (GetWindowRect win32)))
(RECT-left (GetWindowRect hwnd)))
(define/override (get-y)
(RECT-top (GetWindowRect win32)))
(RECT-top (GetWindowRect hwnd)))
(def/public-unimplemented on-toolbar-click)
(def/public-unimplemented on-menu-click)
@ -85,7 +110,41 @@
(define/public (enforce-size min-x min-y max-x max-y step-x step-y)
(void))
(def/public-unimplemented on-activate)
(define focus-window-path #f)
(define/override (not-focus-child v)
(when (and focus-window-path
(memq v focus-window-path))
(set! focus-window-path #f)))
(define/override (set-top-focus win win-path child-hwnd)
(set! focus-window-path win-path)
(when (ptr-equal? hwnd (GetActiveWindow))
(SetFocus child-hwnd)))
(define/private (set-frame-focus)
(when focus-window-path
(SetFocus (send (last focus-window-path) get-hwnd))))
(define/override (child-can-accept-focus?)
#t)
(define/public (on-activate on?) (void))
(define/override (call-pre-on-event w e)
(pre-on-event w e))
(define/override (call-pre-on-char w e)
(pre-on-char w e))
(define dialog-level 0)
(define/public (frame-relative-dialog-status win)
(cond
[(is-dialog?) (let ([dl (send win get-dialog-level)])
(cond
[(= dl dialog-level) 'same]
[(dl . > . dialog-level) #f]
[else 'other]))]
[else #f]))
(def/public-unimplemented designate-root-frame)
(def/public-unimplemented system-menu)
(def/public-unimplemented set-modified)
@ -93,7 +152,9 @@
(def/public-unimplemented maximize)
(def/public-unimplemented iconized?)
(def/public-unimplemented get-menu-bar)
(def/public-unimplemented set-menu-bar)
(define/public (set-menu-bar mb) (void))
(def/public-unimplemented set-icon)
(def/public-unimplemented iconize)
(def/public-unimplemented set-title))

230
collects/mred/private/wx/win32/key.rkt Normal file
View File

@ -0,0 +1,230 @@
#lang racket/base
(require racket/class
ffi/unsafe
"utils.rkt"
"types.rkt"
"const.rkt"
"../common/event.rkt")
(provide make-key-event
generates-key-event?)
(define-user32 GetKeyState (_wfun _int -> _SHORT))
(define-user32 MapVirtualKeyW (_wfun _UINT _UINT -> _UINT))
(define-user32 VkKeyScanW (_wfun _WCHAR -> _SHORT))
(define (generates-key-event? msg)
(let ([message (MSG-message msg)])
(and (memq message (list WM_KEYDOWN WM_SYSKEYDOWN
WM_KEYUP WM_SYSKEYUP))
(make-key-event #t
(MSG-wParam msg)
(MSG-lParam msg)
#f
(or (= message WM_KEYUP)
(= message WM_SYSKEYUP))
(MSG-hwnd msg)))))
(define (THE_SCAN_CODE lParam)
(bitwise-and (arithmetic-shift lParam -16) #x1FF))
(define generic_ascii_code (make-hasheq))
;; The characters in find_shift_alts are things that we'll try
;; to include in keyboard events as char-if-Shift-weren't-pressed,
;; char-if-AltGr-weren't-pressed, etc.
(define other-key-codes
(let ([find_shift_alts (string-append
"!@#$%^&*()_+-=\\|[]{}:\";',.<>/?~`"
"abcdefghijklmnopqrstuvwxyz"
"ABCDEFGHIJKLMNOPQRSTUVWXYZ"
"0123456789")])
(list->vector
(for/list ([i (in-string find_shift_alts)])
(VkKeyScanW (char->integer i))))))
;; If a virtual key code has no mapping here, then the key should be
;; ignored by WM_KEYDOWN and processed by WM_CHAR instead
(define win32->symbol
(hasheq VK_CANCEL 'cancel
VK_BACK 'back
VK_TAB 'tab
VK_CLEAR 'clear
VK_RETURN 'return
VK_SHIFT 'shift
VK_CONTROL 'control
VK_MENU 'menu
VK_PAUSE 'pause
VK_SPACE 'space
VK_ESCAPE 'escape
VK_PRIOR 'prior
VK_NEXT 'next
VK_END 'end
VK_HOME 'home
VK_LEFT 'left
VK_UP 'up
VK_RIGHT 'right
VK_DOWN 'down
VK_SELECT 'select
VK_PRINT 'print
VK_EXECUTE 'execute
VK_INSERT 'insert
VK_DELETE 'delete
VK_HELP 'help
VK_NUMPAD0 'numpad0
VK_NUMPAD1 'numpad1
VK_NUMPAD2 'numpad2
VK_NUMPAD3 'numpad3
VK_NUMPAD4 'numpad4
VK_NUMPAD5 'numpad5
VK_NUMPAD6 'numpad6
VK_NUMPAD7 'numpad7
VK_NUMPAD8 'numpad8
VK_NUMPAD9 'numpad9
VK_MULTIPLY 'multiply
VK_ADD 'add
VK_SUBTRACT 'subtract
VK_DECIMAL 'decimal
VK_DIVIDE 'divide
VK_F1 'f1
VK_F2 'f2
VK_F3 'f3
VK_F4 'f4
VK_F5 'f5
VK_F6 'f6
VK_F7 'f7
VK_F8 'f8
VK_F9 'f9
VK_F10 'f10
VK_F11 'f11
VK_F12 'f12
VK_F13 'f13
VK_F14 'f14
VK_F15 'f15
VK_F16 'f16
VK_F17 'f17
VK_F18 'f18
VK_F19 'f19
VK_F20 'f20
VK_F21 'f21
VK_F22 'f22
VK_F23 'f23
VK_F24 'f24
VK_NUMLOCK 'numlock
VK_SCROLL 'scroll))
(define (make-key-event just-check? wParam lParam is-char? is-up? hwnd)
(let ([control-down? (not (zero? (arithmetic-shift (GetKeyState VK_CONTROL) -1)))]
[shift-down? (not (zero? (arithmetic-shift (GetKeyState VK_SHIFT) -1)))]
[caps-down? (not (zero? (arithmetic-shift (GetKeyState VK_CAPITAL) -1)))]
[alt-down? (= (bitwise-and (HIWORD lParam) KF_ALTDOWN) KF_ALTDOWN)])
(let-values ([(id other-shift other-altgr other-shift-altgr)
(if is-char?
;; wParam is a character
(let ([id wParam]
[sc (THE_SCAN_CODE lParam)])
;; Remember scan codes to help with some key-release events:
(when (byte? id)
(hash-set! generic_ascii_code id sc))
;; Look for elements of find_shift_alts that have a different
;; shift/AltGr state:
(let ([k (MapVirtualKeyW sc 1)])
(if (zero? k)
(values (integer->char id) #f #f #f)
(for/fold ([id id][s #f][a #f][sa #f]) ([o (in-vector other-key-codes)]
[j (in-naturals)])
(if (= (bitwise-and o #xFF) k)
;; Figure out whether it's different in the shift
;; for AltGr dimension, or both:
(if (eq? (zero? (bitwise-and o #x100)) shift-down?)
;; different Shift
(if (eq? (= (bitwise-and o #x600) #x6000)
(and control-down? alt-down?))
;; same AltGr
(values id o a sa)
;; different AltGr
(values id s a o))
;; same Shift
(if (eq? (= (bitwise-and o #x600) #x6000)
(and control-down? alt-down?))
;; same AltGr
(values id s a sa)
;; different AltGr
(values id s o sa)))
(values id s a sa))))))
;; wParam is a virtual key code
(let ([id (hash-ref win32->symbol wParam #f)]
[override-mapping? (and control-down? (not alt-down?))]
[try-generate-release
(lambda ()
(let ([sc (THE_SCAN_CODE lParam)])
(for/fold ([id #f]) ([i (in-range 256)] #:when (not id))
(and (equal? sc (hash-ref generic_ascii_code i #f))
(let ([id i])
(if (id . < . 127)
(char->integer (char-downcase (integer->char id)))
id))))))])
(if (not id)
(if (or override-mapping? is-up?)
;; Non-AltGr Ctl- combination, or a release event:
;; map manually, because the default mapping is
;; unsatisfactory
;; Set id to the unshifted key:
(let* ([id (bitwise-and (MapVirtualKeyW wParam 2) #xFFFF)]
[id (cond
[(zero? id) #f]
[(id . < . 128)
(char->integer (char-downcase (integer->char id)))]
[else id])])
(let-values ([(s a sa)
;; Look for shifted alternate:
(for/fold ([s #f][a #f][sa #f]) ([o (in-vector other-key-codes)]
[j (in-naturals)])
(if (= (bitwise-and o #xFF) wParam)
(if (not (zero? (bitwise-and o #x100)))
(if (= (bitwise-and o #x600) #x6000)
(values s a o)
(values o a sa))
(if (= (bitwise-and o #x600) #x6000)
(values s o sa)
(values s a sa)))
(values s a sa)))])
(if (and id shift-down?)
;; shift was pressed, so swap role of shifted and unshifted
(values s id sa a)
(values id s a sa))))
(values (try-generate-release) #f #f #f))
(cond
[(and (not is-up?) (= wParam VK_CONTROL))
;; Don't generate control-key down events:
(values #f #f #f #f)]
[(and (not override-mapping?) (not is-up?)
;; Let these get translated to WM_CHAR or skipped
;; entirely:
(memq wParam
(list VK_ESCAPE VK_SHIFT VK_CONTROL
VK_SPACE VK_RETURN VK_TAB VK_BACK)))
(values #f #f #f #f)]
[(and (not id) is-up?)
(values (try-generate-release) #f #f #f)]
[else
(values id #f #f #f)]))))])
(and id
(if just-check?
#t
(let* ([id (if (number? id) (integer->char id) id)]
[e (new key-event%
[key-code (if is-up?
'release
id)]
[shift-down shift-down?]
[control-down control-down?]
[meta-down #f]
[alt-down alt-down?]
[x 0]
[y 0]
[time-stamp 0]
[caps-down caps-down?])])
e))))))

2
collects/mred/private/wx/win32/menu-bar.rkt
View File

@ -9,5 +9,5 @@
(def/public-unimplemented number)
(def/public-unimplemented enable-top)
(def/public-unimplemented delete)
(def/public-unimplemented append)
(define/public (append m l) (void))
(super-new))

2
collects/mred/private/wx/win32/menu-item.rkt
View File

@ -5,5 +5,5 @@
(provide menu-item%)
(defclass menu-item% object%
(def/public-unimplemented id)
(define/public (id) this)
(super-new))

14
collects/mred/private/wx/win32/menu.rkt
View File

@ -5,6 +5,10 @@
(provide menu%)
(defclass menu% object%
(init label
callback
font)
(def/public-unimplemented select)
(def/public-unimplemented get-font)
(def/public-unimplemented set-width)
@ -15,8 +19,14 @@
(def/public-unimplemented enable)
(def/public-unimplemented check)
(def/public-unimplemented checked?)
(def/public-unimplemented append-separator)
(def/public-unimplemented delete-by-position)
(def/public-unimplemented delete)
(def/public-unimplemented append)
(public [append-item append])
(define (append-item i label help-str-or-submenu chckable?)
(void))
(define/public (append-separator)
(void))
(super-new))

6
collects/mred/private/wx/win32/panel.rkt
View File

@ -14,13 +14,13 @@
label)
(super-new [parent parent]
[win32
[hwnd
(CreateWindowExW 0
"PLTPanel"
#f
(bitwise-ior WS_CHILD)
0 0 w h
(send parent get-win32)
(send parent get-hwnd)
#f
hInstance
#f)]
@ -28,8 +28,6 @@
(def/public-unimplemented get-label-position)
(def/public-unimplemented set-label-position)
(def/public-unimplemented on-char)
(def/public-unimplemented on-event)
(def/public-unimplemented on-paint)
(define/public (set-item-cursor x y) (void))
(def/public-unimplemented get-item-cursor))

6
collects/mred/private/wx/win32/procs.rkt
View File

@ -52,7 +52,7 @@
(define-unimplemented find-graphical-system-path)
(define-unimplemented register-collecting-blit)
(define-unimplemented unregister-collecting-blit)
(define (shortcut-visible-in-label? ?) #t)
(define (shortcut-visible-in-label? [? #f]) #t)
(define-unimplemented location->window)
(define-unimplemented send-event)
(define-unimplemented file-creator-and-type)
@ -71,7 +71,9 @@
(set-box! xb 1024)
(set-box! yb 768))
(define-unimplemented bell)
(define-unimplemented hide-cursor)
(define (hide-cursor) (void))
(define-unimplemented end-busy-cursor)
(define-unimplemented is-busy?)
(define-unimplemented begin-busy-cursor)

114
collects/mred/private/wx/win32/queue.rkt
View File

@ -1,8 +1,13 @@
#lang racket/base
(require ffi/unsafe
racket/class
ffi/unsafe/alloc
ffi/unsafe/try-atomic
"utils.rkt"
"types.rkt"
"const.rkt"
"key.rkt"
"wndclass.rkt"
"../../lock.rkt"
"../common/queue.rkt")
@ -19,26 +24,33 @@
(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-user32 EnumThreadWindows (_wfun _DWORD _fpointer _LPARAM -> _BOOL))
(define-user32 GetWindow (_wfun _HWND _UINT -> _HWND))
(define-kernel32 GetCurrentThreadId (_wfun -> _DWORD))
(define _enum_proc (_wfun _HWND _LPARAM -> _BOOL))
(define-mz scheme_add_fd_eventmask (_fun _pointer _int -> _void))
(define msg (malloc _MSG 'raw))
(define free-msg
((deallocator)
(lambda (msg)
(free msg))))
(define malloc-msg
((allocator free-msg)
(lambda ()
(malloc _MSG 'raw))))
(define (events-ready?)
(not (zero? (GetQueueStatus QS_ALLINPUT))))
;; Check for events only since the last PeekMessage:
(not (zero? (LOWORD (GetQueueStatus QS_ALLINPUT)))))
(define (install-wakeup fds)
(pre-event-sync #t)
@ -47,17 +59,89 @@
(set-check-queue! events-ready?)
(set-queue-wakeup! install-wakeup)
(define other-peek-evt (make-semaphore))
(define peek-other-peek-evt (semaphore-peek-evt other-peek-evt))
(define (message-dequeue es hwnd)
;; Called in the eventspace for hwnd:
(let ([t (eventspace-extra-table es)]
[id (cast hwnd _HWND _long)])
(atomically (hash-remove! t id))
(let ([msg (malloc-msg)])
(let loop ()
(let ([v (PeekMessageW msg #f 0 0 PM_REMOVE)])
;; Since we called PeekMeessage in a thread other than the
;; event-pump thread, see `other-peek-evt' so the pump
;; knows to check again.
(unless (sync/timeout 0 peek-other-peek-evt)
(semaphore-post other-peek-evt))
;; Now handle the event:
(when v
(unless (generates-key-event? (cast msg _pointer _MSG-pointer))
(TranslateMessage msg))
(call-as-nonatomic-retry-point
(lambda ()
;; in atomic mode:
(DispatchMessageW msg)))
;; Maybe there's another event for this window:
(loop))))
(free-msg msg))))
(define (queue-message-dequeue es hwnd)
(let ([t (eventspace-extra-table es)]
[id (cast hwnd _HWND _long)])
(unless (hash-ref t id #f)
(hash-set! t id #t)
(queue-event es (lambda () (message-dequeue es hwnd))))))
;; For use only in the event-pump thread:
(define msg (malloc-msg))
(define (check-window-event hwnd data)
(let* ([root (let loop ([hwnd hwnd])
(let ([p (GetWindow hwnd GW_OWNER)])
(if p
(loop p)
hwnd)))]
[wx (any-hwnd->wx root)])
(if wx
;; One of our windows, so make sure its eventspace
;; asks for the message:
(let ([v (PeekMessageW msg hwnd 0 0 PM_NOREMOVE)])
(when v
(queue-message-dequeue (send wx get-eventspace)
hwnd)))
;; Not our window, so dispatch any available events
(let loop ()
(let ([v (PeekMessageW msg hwnd 0 0 PM_REMOVE)])
(when v
(TranslateMessage msg)
(DispatchMessageW msg)
(loop)))))
#f))
(define check_window_event (function-ptr check-window-event _enum_proc))
(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))))
;; Windows uses messages above #x4000 to hilite items in the task bar,
;; etc. In any case, these messages won't be handled by us, so they
;; can't trigger callbacks.
(let loop ()
(let ([v (PeekMessageW msg #f #x4000 #xFFFF PM_REMOVE)])
(when v
(TranslateMessage msg)
(DispatchMessageW msg)
(loop))))
;; Per-window checking lets us put an event in the right
;; eventspace:
(EnumThreadWindows (GetCurrentThreadId) check_window_event 0))
(define (win32-start-event-pump)
(thread (lambda ()
(let loop ()
(sync queue-evt)
(sync queue-evt other-peek-evt)
(as-entry dispatch-all-ready)
(loop)))))

23
collects/mred/private/wx/win32/types.rkt
View File

@ -12,7 +12,9 @@
_UINT
_BYTE
_LONG
_SHORT
_HRESULT
_WCHAR
_HINSTANCE
_HWND
@ -30,7 +32,11 @@
_permanent-string/utf-16
(struct-out POINT) _POINT _POINT-pointer
(struct-out RECT) _RECT _RECT-pointer)
(struct-out RECT) _RECT _RECT-pointer
(struct-out MSG) _MSG _MSG-pointer
HIWORD
LOWORD)
(define-syntax-rule (_wfun . a)
(_fun #:abi 'stdcall . a))
@ -44,6 +50,7 @@
(define _UINT _uint)
(define _BYTE _uint8)
(define _HRESULT _int32)
(define _WCHAR _int16)
(define _HINSTANCE (_cpointer/null 'HINSTANCE))
(define _HWND (_cpointer/null 'HWND))
@ -77,6 +84,7 @@
(cast p _pointer _string/utf-16)))))
(define _LONG _long)
(define _SHORT _short)
(define-cstruct _POINT ([x _LONG]
[y _LONG]))
@ -85,3 +93,16 @@
[top _LONG]
[right _LONG]
[bottom _LONG]))
(define-cstruct _MSG ([hwnd _HWND]
[message _UINT]
[wParam _WPARAM]
[lParam _LPARAM]
[time _DWORD]
[pt _POINT]))
(define (HIWORD v)
(arithmetic-shift v -16))
(define (LOWORD v)
(bitwise-and v #xFFFF))

13
collects/mred/private/wx/win32/utils.rkt
View File

@ -1,14 +1,16 @@
#lang racket/base
(require ffi/unsafe
ffi/unsafe/define
"../common/utils.rkt")
"../common/utils.rkt"
"types.rkt")
(provide define-gdi32
define-user32
define-kernel32
define-comctl32
define-uxtheme
define-mz)
define-mz
failed)
(define gdi32-lib (ffi-lib "gdi32.dll"))
(define user32-lib (ffi-lib "user32.dll"))
@ -21,3 +23,10 @@
(define-ffi-definer define-kernel32 kernel32-lib)
(define-ffi-definer define-comctl32 comctl32-lib)
(define-ffi-definer define-uxtheme uxtheme-lib)
(define-kernel32 GetLastError (_wfun -> _DWORD))
(define (failed w who)
(error who "call failed (~s)"
(GetLastError)))

211
collects/mred/private/wx/win32/window.rkt
View File

@ -3,12 +3,15 @@
racket/class
racket/draw
"../../syntax.rkt"
"../common/freeze.rkt"
"../common/queue.rkt"
"utils.rkt"
"types.rkt"
"const.rkt"
"wndclass.rkt"
"queue.rkt"
"theme.rkt")
"theme.rkt"
"key.rkt")
(provide window%
queue-window-event
@ -17,6 +20,8 @@
CreateWindowExW
GetWindowRect)
(define (unhide-cursor) (void))
(define-user32 CreateWindowExW (_wfun _DWORD
_string/utf-16
_string/utf-16
@ -24,16 +29,20 @@
_int _int _int _int
_HWND _HMENU _HINSTANCE _pointer
-> _HWND))
(define-user32 GetWindowRect (_wfun _HWND (r : (_ptr o _RECT)) -> _void -> r))
(define-user32 GetClientRect (_wfun _HWND (r : (_ptr o _RECT)) -> _void -> r))
(define-user32 GetWindowRect (_wfun _HWND (rect : (_ptr o _RECT)) -> (r : _BOOL) ->
(if r rect (failed 'GetWindowRect))))
(define-user32 GetClientRect (_wfun _HWND (rect : (_ptr o _RECT)) -> (r : _BOOL) ->
(if r rect (failed 'GetClientRect))))
(define-gdi32 CreateFontIndirectW (_wfun _LOGFONT-pointer -> _HFONT))
(define-user32 SendMessageW (_wfun _HWND _UINT _WPARAM _LPARAM -> _LRESULT))
(define-user32 MoveWindow(_wfun _HWND _int _int _int _int _BOOL -> _BOOL))
(define-user32 MoveWindow(_wfun _HWND _int _int _int _int _BOOL -> (r : _BOOL)
-> (unless r (failed 'MoveWindow))))
(define-user32 ShowWindow (_wfun _HWND _int -> (previously-shown? : _BOOL) -> (void)))
(define-user32 ShowWindow (_wfun _HWND _int -> _BOOL))
(define SW_SHOW 5)
(define SW_HIDE 0)
@ -48,38 +57,69 @@
(* 1/8 (arithmetic-shift v -16)))))
(defclass window% object%
(init-field parent win32)
(init-field parent hwnd)
(init style)
(super-new)
(define eventspace (current-eventspace))
(set-win32-wx! win32 this)
(set-hwnd-wx! hwnd this)
(unless (memq 'invisible style)
(show #t))
(define/public (get-win32) win32)
(define/public (get-client-win32) win32)
(define/public (get-hwnd) hwnd)
(define/public (get-client-hwnd) hwnd)
(define/public (get-eventspace) eventspace)
(define/public (wndproc w msg wparam lparam)
(DefWindowProcW w msg wparam lparam))
(define/public (wndproc w msg wParam lParam)
(cond
[(= msg WM_SETFOCUS)
(queue-window-event this (lambda () (on-set-focus)))
0]
[(= msg WM_KILLFOCUS)
(queue-window-event this (lambda () (on-kill-focus)))
0]
[(= msg WM_SYSKEYDOWN)
(when (or (= wParam VK_MENU) (= wParam VK_F4)) ;; F4 is close
(unhide-cursor)
(begin0
(DefWindowProcW w msg wParam lParam)
(do-key wParam lParam #f #f)))]
[(= msg WM_KEYDOWN)
(do-key wParam lParam #f #f)
0]
[(= msg WM_KEYUP)
(do-key wParam lParam #f #t)
0]
[(= msg WM_SYSCHAR)
(when (= wParam VK_MENU)
(unhide-cursor)
(begin0
(DefWindowProcW w msg wParam lParam)
(do-key wParam lParam #t #f)))]
[(= msg WM_CHAR)
(do-key wParam lParam #t #f)
0]
[else
(DefWindowProcW w msg wParam lParam)]))
(define/public (show on?)
(direct-show on?))
(define shown? #f)
(define/public (direct-show on?)
(void (ShowWindow win32 (if on? SW_SHOW SW_HIDE))))
(set! shown? (and on? #t))
(unless on? (not-focus-child this))
(ShowWindow hwnd (if on? SW_SHOW SW_HIDE)))
(unless (memq 'invisible style)
(show #t))
(def/public-unimplemented on-drop-file)
(def/public-unimplemented pre-on-event)
(def/public-unimplemented pre-on-char)
(def/public-unimplemented on-size)
(def/public-unimplemented on-set-focus)
(def/public-unimplemented on-kill-focus)
(def/public-unimplemented get-handle)
(define/public (on-size w h) (void))
(define/public (on-set-focus) (void))
(define/public (on-kill-focus) (void))
(define/public (get-handle) hwnd)
(define/public (is-window-enabled?)
#t)
@ -89,51 +129,54 @@
(send parent is-enabled-to-root?)))
(define/public (is-shown-to-root?)
(and (is-shown?)
(and shown?
(send parent is-shown-to-root?)))
(define/public (is-shown?)
#t)
shown?)
(def/public-unimplemented set-phantom-size)
(define/public (paint-children) (void))
(define/public (get-x)
(let ([r (GetWindowRect win32)])
(let ([r (GetWindowRect hwnd)])
(- (RECT-left r) (send parent get-x))))
(define/public (get-y)
(let ([r (GetWindowRect win32)])
(let ([r (GetWindowRect hwnd)])
(- (RECT-top r) (send parent get-y))))
(define/public (get-width)
(let ([r (GetWindowRect win32)])
(let ([r (GetWindowRect hwnd)])
(- (RECT-right r) (RECT-left r))))
(define/public (get-height)
(let ([r (GetWindowRect win32)])
(let ([r (GetWindowRect hwnd)])
(- (RECT-bottom r) (RECT-top r))))
(define/public (set-size x y w h)
(void
(if (or (= x -11111)
(= y -11111)
(= w -1)
(= h -1))
(let ([r (GetWindowRect win32)])
(MoveWindow win32
(if (= x -11111) (RECT-left r) x)
(if (= y -11111) (RECT-right r) y)
(if (= w -1) (- (RECT-right r) (RECT-left r)) w)
(if (= h -1) (- (RECT-bottom r) (RECT-top r)) h)
#t))
(MoveWindow win32 x y w h #t))))
(if (or (= x -11111)
(= y -11111)
(= w -1)
(= h -1))
(let ([r (GetWindowRect hwnd)])
(MoveWindow hwnd
(if (= x -11111) (RECT-left r) x)
(if (= y -11111) (RECT-right r) y)
(if (= w -1) (- (RECT-right r) (RECT-left r)) w)
(if (= h -1) (- (RECT-bottom r) (RECT-top r)) h)
#t))
(MoveWindow hwnd x y w h #t))
(on-size w h)
(unless (and (= w -1) (= h -1))
(on-resized))
(refresh))
(define/public (move x y)
(set-size x y -1 -1))
(define/public (auto-size label min-w min-h dw dh)
(unless theme-hfont
(set! theme-hfont (CreateFontIndirectW (get-theme-logfont))))
(SendMessageW win32 WM_SETFONT (cast theme-hfont _HFONT _LPARAM) 0)
(SendMessageW hwnd WM_SETFONT (cast theme-hfont _HFONT _LPARAM) 0)
(unless measure-dc
(let* ([bm (make-object bitmap% 1 1)]
[dc (make-object bitmap-dc% bm)]
@ -151,7 +194,9 @@
(define/public (get-parent) parent)
(def/public-unimplemented refresh)
(define/public (refresh) (void))
(define/public (on-resized) (void))
(def/public-unimplemented screen-to-client)
(def/public-unimplemented client-to-screen)
@ -162,16 +207,90 @@
(def/public-unimplemented get-position)
(define/public (get-client-size w h)
(let ([r (GetClientRect (get-client-win32))])
(let ([r (GetClientRect (get-client-hwnd))])
(set-box! w (- (RECT-right r) (RECT-left r)))
(set-box! h (- (RECT-bottom r) (RECT-top r)))))
(define/public (get-size w h)
(let ([r (GetWindowRect (get-client-hwnd))])
(set-box! w (- (RECT-right r) (RECT-left r)))
(set-box! h (- (RECT-bottom r) (RECT-top r)))))
(def/public-unimplemented get-size)
(def/public-unimplemented fit)
(def/public-unimplemented set-cursor)
(def/public-unimplemented set-focus)
(define/public (set-focus)
(when (can-accept-focus?)
(set-top-focus this null hwnd)))
(define/public (can-accept-focus?)
(child-can-accept-focus?))
(define/public (child-can-accept-focus?)
(and shown?
(send parent child-can-accept-focus?)))
(define/public (set-top-focus win win-path hwnd)
(send parent set-top-focus win (cons this win-path) hwnd))
(define/public (not-focus-child v)
(send parent not-focus-child v))
(def/public-unimplemented gets-focus?)
(def/public-unimplemented centre))
(def/public-unimplemented centre)
(define/private (do-key wParam lParam is-char? is-up?)
(let ([e (make-key-event #f wParam lParam is-char? is-up? hwnd)])
(and e
(if (definitely-wants-event? e)
(begin
(queue-window-event this (lambda () (dispatch-on-char/sync e)))
#t)
(constrained-reply (get-eventspace)
(lambda () (dispatch-on-char e #t))
#t)))))
(define/public (definitely-wants-event? e)
#f)
(define/public (dispatch-on-char/sync e)
(pre-event-refresh #t)
(dispatch-on-char e #f))
(define/public (dispatch-on-char e just-pre?)
(cond
[(other-modal? this) #t]
[(call-pre-on-char this e) #t]
[just-pre? #f]
[else (when (is-enabled-to-root?) (on-char e)) #t]))
(define/public (dispatch-on-event/sync e)
(pre-event-refresh #f)
(dispatch-on-event e #f))
(define/public (dispatch-on-event e just-pre?)
(cond
[(other-modal? this) #t]
[(call-pre-on-event this e) #t]
[just-pre? #f]
[else (when (is-enabled-to-root?) (on-event e)) #t]))
(define/public (call-pre-on-event w e)
(or (send parent call-pre-on-event w e)
(pre-on-event w e)))
(define/public (call-pre-on-char w e)
(or (send parent call-pre-on-char w e)
(pre-on-char w e)))
(define/public (pre-on-event w e) #f)
(define/public (pre-on-char w e) #f)
(define/public (on-char e) (void))
(define/public (on-event e) (void))
(define/private (pre-event-refresh key?)
;; Since we break the connection between the
;; Cocoa queue and event handling, we
;; re-sync the display in case a stream of
;; events (e.g., key repeat) have a corresponding
;; stream of screen updates.
(void)))
;; ----------------------------------------

30
collects/mred/private/wx/win32/wndclass.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base
(require ffi/unsafe
racket/class
"../../lock.rkt"
"utils.rkt"
"types.rkt"
"const.rkt"
@ -8,8 +9,9 @@
(provide hInstance
DefWindowProcW
win32->wx
set-win32-wx!
hwnd->wx
any-hwnd->wx
set-hwnd-wx!
MessageBoxW)
;; ----------------------------------------
@ -17,12 +19,26 @@
(define-user32 GetWindowLongW (_wfun _HWND _int -> _pointer))
(define-user32 SetWindowLongW (_wfun _HWND _int _pointer -> _pointer))
(define (win32->wx win32)
(let ([p (GetWindowLongW win32 GWLP_USERDATA)])
(define all-cells (make-hash))
(define (hwnd->wx hwnd)
(let ([p (GetWindowLongW hwnd GWLP_USERDATA)])
(and p (ptr-ref p _racket))))
(define (set-win32-wx! win32 wx)
(SetWindowLongW win32 GWLP_USERDATA (malloc-immobile-cell wx)))
(define (set-hwnd-wx! hwnd wx)
(let ([c (malloc-immobile-cell wx)])
(SetWindowLongW hwnd GWLP_USERDATA c)
(atomically (hash-set! all-cells (cast c _pointer _long) #t))))
(define (any-hwnd->wx hwnd)
(let ([p (GetWindowLongW hwnd GWLP_USERDATA)])
(and p
(atomically (hash-ref all-cells (cast p _pointer _long) #f))
(let ([wx (ptr-ref p _racket)])
(and wx
(ptr-equal? hwnd (send wx get-hwnd))
wx)))))
;; ----------------------------------------
@ -63,7 +79,7 @@
#;(define-user32 PostQuitMessage (_wfun _int -> _void))
(define (wind-proc w msg wparam lparam)
(let ([wx (win32->wx w)])
(let ([wx (hwnd->wx w)])
(if wx
(send wx wndproc w msg wparam lparam)
(DefWindowProcW w msg wparam lparam))))