win32: change HWND allocation and deallocation
This commit is contained in:
Matthew Flatt
parent
3bcfd5cf7f
commit
daf7f6dd17
|
|
@ -21,7 +21,6 @@
|
|||
(define base-button%
|
||||
(class item%
|
||||
(inherit set-control-font auto-size get-hwnd
|
||||
subclass-control
|
||||
remember-label-bitmap)
|
||||
|
||||
(init parent cb label x y w h style font)
|
||||
|
|
@ -38,20 +37,20 @@
|
|||
(super-new [callback cb]
|
||||
[parent parent]
|
||||
[hwnd
|
||||
(CreateWindowExW 0
|
||||
(get-class)
|
||||
(if (string? label)
|
||||
label
|
||||
"<image>")
|
||||
(bitwise-ior (get-flags) WS_CHILD WS_CLIPSIBLINGS
|
||||
(if bitmap?
|
||||
BS_BITMAP
|
||||
0))
|
||||
0 0 0 0
|
||||
(send parent get-client-hwnd)
|
||||
#f
|
||||
hInstance
|
||||
#f)]
|
||||
(CreateWindowExW/control 0
|
||||
(get-class)
|
||||
(if (string? label)
|
||||
label
|
||||
"<image>")
|
||||
(bitwise-ior (get-flags) WS_CHILD WS_CLIPSIBLINGS
|
||||
(if bitmap?
|
||||
BS_BITMAP
|
||||
0))
|
||||
0 0 0 0
|
||||
(send parent get-client-hwnd)
|
||||
#f
|
||||
hInstance
|
||||
#f)]
|
||||
[style style])
|
||||
|
||||
(when bitmap?
|
||||
|
|
@ -73,8 +72,6 @@
|
|||
(auto-size font label 60 20 12 0 #:scale-w 1.1 #:scale-h 1.1)]))
|
||||
(auto-size-button font label)
|
||||
|
||||
(subclass-control (get-hwnd))
|
||||
|
||||
(define/override (is-command? cmd)
|
||||
(= cmd BN_CLICKED))
|
||||
|
||||
|
|
|
|||
|
|
@ -82,7 +82,6 @@
|
|||
get-client-size
|
||||
get-eventspace
|
||||
set-control-font
|
||||
subclass-control
|
||||
is-auto-scroll? get-virtual-width get-virtual-height
|
||||
reset-auto-scroll
|
||||
refresh-for-autoscroll
|
||||
|
|
@ -122,18 +121,18 @@
|
|||
#f))
|
||||
(define combo-hwnd
|
||||
(and panel-hwnd
|
||||
(CreateWindowExW 0
|
||||
"PLTCOMBOBOX"
|
||||
""
|
||||
(bitwise-ior WS_CHILD WS_VISIBLE
|
||||
CBS_DROPDOWNLIST
|
||||
WS_HSCROLL WS_VSCROLL
|
||||
WS_BORDER WS_CLIPSIBLINGS)
|
||||
0 0 w h
|
||||
panel-hwnd
|
||||
#f
|
||||
hInstance
|
||||
#f)))
|
||||
(CreateWindowExW/control 0
|
||||
"PLTCOMBOBOX"
|
||||
""
|
||||
(bitwise-ior WS_CHILD WS_VISIBLE
|
||||
CBS_DROPDOWNLIST
|
||||
WS_HSCROLL WS_VSCROLL
|
||||
WS_BORDER WS_CLIPSIBLINGS)
|
||||
0 0 w h
|
||||
panel-hwnd
|
||||
#f
|
||||
hInstance
|
||||
#f)))
|
||||
|
||||
(define hwnd (or panel-hwnd canvas-hwnd))
|
||||
|
||||
|
|
@ -145,8 +144,7 @@
|
|||
[style style])
|
||||
|
||||
(when combo-hwnd
|
||||
(set-control-font #f combo-hwnd)
|
||||
(subclass-control combo-hwnd))
|
||||
(set-control-font #f combo-hwnd))
|
||||
|
||||
(define control-border-theme
|
||||
(and (memq 'control-border style)
|
||||
|
|
|
|||
|
|
@ -25,23 +25,22 @@
|
|||
x y w h
|
||||
choices style font)
|
||||
(inherit auto-size set-control-font
|
||||
set-size
|
||||
subclass-control)
|
||||
set-size)
|
||||
|
||||
(define callback cb)
|
||||
|
||||
(define hwnd
|
||||
(CreateWindowExW 0
|
||||
"PLTCOMBOBOX"
|
||||
label
|
||||
(bitwise-ior WS_CHILD CBS_DROPDOWNLIST
|
||||
WS_HSCROLL WS_VSCROLL
|
||||
WS_BORDER WS_CLIPSIBLINGS)
|
||||
0 0 0 0
|
||||
(send parent get-client-hwnd)
|
||||
#f
|
||||
hInstance
|
||||
#f))
|
||||
(CreateWindowExW/control 0
|
||||
"PLTCOMBOBOX"
|
||||
label
|
||||
(bitwise-ior WS_CHILD CBS_DROPDOWNLIST
|
||||
WS_HSCROLL WS_VSCROLL
|
||||
WS_BORDER WS_CLIPSIBLINGS)
|
||||
0 0 0 0
|
||||
(send parent get-client-hwnd)
|
||||
#f
|
||||
hInstance
|
||||
#f))
|
||||
|
||||
(define num-choices (length choices))
|
||||
|
||||
|
|
@ -66,8 +65,6 @@
|
|||
(set-size -11111 -11111 w (* h 8))))
|
||||
|
||||
|
||||
(subclass-control hwnd)
|
||||
|
||||
(define choice-dropped? #f)
|
||||
|
||||
(define/override (ctlproc w msg wParam lParam default)
|
||||
|
|
|
|||
|
|
@ -21,8 +21,7 @@
|
|||
|
||||
(define gauge%
|
||||
(class item%
|
||||
(inherit set-size
|
||||
subclass-control)
|
||||
(inherit set-size)
|
||||
|
||||
(init parent
|
||||
label
|
||||
|
|
@ -32,18 +31,18 @@
|
|||
font)
|
||||
|
||||
(define hwnd
|
||||
(CreateWindowExW 0
|
||||
"PLTmsctls_progress32"
|
||||
label
|
||||
(bitwise-ior WS_CHILD WS_CLIPSIBLINGS
|
||||
(if (memq 'vertical style)
|
||||
PBS_VERTICAL
|
||||
0))
|
||||
0 0 0 0
|
||||
(send parent get-client-hwnd)
|
||||
#f
|
||||
hInstance
|
||||
#f))
|
||||
(CreateWindowExW/control 0
|
||||
"PLTmsctls_progress32"
|
||||
label
|
||||
(bitwise-ior WS_CHILD WS_CLIPSIBLINGS
|
||||
(if (memq 'vertical style)
|
||||
PBS_VERTICAL
|
||||
0))
|
||||
0 0 0 0
|
||||
(send parent get-client-hwnd)
|
||||
#f
|
||||
hInstance
|
||||
#f))
|
||||
|
||||
(super-new [callback void]
|
||||
[parent parent]
|
||||
|
|
@ -56,8 +55,6 @@
|
|||
(set-size -11111 -11111 100 24)
|
||||
(set-size -11111 -11111 24 100))
|
||||
|
||||
(subclass-control hwnd)
|
||||
|
||||
(define/public (get-value)
|
||||
(SendMessageW hwnd PBM_GETPOS 0 0))
|
||||
(define/public (set-value v)
|
||||
|
|
|
|||
|
|
@ -22,19 +22,18 @@
|
|||
style
|
||||
label)
|
||||
|
||||
(inherit auto-size set-control-font
|
||||
subclass-control)
|
||||
(inherit auto-size set-control-font)
|
||||
|
||||
(define hwnd
|
||||
(CreateWindowExW 0
|
||||
"PLTBUTTON"
|
||||
(or label "")
|
||||
(bitwise-ior BS_GROUPBOX WS_CHILD WS_CLIPSIBLINGS)
|
||||
0 0 0 0
|
||||
(send parent get-client-hwnd)
|
||||
#f
|
||||
hInstance
|
||||
#f))
|
||||
(CreateWindowExW/control 0
|
||||
"PLTBUTTON"
|
||||
(or label "")
|
||||
(bitwise-ior BS_GROUPBOX WS_CHILD WS_CLIPSIBLINGS)
|
||||
0 0 0 0
|
||||
(send parent get-client-hwnd)
|
||||
#f
|
||||
hInstance
|
||||
#f))
|
||||
|
||||
(define client-hwnd
|
||||
(CreateWindowExW 0
|
||||
|
|
@ -63,7 +62,6 @@
|
|||
(lambda (w h)
|
||||
(set! label-h h)
|
||||
(set-size -11111 -11111 (+ w 10) (+ h 10))))
|
||||
(subclass-control hwnd)
|
||||
|
||||
(define/public (set-label lbl)
|
||||
(SetWindowTextW hwnd lbl))
|
||||
|
|
|
|||
|
|
@ -16,17 +16,6 @@
|
|||
(protect-out item-mixin
|
||||
item%))
|
||||
|
||||
(define (control-proc w msg wParam lParam)
|
||||
(let ([wx (hwnd->wx w)])
|
||||
(if wx
|
||||
(send wx ctlproc w msg wParam lParam
|
||||
(lambda (w msg wParam lParam)
|
||||
((hwnd->ctlproc w) w msg wParam lParam)))
|
||||
(let ([default-ctlproc (hwnd->ctlproc w)])
|
||||
(default-ctlproc w msg wParam lParam)))))
|
||||
|
||||
(define control_proc (function-ptr control-proc _WndProc))
|
||||
|
||||
(define (item-mixin %)
|
||||
(class %
|
||||
(inherit on-set-focus
|
||||
|
|
@ -40,11 +29,6 @@
|
|||
|
||||
(super-new)
|
||||
|
||||
(define/public (subclass-control hwnd)
|
||||
(let ([old-control-proc (function-ptr (GetWindowLongW hwnd GWLP_WNDPROC) _WndProc)])
|
||||
(set-hwnd-ctlproc! hwnd old-control-proc)
|
||||
(SetWindowLongW hwnd GWLP_WNDPROC control_proc)))
|
||||
|
||||
(define/public (ctlproc w msg wParam lParam default)
|
||||
(if (try-mouse w msg wParam lParam)
|
||||
0
|
||||
|
|
|
|||
|
|
@ -54,7 +54,6 @@
|
|||
font label-font)
|
||||
|
||||
(inherit set-size set-control-font
|
||||
subclass-control
|
||||
get-client-size)
|
||||
|
||||
(define single?
|
||||
|
|
@ -62,22 +61,22 @@
|
|||
(not (memq 'mutiple style))))
|
||||
|
||||
(define hwnd
|
||||
(CreateWindowExW WS_EX_CLIENTEDGE
|
||||
"PLTLISTBOX"
|
||||
label
|
||||
(bitwise-ior WS_CHILD WS_CLIPSIBLINGS LBS_NOTIFY
|
||||
WS_VSCROLL
|
||||
(if (memq 'hscroll style) WS_HSCROLL 0)
|
||||
(cond
|
||||
;; Win32 sense of "multiple" and "extended" is backwards
|
||||
[(eq? kind 'extended) LBS_MULTIPLESEL]
|
||||
[(eq? kind 'multiple) LBS_EXTENDEDSEL]
|
||||
[else 0]))
|
||||
0 0 0 0
|
||||
(send parent get-client-hwnd)
|
||||
#f
|
||||
hInstance
|
||||
#f))
|
||||
(CreateWindowExW/control WS_EX_CLIENTEDGE
|
||||
"PLTLISTBOX"
|
||||
label
|
||||
(bitwise-ior WS_CHILD WS_CLIPSIBLINGS LBS_NOTIFY
|
||||
WS_VSCROLL
|
||||
(if (memq 'hscroll style) WS_HSCROLL 0)
|
||||
(cond
|
||||
;; Win32 sense of "multiple" and "extended" is backwards
|
||||
[(eq? kind 'extended) LBS_MULTIPLESEL]
|
||||
[(eq? kind 'multiple) LBS_EXTENDEDSEL]
|
||||
[else 0]))
|
||||
0 0 0 0
|
||||
(send parent get-client-hwnd)
|
||||
#f
|
||||
hInstance
|
||||
#f))
|
||||
|
||||
(for ([s (in-list choices)])
|
||||
(SendMessageW/str hwnd LB_ADDSTRING 0 s))
|
||||
|
|
@ -90,8 +89,6 @@
|
|||
(set-control-font font)
|
||||
(set-size -11111 -11111 40 60)
|
||||
|
||||
(subclass-control hwnd)
|
||||
|
||||
(define callback cb)
|
||||
|
||||
(define/override (is-command? cmd)
|
||||
|
|
|
|||
|
|
@ -65,7 +65,6 @@
|
|||
(define message%
|
||||
(class item%
|
||||
(inherit auto-size set-size set-control-font get-hwnd
|
||||
subclass-control
|
||||
remember-label-bitmap)
|
||||
|
||||
(init parent label
|
||||
|
|
@ -81,26 +80,24 @@
|
|||
(super-new [callback void]
|
||||
[parent parent]
|
||||
[hwnd
|
||||
(CreateWindowExW 0
|
||||
(get-class)
|
||||
(if (string? label)
|
||||
label
|
||||
"<image>")
|
||||
(bitwise-ior SS_LEFT WS_CHILD WS_CLIPSIBLINGS
|
||||
(if bitmap?
|
||||
SS_BITMAP
|
||||
(if (symbol? label)
|
||||
SS_ICON
|
||||
0)))
|
||||
0 0 0 0
|
||||
(send parent get-client-hwnd)
|
||||
#f
|
||||
hInstance
|
||||
#f)]
|
||||
(CreateWindowExW/control 0
|
||||
(get-class)
|
||||
(if (string? label)
|
||||
label
|
||||
"<image>")
|
||||
(bitwise-ior SS_LEFT WS_CHILD WS_CLIPSIBLINGS
|
||||
(if bitmap?
|
||||
SS_BITMAP
|
||||
(if (symbol? label)
|
||||
SS_ICON
|
||||
0)))
|
||||
0 0 0 0
|
||||
(send parent get-client-hwnd)
|
||||
#f
|
||||
hInstance
|
||||
#f)]
|
||||
[style style])
|
||||
|
||||
(subclass-control (get-hwnd))
|
||||
|
||||
(when bitmap?
|
||||
(let ([hbitmap (bitmap->hbitmap label)])
|
||||
(remember-label-bitmap hbitmap)
|
||||
|
|
|
|||
|
|
@ -30,7 +30,6 @@
|
|||
|
||||
(inherit auto-size set-control-font
|
||||
is-enabled-to-root?
|
||||
subclass-control
|
||||
set-focus)
|
||||
|
||||
(define callback cb)
|
||||
|
|
@ -59,20 +58,20 @@
|
|||
[bitmap? (and (label . is-a? . bitmap%)
|
||||
(send label ok?))]
|
||||
[radio-hwnd
|
||||
(CreateWindowExW 0
|
||||
"PLTBUTTON"
|
||||
(if (string? label)
|
||||
label
|
||||
"<image>")
|
||||
(bitwise-ior BS_RADIOBUTTON WS_CHILD WS_CLIPSIBLINGS
|
||||
(if bitmap?
|
||||
BS_BITMAP
|
||||
0))
|
||||
0 0 0 0
|
||||
hwnd
|
||||
#f
|
||||
hInstance
|
||||
#f)])
|
||||
(CreateWindowExW/control 0
|
||||
"PLTBUTTON"
|
||||
(if (string? label)
|
||||
label
|
||||
"<image>")
|
||||
(bitwise-ior BS_RADIOBUTTON WS_CHILD WS_CLIPSIBLINGS
|
||||
(if bitmap?
|
||||
BS_BITMAP
|
||||
0))
|
||||
0 0 0 0
|
||||
hwnd
|
||||
#f
|
||||
hInstance
|
||||
#f)])
|
||||
(when bitmap?
|
||||
(let ([hbitmap (bitmap->hbitmap label)])
|
||||
(set! label-bitmaps (cons hbitmap label-bitmaps))
|
||||
|
|
@ -96,9 +95,6 @@
|
|||
[hwnd hwnd]
|
||||
[extra-hwnds radio-hwnds]
|
||||
[style style])
|
||||
|
||||
(for ([radio-hwnd (in-list radio-hwnds)])
|
||||
(subclass-control radio-hwnd))
|
||||
|
||||
(define/override (is-hwnd? a-hwnd)
|
||||
(or (ptr-equal? hwnd a-hwnd)
|
||||
|
|
|
|||
|
|
@ -40,8 +40,7 @@
|
|||
style
|
||||
font)
|
||||
(inherit set-control-font
|
||||
auto-size
|
||||
subclass-control)
|
||||
auto-size)
|
||||
|
||||
(define callback cb)
|
||||
(define vertical? (memq 'vertical style))
|
||||
|
|
@ -79,15 +78,15 @@
|
|||
|
||||
(define value-hwnd
|
||||
(and panel-hwnd
|
||||
(CreateWindowExW 0
|
||||
"STATIC"
|
||||
(format "~s" val)
|
||||
(bitwise-ior SS_CENTER WS_CHILD WS_CLIPSIBLINGS WS_VISIBLE)
|
||||
0 0 0 0
|
||||
panel-hwnd
|
||||
#f
|
||||
hInstance
|
||||
#f)))
|
||||
(CreateWindowExW/control 0
|
||||
"STATIC"
|
||||
(format "~s" val)
|
||||
(bitwise-ior SS_CENTER WS_CHILD WS_CLIPSIBLINGS WS_VISIBLE)
|
||||
0 0 0 0
|
||||
panel-hwnd
|
||||
#f
|
||||
hInstance
|
||||
#f)))
|
||||
|
||||
(define hwnd (or panel-hwnd slider-hwnd))
|
||||
|
||||
|
|
@ -129,8 +128,6 @@
|
|||
(SendMessageW slider-hwnd TBM_SETRANGE 1 (MAKELPARAM lo hi))
|
||||
(set-value val)
|
||||
|
||||
(subclass-control slider-hwnd)
|
||||
|
||||
(define/override (set-size x y w h)
|
||||
(super set-size x y w h)
|
||||
(when panel-hwnd
|
||||
|
|
|
|||
|
|
@ -45,19 +45,18 @@
|
|||
(define callback void)
|
||||
|
||||
(inherit auto-size set-control-font
|
||||
is-shown-to-root?
|
||||
subclass-control)
|
||||
is-shown-to-root?)
|
||||
|
||||
(define hwnd
|
||||
(CreateWindowExW 0
|
||||
"PLTSysTabControl32"
|
||||
""
|
||||
(bitwise-ior WS_CHILD WS_CLIPSIBLINGS)
|
||||
0 0 0 0
|
||||
(send parent get-client-hwnd)
|
||||
#f
|
||||
hInstance
|
||||
#f))
|
||||
(CreateWindowExW/control 0
|
||||
"PLTSysTabControl32"
|
||||
""
|
||||
(bitwise-ior WS_CHILD WS_CLIPSIBLINGS)
|
||||
0 0 0 0
|
||||
(send parent get-client-hwnd)
|
||||
#f
|
||||
hInstance
|
||||
#f))
|
||||
|
||||
(define client-hwnd
|
||||
(CreateWindowExW 0
|
||||
|
|
@ -76,8 +75,6 @@
|
|||
[hwnd hwnd]
|
||||
[style style])
|
||||
|
||||
(subclass-control hwnd)
|
||||
|
||||
(define/override (get-client-hwnd)
|
||||
client-hwnd)
|
||||
|
||||
|
|
|
|||
|
|
@ -19,11 +19,6 @@
|
|||
|
||||
GetLastError
|
||||
|
||||
DestroyWindow
|
||||
NotifyWindowDestroy
|
||||
CreateWindowExW
|
||||
clean-up-destroyed
|
||||
|
||||
GetWindowLongW
|
||||
SetWindowLongW
|
||||
SendMessageW SendMessageW/str
|
||||
|
|
@ -71,23 +66,6 @@
|
|||
(error who "call failed (~s)"
|
||||
(GetLastError)))
|
||||
|
||||
(define-user32 DestroyWindow (_wfun _HWND -> (r : _BOOL)
|
||||
-> (unless r (failed 'DestroyWindow)))
|
||||
#:wrap (deallocator))
|
||||
(define NotifyWindowDestroy ((deallocator) void))
|
||||
|
||||
(define (clean-up-destroyed)
|
||||
(free-remembered-now DestroyWindow))
|
||||
|
||||
(define-user32 CreateWindowExW (_wfun _DWORD
|
||||
_string/utf-16
|
||||
_string/utf-16
|
||||
_UDWORD
|
||||
_int _int _int _int
|
||||
_HWND _HMENU _HINSTANCE _pointer
|
||||
-> _HWND)
|
||||
#:wrap (allocator remember-to-free-later))
|
||||
|
||||
(define-user32 GetWindowLongW (_wfun _HWND _int -> _pointer))
|
||||
(define-user32 SetWindowLongW (_wfun _HWND _int _pointer -> _pointer))
|
||||
|
||||
|
|
|
|||
|
|
@ -143,11 +143,6 @@
|
|||
(if (try-mouse w msg wParam lParam)
|
||||
0
|
||||
(cond
|
||||
[(= msg WM_DESTROY)
|
||||
;; release immobile cell
|
||||
(unregister-hwnd w)
|
||||
;; so it won't be finalized:
|
||||
(NotifyWindowDestroy w)]
|
||||
[(= msg WM_SETFOCUS)
|
||||
(queue-window-event this (lambda () (on-set-focus)))
|
||||
0]
|
||||
|
|
|
|||
|
|
@ -1,7 +1,9 @@
|
|||
#lang racket/base
|
||||
(require ffi/unsafe
|
||||
ffi/unsafe/alloc
|
||||
racket/class
|
||||
"../../lock.rkt"
|
||||
"../common/utils.rkt"
|
||||
"utils.rkt"
|
||||
"types.rkt"
|
||||
"const.rkt"
|
||||
|
|
@ -12,11 +14,12 @@
|
|||
DefWindowProcW
|
||||
background-hbrush
|
||||
set-hwnd-wx!
|
||||
set-hwnd-ctlproc!
|
||||
hwnd->wx
|
||||
hwnd->ctlproc
|
||||
any-hwnd->wx
|
||||
unregister-hwnd
|
||||
CreateWindowExW
|
||||
CreateWindowExW/control
|
||||
clean-up-destroyed
|
||||
MessageBoxW
|
||||
_WndProc))
|
||||
|
||||
|
|
@ -32,50 +35,69 @@
|
|||
;; | (cons <ctlproc> <wx-weak-box>)
|
||||
;; <wx-weak-box> = (make-weak-box <object%>)
|
||||
|
||||
(define all-cells (make-hash))
|
||||
(define all-hwnds (make-hash))
|
||||
|
||||
;; call in atomic mode:
|
||||
(define (register-hwnd! hwnd)
|
||||
(hash-set! all-hwnds (cast hwnd _pointer _long) #t))
|
||||
|
||||
;; call in atomic mode:
|
||||
(define (alloc-hwnd-cell hwnd)
|
||||
(let ([c (GetWindowLongW hwnd GWLP_USERDATA)])
|
||||
(or c
|
||||
(let ([c (malloc-immobile-cell #f)])
|
||||
(SetWindowLongW hwnd GWLP_USERDATA c)
|
||||
c))))
|
||||
|
||||
(define (set-hwnd-wx! hwnd wx)
|
||||
(let ([c (malloc-immobile-cell (make-weak-box wx))])
|
||||
(SetWindowLongW hwnd GWLP_USERDATA c)
|
||||
(atomically (hash-set! all-cells (cast c _pointer _long) #t))))
|
||||
(let* ([c (atomically (alloc-hwnd-cell hwnd))]
|
||||
[v (ptr-ref c _racket)])
|
||||
(ptr-set! c _racket (cons wx (and v (cdr v))))))
|
||||
|
||||
(define (set-hwnd-ctlproc! hwnd ctlproc)
|
||||
(let ([p (GetWindowLongW hwnd GWLP_USERDATA)])
|
||||
(ptr-set! p _racket (cons (ptr-ref p _racket) ctlproc))))
|
||||
(let* ([c (atomically (alloc-hwnd-cell hwnd))]
|
||||
[v (ptr-ref c _racket)])
|
||||
(ptr-set! c _racket (cons (and v (car v)) ctlproc))))
|
||||
|
||||
(define (hwnd->wx hwnd)
|
||||
(let ([p (GetWindowLongW hwnd GWLP_USERDATA)])
|
||||
(and p (let ([wb (ptr-ref p _racket)])
|
||||
(let ([c (GetWindowLongW hwnd GWLP_USERDATA)])
|
||||
(and c (let ([wb (ptr-ref c _racket)])
|
||||
(and wb
|
||||
(weak-box-value (if (pair? wb)
|
||||
(car wb)
|
||||
wb)))))))
|
||||
|
||||
(define (hwnd->ctlproc hwnd)
|
||||
(let ([p (GetWindowLongW hwnd GWLP_USERDATA)])
|
||||
(and p (let ([wb (ptr-ref p _racket)])
|
||||
(let ([c (GetWindowLongW hwnd GWLP_USERDATA)])
|
||||
(and c (let ([wb (ptr-ref c _racket)])
|
||||
(and wb
|
||||
(pair? wb)
|
||||
(cdr wb))))))
|
||||
|
||||
(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 (let ([wb (ptr-ref p _racket)])
|
||||
(and wb
|
||||
(weak-box-value (if (pair? wb)
|
||||
(car wb)
|
||||
wb))))])
|
||||
(and wx
|
||||
(send wx is-hwnd? hwnd)
|
||||
wx)))))
|
||||
(and
|
||||
(atomically (hash-ref all-hwnds (cast hwnd _pointer _long) #f))
|
||||
(let ([c (GetWindowLongW hwnd GWLP_USERDATA)])
|
||||
(and c
|
||||
(let ([wx (let ([wb (ptr-ref c _racket)])
|
||||
(and wb
|
||||
(weak-box-value (if (pair? wb)
|
||||
(car wb)
|
||||
wb))))])
|
||||
(and wx
|
||||
(send wx is-hwnd? hwnd)
|
||||
wx))))))
|
||||
|
||||
(define (unregister-hwnd hwnd)
|
||||
(let ([p (GetWindowLongW hwnd GWLP_USERDATA)])
|
||||
(when p
|
||||
(free-immobile-cell p)
|
||||
(SetWindowLongW hwnd GWLP_USERDATA #f))))
|
||||
;; call in atomic mode:
|
||||
(define (unregister-hwnd? hwnd)
|
||||
(let ([addr (cast hwnd _pointer _long)])
|
||||
(and (hash-ref all-hwnds addr #f)
|
||||
(let ([c (GetWindowLongW hwnd GWLP_USERDATA)])
|
||||
(when c
|
||||
(free-immobile-cell c)
|
||||
(hash-ref all-hwnds addr #f)
|
||||
(SetWindowLongW hwnd GWLP_USERDATA #f)
|
||||
#t)))))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
|
@ -95,6 +117,74 @@
|
|||
(define _WndProc (_wfun #:atomic? #t #:keep (box null)
|
||||
_HWND _UINT _WPARAM _LPARAM -> _LRESULT))
|
||||
|
||||
(define (wind-proc w msg wparam lparam)
|
||||
(if (= msg WM_DESTROY)
|
||||
(begin
|
||||
(unregister-hwnd? w)
|
||||
(DefWindowProcW w msg wparam lparam))
|
||||
(let ([wx (hwnd->wx w)])
|
||||
(if wx
|
||||
(send wx wndproc w msg wparam lparam DefWindowProcW)
|
||||
(DefWindowProcW w msg wparam lparam)))))
|
||||
|
||||
(define wind-proc-ptr (function-ptr wind-proc _WndProc))
|
||||
|
||||
(define (control-proc w msg wParam lParam)
|
||||
(if (= msg WM_DESTROY)
|
||||
(let ([default-ctlproc (hwnd->ctlproc w)])
|
||||
(unregister-hwnd? w)
|
||||
(default-ctlproc w))
|
||||
(let ([wx (hwnd->wx w)])
|
||||
(if wx
|
||||
(send wx ctlproc w msg wParam lParam
|
||||
(lambda (w msg wParam lParam)
|
||||
((hwnd->ctlproc w) w msg wParam lParam)))
|
||||
(let ([default-ctlproc (hwnd->ctlproc w)])
|
||||
(default-ctlproc w msg wParam lParam))))))
|
||||
|
||||
(define control_proc (function-ptr control-proc _WndProc))
|
||||
|
||||
(define (subclass-control hwnd)
|
||||
(let ([old-control-proc (function-ptr (GetWindowLongW hwnd GWLP_WNDPROC) _WndProc)])
|
||||
(set-hwnd-ctlproc! hwnd old-control-proc)
|
||||
(SetWindowLongW hwnd GWLP_WNDPROC control_proc)))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define-user32 DestroyWindow (_wfun _HWND -> (r : _BOOL)
|
||||
-> (unless r (failed 'DestroyWindow))))
|
||||
|
||||
(define (maybe-destroy-window hwnd)
|
||||
(atomically
|
||||
(when (unregister-hwnd? hwnd)
|
||||
(DestroyWindow hwnd))))
|
||||
|
||||
(define (clean-up-destroyed)
|
||||
(free-remembered-now maybe-destroy-window))
|
||||
|
||||
(define-user32 _CreateWindowExW (_wfun _DWORD
|
||||
_string/utf-16
|
||||
_string/utf-16
|
||||
_UDWORD
|
||||
_int _int _int _int
|
||||
_HWND _HMENU _HINSTANCE _pointer
|
||||
-> _HWND)
|
||||
#:c-id CreateWindowExW)
|
||||
|
||||
(define (make-CreateWindowEx register!)
|
||||
((allocator remember-to-free-later)
|
||||
(lambda (dwExStyle lpClassName lpWindowName dwStyle x y nWidth nHeight hWndParent hMenu hInstance lpParam)
|
||||
(let ([hwnd (_CreateWindowExW dwExStyle lpClassName lpWindowName dwStyle x y nWidth nHeight hWndParent hMenu hInstance lpParam)])
|
||||
(register-hwnd! hwnd)
|
||||
hwnd))))
|
||||
|
||||
(define CreateWindowExW (make-CreateWindowEx register-hwnd!))
|
||||
(define CreateWindowExW/control (make-CreateWindowEx (lambda (hwnd)
|
||||
(register-hwnd! hwnd)
|
||||
(subclass-control hwnd))))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define-cstruct _WNDCLASS ([style _UINT]
|
||||
[lpfnWndProc _fpointer]
|
||||
[cbClsExtra _int]
|
||||
|
|
@ -120,14 +210,6 @@
|
|||
|
||||
#;(define-user32 PostQuitMessage (_wfun _int -> _void))
|
||||
|
||||
(define (wind-proc w msg wparam lparam)
|
||||
(let ([wx (hwnd->wx w)])
|
||||
(if wx
|
||||
(send wx wndproc w msg wparam lparam DefWindowProcW)
|
||||
(DefWindowProcW w msg wparam lparam))))
|
||||
|
||||
(define wind-proc-ptr (function-ptr wind-proc _WndProc))
|
||||
|
||||
(define hInstance (GetModuleHandleW #f))
|
||||
|
||||
(define background-hbrush (let ([p (ptr-add #f (+ COLOR_BTNFACE 1))])
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user