diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index dc22282926..759b4c4032 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -330,15 +330,21 @@ (GetScrollPos canvas-hwnd SB_VERT)) (define/public (get-scroll-pos which) - (GetScrollPos canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))) + (if (is-auto-scroll?) + 0 + (GetScrollPos canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ)))) (define/public (get-scroll-range which) - (let ([i (GetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) - (+ (- (SCROLLINFO-nMax i) - (SCROLLINFO-nPage i)) - 1))) + (if (is-auto-scroll?) + 0 + (let ([i (GetScrollInfo canvas-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 canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) - (SCROLLINFO-nPage i))) + (if (is-auto-scroll?) + 0 + (let ([i (GetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) + (SCROLLINFO-nPage i)))) (define/public (set-scroll-pos which v) (void (SetScrollPos canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) v #t))) @@ -445,7 +451,7 @@ (set-scroll-pos 'vertical (->long (* y (get-scroll-range 'vertical))))) (when (is-auto-scroll?) (refresh-for-autoscroll))) - (def/public-unimplemented warp-pointer) + (define/public (warp-pointer x y) (void)) (define/public (set-resize-corner on?) (void)) diff --git a/collects/mred/private/wx/win32/choice.rkt b/collects/mred/private/wx/win32/choice.rkt index 5eff9838e3..4a045e7ac1 100644 --- a/collects/mred/private/wx/win32/choice.rkt +++ b/collects/mred/private/wx/win32/choice.rkt @@ -94,7 +94,7 @@ (define/public (set-selection i) - (SendMessageW hwnd CB_SETCURSEL i 0)) + (void (SendMessageW hwnd CB_SETCURSEL i 0))) (define/public (get-selection) (SendMessageW hwnd CB_GETCURSEL 0 0)) diff --git a/collects/mred/private/wx/win32/list-box.rkt b/collects/mred/private/wx/win32/list-box.rkt index df223e2ff2..9510d8e338 100644 --- a/collects/mred/private/wx/win32/list-box.rkt +++ b/collects/mred/private/wx/win32/list-box.rkt @@ -56,9 +56,7 @@ (inherit set-size set-control-font get-client-size) - (define single? - (and (not (memq 'extended style)) - (not (memq 'mutiple style)))) + (define single? (eq? 'single kind)) (define hwnd (CreateWindowExW/control WS_EX_CLIENTEDGE @@ -115,10 +113,11 @@ (define/public (set-string i str) (atomically (SendMessageW/str hwnd LB_INSERTSTRING i str) - (SendMessageW hwnd LB_DELETESTRING (add1 i) 0))) + (SendMessageW hwnd LB_DELETESTRING (add1 i) 0) + (void))) (define/public (set-first-visible-item i) - (SendMessageW hwnd LB_SETTOPINDEX i 0)) + (void (SendMessageW hwnd LB_SETTOPINDEX i 0))) (define/public (get-first-item) (SendMessageW hwnd LB_GETTOPINDEX 0 0)) @@ -134,7 +133,7 @@ (atomically (set! data null) (set! num 0) - (SendMessageW hwnd LB_RESETCONTENT 0 0))) + (void (SendMessageW hwnd LB_RESETCONTENT 0 0)))) (define/public (set choices) (atomically @@ -157,7 +156,7 @@ (atomically (set! data (append (take data i) (drop data (add1 i)))) (set! num (sub1 num)) - (SendMessageW hwnd LB_DELETESTRING i 0))) + (void (SendMessageW hwnd LB_DELETESTRING i 0)))) (define/public (get-selections) (atomically @@ -186,14 +185,15 @@ (not (zero? (SendMessageW hwnd LB_GETSEL i 0)))) (define/public (select i [on? #t] [extend? #t]) - (if single? - (SendMessageW hwnd LB_SETCURSEL (if on? i -1) 0) - (begin - (when extend? - (SendMessageW hwnd LB_SELITEMRANGE 0 (MAKELPARAM 0 num))) - (SendMessageW hwnd LB_SETSEL (if on? 1 0) i)))) + (void + (if single? + (SendMessageW hwnd LB_SETCURSEL (if on? i -1) 0) + (begin + (when extend? + (SendMessageW hwnd LB_SELITEMRANGE 0 (MAKELPARAM 0 num))) + (SendMessageW hwnd LB_SETSEL (if on? 1 0) i))))) (define/public (set-selection i) - (select i #t #f)) + (void (select i #t #f))) (def/public-unimplemented get-label-font))) diff --git a/collects/mred/private/wx/win32/wndclass.rkt b/collects/mred/private/wx/win32/wndclass.rkt index c41a49436a..1f0da158d4 100644 --- a/collects/mred/private/wx/win32/wndclass.rkt +++ b/collects/mred/private/wx/win32/wndclass.rkt @@ -39,7 +39,7 @@ ;; call in atomic mode: (define (register-hwnd! hwnd) - (hash-set! all-hwnds (cast hwnd _pointer _long) #t)) + (hash-set! all-hwnds (cast hwnd _pointer _long) hwnd)) ;; call in atomic mode: (define (alloc-hwnd-cell hwnd) @@ -52,27 +52,26 @@ (define (set-hwnd-wx! hwnd wx) (let* ([c (atomically (alloc-hwnd-cell hwnd))] [v (ptr-ref c _racket)]) - (ptr-set! c _racket (cons wx (and v (cdr v)))))) + (ptr-set! c _racket (cons (make-weak-box wx) + (and v (cdr v)))))) (define (set-hwnd-ctlproc! hwnd ctlproc) (let* ([c (atomically (alloc-hwnd-cell hwnd))] [v (ptr-ref c _racket)]) - (ptr-set! c _racket (cons (and v (car v)) ctlproc)))) + (ptr-set! c _racket (cons (and v (car v)) + ctlproc)))) (define (hwnd->wx hwnd) (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))))))) + (car wb) + (weak-box-value (car wb))))))) (define (hwnd->ctlproc hwnd) (let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) (and c (let ([wb (ptr-ref c _racket)]) - (and wb - (pair? wb) - (cdr wb)))))) + (and wb (cdr wb)))))) (define (any-hwnd->wx hwnd) (and @@ -81,23 +80,22 @@ (and c (let ([wx (let ([wb (ptr-ref c _racket)]) (and wb - (weak-box-value (if (pair? wb) - (car wb) - wb))))]) + (car wb) + (weak-box-value (car wb))))]) (and wx (send wx is-hwnd? hwnd) wx)))))) ;; call in atomic mode: -(define (unregister-hwnd? hwnd) +(define (unregister-hwnd? hwnd [same? (lambda (v) (eq? v hwnd))]) (let ([addr (cast hwnd _pointer _long)]) - (and (hash-ref all-hwnds addr #f) + (and (same? (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))))) + (SetWindowLongW hwnd GWLP_USERDATA #f)) + (hash-remove! all-hwnds addr) + #t)))) ;; ---------------------------------------- @@ -120,7 +118,7 @@ (define (wind-proc w msg wparam lparam) (if (= msg WM_DESTROY) (begin - (unregister-hwnd? w) + (unregister-hwnd? w (lambda (x) x)) (DefWindowProcW w msg wparam lparam)) (let ([wx (hwnd->wx w)]) (if wx @@ -132,7 +130,7 @@ (define (control-proc w msg wParam lParam) (if (= msg WM_DESTROY) (let ([default-ctlproc (hwnd->ctlproc w)]) - (unregister-hwnd? w) + (unregister-hwnd? w (lambda (x) x)) (default-ctlproc w)) (let ([wx (hwnd->wx w)]) (if wx @@ -175,7 +173,7 @@ ((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) + (register! hwnd) hwnd)))) (define CreateWindowExW (make-CreateWindowEx register-hwnd!))