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

clean up lock library and uses

Browse Source
This commit is contained in:
Matthew Flatt 2010-08-14 09:04:09 -06:00
parent 0a9bdc11ad
commit a9ffced9b8
25 changed files with 315 additions and 323 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
collects/mred/private/lock.rkt
View File

@ -1,19 +1,69 @@
(module lock mzscheme
(require racket/draw/lock)
(provide as-entry
as-exit
entry-point
(protect mk-param))
#lang racket/base
(require (for-syntax racket/base)
ffi/unsafe/atomic)
(define-syntax mk-param
(lambda (stx)
(syntax-case stx ()
[(_ val filter check force-redraw)
(syntax
(case-lambda
[() val]
[(v) (check v)
(let ([v2 (filter v)])
(unless (eq? v2 val)
(set! val v2)
(force-redraw)))]))]))))
(provide (protect-out as-entry ;; alias for call-as-atomic
as-exit ;; alias for call-as-nonatomic
atomically ;; assumes no exceptions!
entry-point ;; converts a proc body to use as-entry
mk-param)) ;; parameter pattern --- out of place here
;; We need atomic mode for a couple of reasons:
;;
;; * We may need to bracket some (trusted) operations so that the
;; queue thread doesn't poll for events during the operation.
;; The `atomically' form is ok for that if no exceptions will
;; be raised. Otherwise, use the more heavyweight `as-entry'.
;;
;; * The scheme/gui classes have internal-consistency requirements.
;; When the user creates an object or calls a method, or when the
;; system invokes a callback, many steps may be required to
;; initialize or reset fields to maintain invariants. To ensure that
;; other threads do not call methods during a time when invariants
;; do not hold, we force all of the following code to be executed in
;; a single threaded manner, and we temporarily disable breaks.
;; The `as-entry' form or `entry-point' wrapper is normally used for
;; that case.
;;
;; If an exception is raised within an `enter'ed area, control is
;; moved back outside by the exception handler, and then the exception
;; is re-raised. The user can't tell that the exception was caught an
;; re-raised. But without the catch-and-reraise, the user's exception
;; handler might try to use GUI elements from a different thread, or
;; other such things, leading to deadlock.
(define as-entry call-as-atomic)
(define as-exit call-as-nonatomic)
(define-syntax entry-point
(lambda (stx)
(syntax-case stx (lambda #%plain-lambda case-lambda)
[(_ (lambda args body1 body ...))
(syntax (lambda args (as-entry (lambda () body1 body ...))))]
[(_ (#%plain-lambda args body1 body ...))
(syntax (#%plain-lambda args (as-entry (lambda () body1 body ...))))]
[(_ (case-lambda [vars body1 body ...] ...))
(syntax (case-lambda
[vars (as-entry (lambda () body1 body ...))]
...))])))
(define-syntax-rule (atomically expr ...)
(begin
(start-atomic)
(begin0 (let () expr ...)
(end-atomic))))
;; Parameter-method pattern. (Why is this in the "lock" library?)
(define-syntax mk-param
(lambda (stx)
(syntax-case stx ()
[(_ val filter check force-redraw)
(syntax
(case-lambda
[() val]
[(v) (check v)
(let ([v2 (filter v)])
(unless (eq? v2 val)
(set! val v2)
(force-redraw)))]))])))

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

@ -235,6 +235,7 @@
(queue-paint))
(define/public (queue-backing-flush)
;; called atomically (not expecting exceptions)
(tellv content-cocoa setNeedsDisplay: #:type _BOOL #t))
(define/override (get-cocoa-content) content-cocoa)

25
collects/mred/private/wx/cocoa/dc.rkt
View File

@ -50,27 +50,26 @@
(values (unbox xb) (unbox yb))))
(define/override (queue-backing-flush)
;; called atomically (not expecting exceptions)
(send canvas queue-backing-flush))
(define suspend-count 0)
(define req #f)
(define/override (suspend-flush)
(as-entry
(lambda ()
(when (zero? suspend-count)
(set! req (request-flush-delay (send canvas get-cocoa-window))))
(set! suspend-count (add1 suspend-count))
(super suspend-flush))))
(atomically
(when (zero? suspend-count)
(set! req (request-flush-delay (send canvas get-cocoa-window))))
(set! suspend-count (add1 suspend-count))
(super suspend-flush)))
(define/override (resume-flush)
(as-entry
(lambda ()
(set! suspend-count (sub1 suspend-count))
(when (and (zero? suspend-count) req)
(cancel-flush-delay req)
(set! req #f))
(super resume-flush))))))
(atomically
(set! suspend-count (sub1 suspend-count))
(when (and (zero? suspend-count) req)
(cancel-flush-delay req)
(set! req #f))
(super resume-flush)))))
(define (do-backing-flush canvas dc ctx dx dy)
(tellv ctx saveGraphicsState)

18
collects/mred/private/wx/cocoa/dialog.rkt
View File

@ -14,11 +14,10 @@
(define/override (direct-show on?)
(unless on?
(as-entry
(lambda ()
(when close-sema
(semaphore-post close-sema)
(set! close-sema #f)))))
(atomically
(when close-sema
(semaphore-post close-sema)
(set! close-sema #f))))
(super direct-show on?))
;; #t result avoids children sheets
@ -26,11 +25,10 @@
(define/override (show on?)
(if on?
(let ([s (as-entry
(lambda ()
(let ([s (or close-sema (make-semaphore))])
(unless close-sema (set! close-sema s))
s)))])
(let ([s (atomically
(let ([s (or close-sema (make-semaphore))])
(unless close-sema (set! close-sema s))
s))])
(super show on?)
(yield s)
(void))

45
collects/mred/private/wx/cocoa/image.rkt
View File

@ -60,26 +60,25 @@
(let ([mask (send bm get-loaded-mask)])
(when mask
(send mask get-argb-pixels 0 0 w h str #t)))
(as-entry
(lambda ()
(let ([rgba (scheme_make_sized_byte_string (malloc (* w h 4) 'raw) (* w h 4) 0)])
(memcpy rgba str (sub1 (* w h 4)))
(let* ([cs (CGColorSpaceCreateDeviceRGB)]
[provider (CGDataProviderCreateWithData #f rgba (* w h 4) free-it)]
[image (CGImageCreate w
h
8
32
(* 4 w)
cs
(bitwise-ior kCGImageAlphaFirst
kCGBitmapByteOrder32Big)
provider ; frees `rgba'
#f
#f
0)])
(CGDataProviderRelease provider)
(CGColorSpaceRelease cs)
(tell (tell NSImage alloc)
initWithCGImage: #:type _CGImageRef image
size: #:type _NSSize (make-NSSize w h))))))))
(atomically
(let ([rgba (scheme_make_sized_byte_string (malloc (* w h 4) 'raw) (* w h 4) 0)])
(memcpy rgba str (sub1 (* w h 4)))
(let* ([cs (CGColorSpaceCreateDeviceRGB)]
[provider (CGDataProviderCreateWithData #f rgba (* w h 4) free-it)]
[image (CGImageCreate w
h
8
32
(* 4 w)
cs
(bitwise-ior kCGImageAlphaFirst
kCGBitmapByteOrder32Big)
provider ; frees `rgba'
#f
#f
0)])
(CGDataProviderRelease provider)
(CGColorSpaceRelease cs)
(tell (tell NSImage alloc)
initWithCGImage: #:type _CGImageRef image
size: #:type _NSSize (make-NSSize w h)))))))

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

@ -106,16 +106,15 @@
(define/public (get-selection)
(tell #:type _NSInteger content-cocoa selectedRow))
(define/public (get-selections)
(as-entry
(lambda ()
(with-autorelease
(let ([v (tell content-cocoa selectedRowIndexes)])
(begin0
(let loop ([i (tell #:type _NSInteger v firstIndex)])
(cond
[(= i NSNotFound) null]
[else (cons i (loop (tell #:type _NSInteger v
indexGreaterThanIndex: #:type _NSInteger i)))]))))))))
(atomically
(with-autorelease
(let ([v (tell content-cocoa selectedRowIndexes)])
(begin0
(let loop ([i (tell #:type _NSInteger v firstIndex)])
(cond
[(= i NSNotFound) null]
[else (cons i (loop (tell #:type _NSInteger v
indexGreaterThanIndex: #:type _NSInteger i)))])))))))
(define/private (visible-range)
(tell #:type _NSRange content-cocoa
@ -158,13 +157,12 @@
(define/public (select i [on? #t] [extend? #t])
(if on?
(as-entry
(lambda ()
(with-autorelease
(let ([index (tell (tell NSIndexSet alloc) initWithIndex: #:type _NSUInteger i)])
(tellv content-cocoa
selectRowIndexes: index
byExtendingSelection: #:type _BOOL extend?)))))
(atomically
(with-autorelease
(let ([index (tell (tell NSIndexSet alloc) initWithIndex: #:type _NSUInteger i)])
(tellv content-cocoa
selectRowIndexes: index
byExtendingSelection: #:type _BOOL extend?))))
(tellv content-cocoa deselectRow: #:type _NSInteger i)))
(define/public (set-selection i)
(select i #t #f))

4
collects/mred/private/wx/cocoa/procs.rkt
View File

@ -114,9 +114,9 @@
(tellv NSCursor setHiddenUntilMouseMoves: #:type _BOOL #t))
(define busy-count 0)
(define (end-busy-cursor) (as-entry (lambda () (set! busy-count (add1 busy-count)))))
(define (end-busy-cursor) (atomically (set! busy-count (add1 busy-count))))
(define (is-busy?) (positive? busy-count))
(define (begin-busy-cursor) (as-entry (lambda () (set! busy-count (sub1 busy-count)))))
(define (begin-busy-cursor) (atomically (set! busy-count (sub1 busy-count))))
(define (get-display-depth) 32)
(define-unimplemented is-color-display?)

2
collects/mred/private/wx/cocoa/queue.rkt
View File

@ -245,7 +245,7 @@
(thread (lambda ()
(let loop ()
(sync queue-evt)
(as-entry dispatch-all-ready)
(atomically (dispatch-all-ready))
(loop)))))
(set-check-queue!

44
collects/mred/private/wx/cocoa/window.rkt
View File

@ -412,28 +412,26 @@
(define depth 0)
(define (request-flush-delay cocoa-win)
(as-entry
(lambda ()
(let ([req (box cocoa-win)])
(set! depth (add1 depth))
(tellv cocoa-win disableFlushWindow)
(add-event-boundary-sometimes-callback!
req
(lambda (v)
;; in atomic mode
(when (unbox req)
(set-box! req #f)
(set! depth (sub1 depth))
(tellv cocoa-win enableFlushWindow)
(tellv cocoa-win flushWindow))))
req))))
(atomically
(let ([req (box cocoa-win)])
(set! depth (add1 depth))
(tellv cocoa-win disableFlushWindow)
(add-event-boundary-sometimes-callback!
req
(lambda (v)
;; in atomic mode
(when (unbox req)
(set-box! req #f)
(set! depth (sub1 depth))
(tellv cocoa-win enableFlushWindow)
(tellv cocoa-win flushWindow))))
req)))
(define (cancel-flush-delay req)
(as-entry
(lambda ()
(let ([cocoa-win (unbox req)])
(when cocoa-win
(set-box! req #f)
(set! depth (sub1 depth))
(tellv cocoa-win enableFlushWindow)
(remove-event-boundary-callback! req))))))
(atomically
(let ([cocoa-win (unbox req)])
(when cocoa-win
(set-box! req #f)
(set! depth (sub1 depth))
(tellv cocoa-win enableFlushWindow)
(remove-event-boundary-callback! req)))))

19
collects/mred/private/wx/common/backing-dc.rkt
View File

@ -41,7 +41,7 @@
;; override this method to set up a callback to
;; `on-backing-flush' when the backing store can be rendered
;; to the screen
;; to the screen; called atomically (expecting no exceptions)
(define/public (queue-backing-flush)
(void))
@ -102,18 +102,13 @@
(define flush-suspends 0)
(define/override (suspend-flush)
(as-entry
(lambda ()
;; if not suspended currently, sleep to encourage any
;; existing flush requests to complete
(when (zero? flush-suspends) (sleep))
(set! flush-suspends (add1 flush-suspends)))))
(atomically
(set! flush-suspends (add1 flush-suspends))))
(define/override (resume-flush)
(as-entry
(lambda ()
(set! flush-suspends (sub1 flush-suspends))
(when (zero? flush-suspends)
(queue-backing-flush)))))))
(atomically
(set! flush-suspends (sub1 flush-suspends))
(when (zero? flush-suspends)
(queue-backing-flush))))))
(define (get-backing-bitmap w h)
(make-object bitmap% w h #f #t))

12
collects/mred/private/wx/common/timer.rkt
View File

@ -16,10 +16,10 @@
(define current-once? (and just-once? #t))
(define cb #f)
(def/public (interval) current-interval)
(def/public (start [(integer-in 0 1000000000) msec] [any? [once? #f]])
(define/private (do-start msec once?)
(as-entry
(lambda ()
(stop)
(do-stop)
(set! current-interval msec)
(set! current-once? (and once? #t))
(letrec ([new-cb
@ -31,17 +31,19 @@
(lambda ()
(unless once?
(when (eq? cb new-cb)
(start msec #f))))))))])
(do-start msec #f))))))))])
(set! cb new-cb)
(add-timer-callback new-cb)))))
(def/public (stop)
(def/public (start [(integer-in 0 1000000000) msec] [any? [once? #f]])
(do-start msec once?))
(define/private (do-stop)
(as-entry
(lambda ()
(when cb
(remove-timer-callback cb)
(set! cb #f)))))
(def/public (stop) (do-stop))
(def/public (notify) (notify-cb) (void))
(super-new)
(when ival
(start ival just-once?)))

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

@ -47,17 +47,16 @@
#:fail (lambda ()
;; This by-hand version doesn't produce quite the same notifications.
(lambda (gtk value lower upper step-inc page-inc page-size)
(as-entry
(lambda ()
(g_object_freeze_notify gtk)
(g_object_set_double gtk "lower" lower)
(g_object_set_double gtk "upper" upper)
(g_object_set_double gtk "step-increment" step-inc)
(g_object_set_double gtk "page-increment" page-inc)
(g_object_set_double gtk "page-size" page-size)
(let ([value (max lower (min value (- upper page-size)))])
(gtk_adjustment_set_value gtk value))
(g_object_thaw_notify gtk))))))
(atomically
(g_object_freeze_notify gtk)
(g_object_set_double gtk "lower" lower)
(g_object_set_double gtk "upper" upper)
(g_object_set_double gtk "step-increment" step-inc)
(g_object_set_double gtk "page-increment" page-inc)
(g_object_set_double gtk "page-size" page-size)
(let ([value (max lower (min value (- upper page-size)))])
(gtk_adjustment_set_value gtk value))
(g_object_thaw_notify gtk)))))
(define-gtk gtk_adjustment_get_value (_fun _GtkAdjustment -> _double*))
(define-gtk gtk_adjustment_set_value (_fun _GtkAdjustment _double* -> _void))
(define-gtk gtk_adjustment_get_upper (_fun _GtkAdjustment -> _double*)
@ -348,6 +347,7 @@
(queue-paint))
(define/public (queue-backing-flush)
;; called atomically (not expecting exceptions)
(gtk_widget_queue_draw client-gtk))
(define/override (reset-child-dcs)

9
collects/mred/private/wx/gtk/check-box.rkt
View File

@ -24,11 +24,10 @@
(inherit get-gtk)
(define/public (set-value v)
(as-entry
(lambda ()
(set! no-clicked? #t)
(gtk_toggle_button_set_active (get-gtk) v)
(set! no-clicked? #f))))
(atomically
(set! no-clicked? #t)
(gtk_toggle_button_set_active (get-gtk) v)
(set! no-clicked? #f)))
(define no-clicked? #f)
(define/override (queue-clicked)

38
collects/mred/private/wx/gtk/choice.rkt
View File

@ -71,29 +71,27 @@
(queue-window-event this (lambda () (clicked)))))
(define/public (set-selection i)
(as-entry
(lambda ()
(set! ignore-clicked? #t)
(gtk_combo_box_set_active gtk i)
(set! ignore-clicked? #f))))
(atomically
(set! ignore-clicked? #t)
(gtk_combo_box_set_active gtk i)
(set! ignore-clicked? #f)))
(define/public (get-selection)
(gtk_combo_box_get_active gtk))
(define/public (number) count)
(define/public (clear)
(as-entry
(lambda ()
(set! ignore-clicked? #t)
(for ([i (in-range count)])
(gtk_combo_box_remove_text gtk 0))
(set! count 0)
(set! ignore-clicked? #f))))
(atomically
(set! ignore-clicked? #t)
(for ([i (in-range count)])
(gtk_combo_box_remove_text gtk 0))
(set! count 0)
(set! ignore-clicked? #f)))
(public [-append append])
(define (-append l)
(as-entry
(lambda ()
(set! ignore-clicked? #t)
(set! count (add1 count))
(gtk_combo_box_append_text gtk l)
(when (= count 1)
(set-selection 0))
(set! ignore-clicked? #f)))))
(atomically
(set! ignore-clicked? #t)
(set! count (add1 count))
(gtk_combo_box_append_text gtk l)
(when (= count 1)
(set-selection 0))
(set! ignore-clicked? #f))))

1
collects/mred/private/wx/gtk/dc.rkt
View File

@ -33,6 +33,7 @@
(values (unbox xb) (unbox yb))))
(define/override (queue-backing-flush)
;; called atomically (not expecting exceptions)
(send canvas queue-backing-flush))))
(define (do-backing-flush canvas dc win)

101
collects/mred/private/wx/gtk/list-box.rkt
View File

@ -160,30 +160,28 @@
(gtk_tree_path_free p)))
(define/public (set choices)
(as-entry
(lambda ()
(set! ignore-click? #t)
(clear)
(set! items choices)
(set! data (map (lambda (x) (box #f)) choices))
(reset-content)
(set! ignore-click? #f))))
(atomically
(set! ignore-click? #t)
(clear)
(set! items choices)
(set! data (map (lambda (x) (box #f)) choices))
(reset-content)
(set! ignore-click? #f)))
(define/public (get-selections)
(as-entry
(lambda ()
(let ([list (gtk_tree_selection_get_selected_rows selection #f)])
(if list
(let ([v null])
(g_list_foreach list
(lambda (t)
(set! v (cons (ptr-ref (gtk_tree_path_get_indices t) _int)
v)))
#f)
(g_list_foreach list gtk_tree_path_free #f)
(g_list_free list)
(reverse v))
null)))))
(atomically
(let ([list (gtk_tree_selection_get_selected_rows selection #f)])
(if list
(let ([v null])
(g_list_foreach list
(lambda (t)
(set! v (cons (ptr-ref (gtk_tree_path_get_indices t) _int)
v)))
#f)
(g_list_foreach list gtk_tree_path_free #f)
(g_list_free list)
(reverse v))
null))))
(define/public (get-selection)
(let ([l (get-selections)])
(if (null? l)
@ -191,14 +189,13 @@
(car l))))
(define/private (get-visible-range)
(as-entry
(lambda ()
(let-values ([(sp ep) (gtk_tree_view_get_visible_range client-gtk)])
(begin0
(values (if sp (ptr-ref (gtk_tree_path_get_indices sp) _int) 0)
(if ep (ptr-ref (gtk_tree_path_get_indices ep) _int) 0))
(when sp (gtk_tree_path_free sp))
(when ep (gtk_tree_path_free ep)))))))
(atomically
(let-values ([(sp ep) (gtk_tree_view_get_visible_range client-gtk)])
(begin0
(values (if sp (ptr-ref (gtk_tree_path_get_indices sp) _int) 0)
(if ep (ptr-ref (gtk_tree_path_get_indices ep) _int) 0))
(when sp (gtk_tree_path_free sp))
(when ep (gtk_tree_path_free ep))))))
(define/public (get-first-item)
(let-values ([(start end) (get-visible-range)])
@ -219,18 +216,17 @@
(gtk_tree_path_free p))))
(define/public (select i [on? #t] [extend? #t])
(as-entry
(lambda ()
(set! ignore-click? #t)
(let ([p (gtk_tree_path_new_from_indices i -1)])
(if on?
(begin
(unless extend?
(gtk_tree_selection_unselect_all selection))
(gtk_tree_selection_select_path selection p))
(gtk_tree_selection_unselect_path selection p))
(gtk_tree_path_free p))
(set! ignore-click? #f))))
(atomically
(set! ignore-click? #t)
(let ([p (gtk_tree_path_new_from_indices i -1)])
(if on?
(begin
(unless extend?
(gtk_tree_selection_unselect_all selection))
(gtk_tree_selection_select_path selection p))
(gtk_tree_selection_unselect_path selection p))
(gtk_tree_path_free p))
(set! ignore-click? #f)))
(define/public (set-selection i)
(select i #t #f))
@ -248,15 +244,14 @@
(public [append* append])
(define (append* s [v #f])
(as-entry
(lambda ()
(set! ignore-click? #t)
(set! items (append items (list s)))
(set! data (append data (list (box v))))
(let ([iter (make-GtkTreeIter 0 #f #f #f)])
(gtk_list_store_append store iter #f)
(gtk_list_store_set store iter 0 s -1))
(maybe-init-select)
(set! ignore-click? #f))))
(atomically
(set! ignore-click? #t)
(set! items (append items (list s)))
(set! data (append data (list (box v))))
(let ([iter (make-GtkTreeIter 0 #f #f #f)])
(gtk_list_store_append store iter #f)
(gtk_list_store_set store iter 0 s -1))
(maybe-init-select)
(set! ignore-click? #f)))
(reset-content))
(atomically (reset-content)))

29
collects/mred/private/wx/gtk/pixbuf.rkt
View File

@ -39,18 +39,17 @@
(let ([mask (send bm get-loaded-mask)])
(when mask
(send mask get-argb-pixels 0 0 w h str #t)))
(as-entry
(lambda ()
(let ([rgba (scheme_make_sized_byte_string (malloc (* w h 4) 'raw) (* w h 4) 0)])
(memcpy rgba (ptr-add str 1) (sub1 (* w h 4)))
(for ([i (in-range 0 (* w h 4) 4)])
(bytes-set! rgba (+ i 3) (bytes-ref str i)))
(gdk_pixbuf_new_from_data rgba
0
#t
8
w
h
(* w 4)
free-it
#f))))))
(atomically
(let ([rgba (scheme_make_sized_byte_string (malloc (* w h 4) 'raw) (* w h 4) 0)])
(memcpy rgba (ptr-add str 1) (sub1 (* w h 4)))
(for ([i (in-range 0 (* w h 4) 4)])
(bytes-set! rgba (+ i 3) (bytes-ref str i)))
(gdk_pixbuf_new_from_data rgba
0
#t
8
w
h
(* w 4)
free-it
#f)))))

4
collects/mred/private/wx/gtk/procs.rkt
View File

@ -120,9 +120,9 @@
(define (hide-cursor) (void))
(define busy-count 0)
(define (end-busy-cursor) (as-entry (lambda () (set! busy-count (add1 busy-count)))))
(define (end-busy-cursor) (atomically (set! busy-count (add1 busy-count))))
(define (is-busy?) (positive? busy-count))
(define (begin-busy-cursor) (as-entry (lambda () (set! busy-count (sub1 busy-count)))))
(define (begin-busy-cursor) (atomically (set! busy-count (sub1 busy-count))))
(define-unimplemented is-color-display?)

4
collects/mred/private/wx/gtk/queue.rkt
View File

@ -3,7 +3,7 @@
ffi/unsafe
"utils.rkt"
"types.rkt"
racket/draw/lock
"../../lock.rkt"
"../common/queue.rkt"
"../common/freeze.rkt"
"const.rkt")
@ -131,5 +131,5 @@
(thread (lambda ()
(let loop ()
(sync queue-evt)
(as-entry dispatch-all-ready)
(atomically (dispatch-all-ready))
(loop)))))

21
collects/mred/private/wx/gtk/radio-box.rkt
View File

@ -102,17 +102,16 @@
(define/override (set-focus)
(button-focus (max 0 (set-selection))))
(define/public (set-selection i)
(as-entry
(lambda ()
(set! no-clicked? #t)
(if (= i -1)
(when (pair? radio-gtks)
(unless dummy-gtk
(set! dummy-gtk (gtk_radio_button_new
(gtk_radio_button_get_group (car radio-gtks)))))
(gtk_toggle_button_set_active dummy-gtk #t))
(gtk_toggle_button_set_active (list-ref radio-gtks i) #t))
(set! no-clicked? #f))))
(atomically
(set! no-clicked? #t)
(if (= i -1)
(when (pair? radio-gtks)
(unless dummy-gtk
(set! dummy-gtk (gtk_radio_button_new
(gtk_radio_button_get_group (car radio-gtks)))))
(gtk_toggle_button_set_active dummy-gtk #t))
(gtk_toggle_button_set_active (list-ref radio-gtks i) #t))
(set! no-clicked? #f)))
(define/public (get-selection)
(or (for/or ([radio-gtk (in-list radio-gtks)]

9
collects/mred/private/wx/gtk/slider.rkt
View File

@ -68,10 +68,9 @@
[time-stamp (current-milliseconds)]))))))
(define/public (set-value v)
(as-entry
(lambda ()
(set! ignore-click? #t)
(gtk_range_set_value gtk v)
(set! ignore-click? #f))))
(atomically
(set! ignore-click? #t)
(gtk_range_set_value gtk v)
(set! ignore-click? #f)))
(define/public (get-value)
(inexact->exact (floor (gtk_range_get_value gtk)))))

13
collects/mred/private/wx/gtk/window.rkt
View File

@ -380,13 +380,12 @@
(define shown? #f)
(define/public (direct-show on?)
(as-entry
(lambda ()
(if on?
(gtk_widget_show gtk)
(gtk_widget_hide gtk))
(set! shown? (and on? #t))
(register-child-in-parent on?)))
(atomically
(if on?
(gtk_widget_show gtk)
(gtk_widget_hide gtk))
(set! shown? (and on? #t))
(register-child-in-parent on?))
(when on? (reset-child-dcs)))
(define/public (show on?)
(direct-show on?))

1
collects/racket/draw/dc.rkt
View File

@ -538,6 +538,7 @@
(cairo_stroke cr2)
(cairo_destroy cr2)
(let* ([p (cairo_pattern_create_for_surface s)])
(cairo_surface_destroy s)
(cairo_pattern_set_extend p CAIRO_EXTEND_REPEAT)
(cairo_set_source cr p)
(cairo_pattern_destroy p))))

47
collects/racket/draw/lock.rkt
View File

@ -1,47 +0,0 @@
#lang racket/base
(require (for-syntax racket/base)
ffi/unsafe/atomic)
(provide (protect-out as-entry
as-exit
entry-point))
;; We need atomic mode for a couple of reasons:
;;
;; * We may need to bracket some (trusted) operations so that the
;; queue thread doesn't poll for events during the operation.
;;
;; * The scheme/gui classes have internal-consistency requirements.
;; When the user creates an object or calls a method, or when the
;; system invokes a callback, many steps may be required to
;; initialize or reset fields to maintain invariants. To ensure that
;; other threads do not call methods during a time when invariants
;; do not hold, we force all of the following code to be executed in
;; a single threaded manner, and we temporarily disable breaks.
;;
;; Atomic mode is implemented with a single monitor: all entry points
;; into the code use `entry-point' or `as-entry', and all points with
;; this code that call back out to user code uses `as-exit'.
;;
;; If an exception is raised within an `enter'ed area, control is
;; moved back outside by the exception handler, and then the exception
;; is re-raised. The user can't tell that the exception was caught an
;; re-raised. But without the catch-and-reraise, the user's exception
;; handler might try to use GUI elements from a different thread, or
;; other such things, leading to deadlock.
(define as-entry call-as-atomic)
(define as-exit call-as-nonatomic)
(define-syntax entry-point
(lambda (stx)
(syntax-case stx (lambda #%plain-lambda case-lambda)
[(_ (lambda args body1 body ...))
(syntax (lambda args (as-entry (lambda () body1 body ...))))]
[(_ (#%plain-lambda args body1 body ...))
(syntax (#%plain-lambda args (as-entry (lambda () body1 body ...))))]
[(_ (case-lambda [vars body1 body ...] ...))
(syntax (case-lambda
[vars (as-entry (lambda () body1 body ...))]
...))])))

51
collects/racket/draw/region.rkt
View File

@ -1,12 +1,12 @@
#lang scheme/base
(require scheme/class
ffi/unsafe/atomic
"syntax.ss"
"local.ss"
"cairo.ss"
"dc-path.ss"
"dc-intf.ss"
"point.ss"
"lock.ss")
"point.ss")
(provide region%)
@ -152,25 +152,34 @@
(def/public (in-region? [real? x]
[real? y])
(as-entry
(lambda ()
(unless temp-cr
(set! temp-cr
(cairo_create
(cairo_image_surface_create CAIRO_FORMAT_A8 1 1))))
(let-values ([(x y)
(if matrix
;; need to use the DC's current transformation
(let ([m (send dc get-clipping-matrix)])
(values (+ (* x (vector-ref m 0))
(* y (vector-ref m 2))
(vector-ref m 4))
(+ (* x (vector-ref m 1))
(* y (vector-ref m 3))
(vector-ref m 5))))
;; no transformation needed
(values x y))])
(install-region temp-cr #t (lambda (cr v) (and v (cairo_in_fill temp-cr x y))))))))
(let ([cr (call-as-atomic
(lambda ()
(cond
[temp-cr
(begin0 temp-cr (set! temp-cr #f))]
[else
(let ([s (cairo_image_surface_create CAIRO_FORMAT_A8 1 1)])
(begin0
(cairo_create s)
(cairo_surface_destroy s)))])))])
(let-values ([(x y)
(if matrix
;; need to use the DC's current transformation
(let ([m (send dc get-clipping-matrix)])
(values (+ (* x (vector-ref m 0))
(* y (vector-ref m 2))
(vector-ref m 4))
(+ (* x (vector-ref m 1))
(* y (vector-ref m 3))
(vector-ref m 5))))
;; no transformation needed
(values x y))])
(begin0
(install-region cr #t (lambda (cr v) (and v (cairo_in_fill cr x y))))
(call-as-atomic
(cond
[temp-cr (cairo_destroy cr)]
[else (set! temp-cr cr)]))))))
(def/public (set-arc [real? x]
[real? y]