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

win32: further deallocation fixes, plus some test fixes

Browse Source
This commit is contained in:
Matthew Flatt 2010-10-31 11:32:05 -06:00
parent daf7f6dd17
commit ad9315ba6b
4 changed files with 47 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -330,15 +330,21 @@
(GetScrollPos canvas-hwnd SB_VERT)) (GetScrollPos canvas-hwnd SB_VERT))
(define/public (get-scroll-pos which) (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) (define/public (get-scroll-range which)
(let ([i (GetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) (if (is-auto-scroll?)
(+ (- (SCROLLINFO-nMax i) 0
(SCROLLINFO-nPage i)) (let ([i (GetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))])
1))) (+ (- (SCROLLINFO-nMax i)
(SCROLLINFO-nPage i))
1))))
(define/public (get-scroll-page which) (define/public (get-scroll-page which)
(let ([i (GetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) (if (is-auto-scroll?)
(SCROLLINFO-nPage i))) 0
(let ([i (GetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))])
(SCROLLINFO-nPage i))))
(define/public (set-scroll-pos which v) (define/public (set-scroll-pos which v)
(void (SetScrollPos canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ) v #t))) (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))))) (set-scroll-pos 'vertical (->long (* y (get-scroll-range 'vertical)))))
(when (is-auto-scroll?) (refresh-for-autoscroll))) (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?) (define/public (set-resize-corner on?)
(void)) (void))

2
collects/mred/private/wx/win32/choice.rkt
View File

@ -94,7 +94,7 @@
(define/public (set-selection i) (define/public (set-selection i)
(SendMessageW hwnd CB_SETCURSEL i 0)) (void (SendMessageW hwnd CB_SETCURSEL i 0)))
(define/public (get-selection) (define/public (get-selection)
(SendMessageW hwnd CB_GETCURSEL 0 0)) (SendMessageW hwnd CB_GETCURSEL 0 0))

28
collects/mred/private/wx/win32/list-box.rkt
View File

@ -56,9 +56,7 @@
(inherit set-size set-control-font (inherit set-size set-control-font
get-client-size) get-client-size)
(define single? (define single? (eq? 'single kind))
(and (not (memq 'extended style))
(not (memq 'mutiple style))))
(define hwnd (define hwnd
(CreateWindowExW/control WS_EX_CLIENTEDGE (CreateWindowExW/control WS_EX_CLIENTEDGE
@ -115,10 +113,11 @@
(define/public (set-string i str) (define/public (set-string i str)
(atomically (atomically
(SendMessageW/str hwnd LB_INSERTSTRING i str) (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) (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) (define/public (get-first-item)
(SendMessageW hwnd LB_GETTOPINDEX 0 0)) (SendMessageW hwnd LB_GETTOPINDEX 0 0))
@ -134,7 +133,7 @@
(atomically (atomically
(set! data null) (set! data null)
(set! num 0) (set! num 0)
(SendMessageW hwnd LB_RESETCONTENT 0 0))) (void (SendMessageW hwnd LB_RESETCONTENT 0 0))))
(define/public (set choices) (define/public (set choices)
(atomically (atomically
@ -157,7 +156,7 @@
(atomically (atomically
(set! data (append (take data i) (drop data (add1 i)))) (set! data (append (take data i) (drop data (add1 i))))
(set! num (sub1 num)) (set! num (sub1 num))
(SendMessageW hwnd LB_DELETESTRING i 0))) (void (SendMessageW hwnd LB_DELETESTRING i 0))))
(define/public (get-selections) (define/public (get-selections)
(atomically (atomically
@ -186,14 +185,15 @@
(not (zero? (SendMessageW hwnd LB_GETSEL i 0)))) (not (zero? (SendMessageW hwnd LB_GETSEL i 0))))
(define/public (select i [on? #t] [extend? #t]) (define/public (select i [on? #t] [extend? #t])
(if single? (void
(SendMessageW hwnd LB_SETCURSEL (if on? i -1) 0) (if single?
(begin (SendMessageW hwnd LB_SETCURSEL (if on? i -1) 0)
(when extend? (begin
(SendMessageW hwnd LB_SELITEMRANGE 0 (MAKELPARAM 0 num))) (when extend?
(SendMessageW hwnd LB_SETSEL (if on? 1 0) i)))) (SendMessageW hwnd LB_SELITEMRANGE 0 (MAKELPARAM 0 num)))
(SendMessageW hwnd LB_SETSEL (if on? 1 0) i)))))
(define/public (set-selection i) (define/public (set-selection i)
(select i #t #f)) (void (select i #t #f)))
(def/public-unimplemented get-label-font))) (def/public-unimplemented get-label-font)))

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

@ -39,7 +39,7 @@
;; call in atomic mode: ;; call in atomic mode:
(define (register-hwnd! hwnd) (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: ;; call in atomic mode:
(define (alloc-hwnd-cell hwnd) (define (alloc-hwnd-cell hwnd)
@ -52,27 +52,26 @@
(define (set-hwnd-wx! hwnd wx) (define (set-hwnd-wx! hwnd wx)
(let* ([c (atomically (alloc-hwnd-cell hwnd))] (let* ([c (atomically (alloc-hwnd-cell hwnd))]
[v (ptr-ref c _racket)]) [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) (define (set-hwnd-ctlproc! hwnd ctlproc)
(let* ([c (atomically (alloc-hwnd-cell hwnd))] (let* ([c (atomically (alloc-hwnd-cell hwnd))]
[v (ptr-ref c _racket)]) [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) (define (hwnd->wx hwnd)
(let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) (let ([c (GetWindowLongW hwnd GWLP_USERDATA)])
(and c (let ([wb (ptr-ref c _racket)]) (and c (let ([wb (ptr-ref c _racket)])
(and wb (and wb
(weak-box-value (if (pair? wb) (car wb)
(car wb) (weak-box-value (car wb)))))))
wb)))))))
(define (hwnd->ctlproc hwnd) (define (hwnd->ctlproc hwnd)
(let ([c (GetWindowLongW hwnd GWLP_USERDATA)]) (let ([c (GetWindowLongW hwnd GWLP_USERDATA)])
(and c (let ([wb (ptr-ref c _racket)]) (and c (let ([wb (ptr-ref c _racket)])
(and wb (and wb (cdr wb))))))
(pair? wb)
(cdr wb))))))
(define (any-hwnd->wx hwnd) (define (any-hwnd->wx hwnd)
(and (and
@ -81,23 +80,22 @@
(and c (and c
(let ([wx (let ([wb (ptr-ref c _racket)]) (let ([wx (let ([wb (ptr-ref c _racket)])
(and wb (and wb
(weak-box-value (if (pair? wb) (car wb)
(car wb) (weak-box-value (car wb))))])
wb))))])
(and wx (and wx
(send wx is-hwnd? hwnd) (send wx is-hwnd? hwnd)
wx)))))) wx))))))
;; call in atomic mode: ;; call in atomic mode:
(define (unregister-hwnd? hwnd) (define (unregister-hwnd? hwnd [same? (lambda (v) (eq? v hwnd))])
(let ([addr (cast hwnd _pointer _long)]) (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)]) (let ([c (GetWindowLongW hwnd GWLP_USERDATA)])
(when c (when c
(free-immobile-cell c) (free-immobile-cell c)
(hash-ref all-hwnds addr #f) (SetWindowLongW hwnd GWLP_USERDATA #f))
(SetWindowLongW hwnd GWLP_USERDATA #f) (hash-remove! all-hwnds addr)
#t))))) #t))))
;; ---------------------------------------- ;; ----------------------------------------
@ -120,7 +118,7 @@
(define (wind-proc w msg wparam lparam) (define (wind-proc w msg wparam lparam)
(if (= msg WM_DESTROY) (if (= msg WM_DESTROY)
(begin (begin
(unregister-hwnd? w) (unregister-hwnd? w (lambda (x) x))
(DefWindowProcW w msg wparam lparam)) (DefWindowProcW w msg wparam lparam))
(let ([wx (hwnd->wx w)]) (let ([wx (hwnd->wx w)])
(if wx (if wx
@ -132,7 +130,7 @@
(define (control-proc w msg wParam lParam) (define (control-proc w msg wParam lParam)
(if (= msg WM_DESTROY) (if (= msg WM_DESTROY)
(let ([default-ctlproc (hwnd->ctlproc w)]) (let ([default-ctlproc (hwnd->ctlproc w)])
(unregister-hwnd? w) (unregister-hwnd? w (lambda (x) x))
(default-ctlproc w)) (default-ctlproc w))
(let ([wx (hwnd->wx w)]) (let ([wx (hwnd->wx w)])
(if wx (if wx
@ -175,7 +173,7 @@
((allocator remember-to-free-later) ((allocator remember-to-free-later)
(lambda (dwExStyle lpClassName lpWindowName dwStyle x y nWidth nHeight hWndParent hMenu hInstance lpParam) (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)]) (let ([hwnd (_CreateWindowExW dwExStyle lpClassName lpWindowName dwStyle x y nWidth nHeight hWndParent hMenu hInstance lpParam)])
(register-hwnd! hwnd) (register! hwnd)
hwnd)))) hwnd))))
(define CreateWindowExW (make-CreateWindowEx register-hwnd!)) (define CreateWindowExW (make-CreateWindowEx register-hwnd!))