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

cocoa & gtk: fix some test failures

Browse Source
This commit is contained in:
Matthew Flatt 2010-10-31 09:38:57 -06:00
parent f829424783
commit e033d9edf1
5 changed files with 35 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/mred/private/wx/cocoa/canvas.rkt
View File

@ -712,9 +712,10 @@
in-menu-click?)
(define/public (scroll x y)
(when (x . > . 0) (scroll-pos h-scroller (* x (scroll-range h-scroller))))
(when (y . > . 0) (scroll-pos v-scroller (* y (scroll-range v-scroller))))
(when (is-auto-scroll?) (refresh-for-autoscroll)))
(when (is-auto-scroll?)
(when (x . >= . 0) (scroll-pos h-scroller (floor (* x (scroll-range h-scroller)))))
(when (y . >= . 0) (scroll-pos v-scroller (floor (* y (scroll-range v-scroller)))))
(refresh-for-autoscroll)))
(define/public (warp-pointer x y) (void))

7
collects/mred/private/wx/cocoa/list-box.rkt
View File

@ -116,7 +116,12 @@
cell-font)
(define/public (get-selection)
(tell #:type _NSInteger content-cocoa selectedRow))
(if allow-multi?
(let ([l (get-selections)])
(if (null? l)
-1
(car l)))
(tell #:type _NSInteger content-cocoa selectedRow)))
(define/public (get-selections)
(atomically
(with-autorelease

21
collects/mred/private/wx/gtk/canvas.rkt
View File

@ -542,11 +542,22 @@
(define/public (on-scroll e) (void))
(define/public (scroll x y)
(as-scroll-change
(lambda ()
(when hscroll-adj (gtk_adjustment_set_value hscroll-adj x))
(when vscroll-adj (gtk_adjustment_set_value vscroll-adj y))))
(when (is-auto-scroll?) (refresh-for-autoscroll)))
(when (is-auto-scroll?)
(as-scroll-change
(lambda ()
(when (and hscroll-adj (>= x 0))
(gtk_adjustment_set_value
hscroll-adj
(floor
(* x (- (gtk_adjustment_get_upper hscroll-adj)
(gtk_adjustment_get_page_size hscroll-adj))))))
(when (and vscroll-adj (>= y 0))
(gtk_adjustment_set_value
vscroll-adj
(floor
(* y (- (gtk_adjustment_get_upper vscroll-adj)
(gtk_adjustment_get_page_size vscroll-adj))))))))
(refresh-for-autoscroll)))
(define/public (warp-pointer x y) (void))

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

@ -445,11 +445,12 @@
(ptr-equal? combo-hwnd a-hwnd)))
(define/public (scroll x y)
(when (x . > . 0)
(set-scroll-pos 'horizontal (->long (* x (get-scroll-range 'horizontal)))))
(when (y . > . 0)
(set-scroll-pos 'vertical (->long (* y (get-scroll-range 'vertical)))))
(when (is-auto-scroll?) (refresh-for-autoscroll)))
(when (is-auto-scroll?)
(when (x . > . 0)
(set-scroll-pos 'horizontal (->long (* x (get-scroll-range 'horizontal)))))
(when (y . > . 0)
(set-scroll-pos 'vertical (->long (* y (get-scroll-range 'vertical)))))
(refresh-for-autoscroll)))
(define/public (warp-pointer x y) (void))

5
collects/tests/gracket/windowing.rktl
View File

@ -56,6 +56,7 @@
(define (client->screen-tests f)
(printf "Client<->Screen ~a\n" f)
(send (or (send f get-parent) f) reflow-container)
(let-values ([(x y) (send f client->screen 0 0)])
(stvals '(0 0) f screen->client x y))
(let-values ([(x y) (send f screen->client 0 0)])
@ -885,8 +886,8 @@
(lambda (xpos ypos)
(let-values ([(x y) (send c get-view-start)])
(let ([coerce (lambda (x) (inexact->exact (floor x)))])
(test (coerce (* xpos (- 500 cw))) `(canvas-view-x ,xpos ,ypos ,x ,cw) x)
(test (coerce (* ypos (- 606 ch))) `(canvas-view-y ,xpos ,ypos ,y ,ch) y))))])
(test (coerce (* xpos (- 500 cw))) `(canvas-view-x ,xpos ,ypos ,x ,cw ,w) x)
(test (coerce (* ypos (- 606 ch))) `(canvas-view-y ,xpos ,ypos ,y ,ch , h) y))))])
(test 500 'canvas-virt-w-size w)
(test 606 'canvas-virt-h-size h)