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))
(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))

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

@ -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))

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

@ -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)))

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

@ -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!))