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

fixed race in rackunit gui

Browse Source 
Merge to release branch
(cherry picked from commit 9d42ef9235)
This commit is contained in:
Ryan Culpepper 2011-02-03 16:42:05 -07:00
parent 4bb3fd937a
commit 6eedd57f8b
1 changed files with 36 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
collects/rackunit/private/gui/view.rkt
View File

@ -71,8 +71,16 @@ still be there, just not visible?
(view this) (view this)
(controller controller))) (controller controller)))
;; for update management ;; Update management
(define update-queue (make-hasheq)) ;; Do adds in order, then updates in any order (hash).
;; add-queue : (listof (-> void))
(define add-queue null)
;; update-queue : (imm-hashof model<%> #t)
(define update-queue '#hasheq())
;; update-lock : semaphore
(define update-lock (make-semaphore 1)) (define update-lock (make-semaphore 1))
(send editor lock #t) (send editor lock #t)
@ -83,12 +91,6 @@ still be there, just not visible?
;; View Links ;; View Links
(define/public (create-view-link model parent)
(parameterize ((current-eventspace eventspace))
(queue-callback
(lambda ()
(send tree-view create-view-link model parent)))))
(define/private (get-view-link model) (define/private (get-view-link model)
(send tree-view get-view-link model)) (send tree-view get-view-link model))
@ -108,10 +110,18 @@ still be there, just not visible?
;; Update Management ;; Update Management
;; create-view-link : model suite-result<%>/#f -> void
(define/public (create-view-link model parent)
(let ([proc (lambda () (send tree-view create-view-link model parent))])
(semaphore-wait update-lock)
(set! add-queue (cons proc add-queue))
(semaphore-post update-lock)
(process-updates)))
;; queue-for-update : model -> void ;; queue-for-update : model -> void
(define/public (queue-for-update model) (define/public (queue-for-update model)
(semaphore-wait update-lock) (semaphore-wait update-lock)
(hash-set! update-queue model #t) (set! update-queue (hash-set update-queue model #t))
(semaphore-post update-lock) (semaphore-post update-lock)
(process-updates)) (process-updates))
@ -120,38 +130,33 @@ still be there, just not visible?
(parameterize ((current-eventspace eventspace)) (parameterize ((current-eventspace eventspace))
(queue-callback (queue-callback
(lambda () (lambda ()
(let ([models-to-update (grab+clear-update-queue)]) (let-values ([(adds updates) (grab+clear-update-queue)])
(for ([model models-to-update]) (for ([add (in-list adds)])
(add))
(for ([model (in-hash-keys updates)])
(do-model-update model))))))) (do-model-update model)))))))
;; grab+clear-update-queue : -> void ;; grab+clear-update-queue : -> (values list hash)
;; ** Must be called from eventspace thread. ;; ** Must be called from eventspace thread.
(define/private (grab+clear-update-queue) (define/private (grab+clear-update-queue)
(semaphore-wait update-lock) (semaphore-wait update-lock)
(if (positive? (hash-count update-queue)) (begin0
(let ([old-queue update-queue]) (values (reverse add-queue)
(set! update-queue (make-hasheq)) update-queue)
(semaphore-post update-lock) (set! add-queue null)
(reverse (set! update-queue '#hasheq())
(hash-map old-queue (lambda (k v) k)))) (semaphore-post update-lock)))
(begin (semaphore-post update-lock)
null)))
;; do-model-update : model<%> -> void ;; do-model-update : model<%> -> void
;; ** Must be called from eventspace thread. ;; ** Must be called from eventspace thread.
(define/private (do-model-update model) (define/private (do-model-update model)
(let ([view-link (get-view-link model)]) (let ([view-link (get-view-link model)])
(cond [view-link (unless view-link
(send tree-view update-item view-link) ;; should not be possible
(when (eq? model (get-selected-model)) (error 'rackunit-gui "internal error: no view-link"))
(show-model model))] (send tree-view update-item view-link)
[(not view-link) (when (eq? model (get-selected-model))
;; If the view-link has not been created, (show-model model))))
;; yield until it is.
(unless (yield)
(error 'rackunit-gui
"internal error: no progress waiting for view-link"))
(do-model-update model)])))
;; Update display ;; Update display