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

fix to work around race condition

Browse Source 
svn: r14962
This commit is contained in:
Robby Findler 2009-05-23 19:45:58 +00:00
parent cf5b14f626
commit 148d945fbe
1 changed files with 47 additions and 35 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

82
collects/drscheme/syncheck.ss
View File

@ -241,6 +241,8 @@ If the namespace does not, they are colored the unbound color.
;; string))))))
(define arrow-vectors #f)
;; cleanup-texts : (or/c #f (listof text))
(define cleanup-texts #f)
;; bindings-table : hash-table[(list text number number) -o> (listof (list text number number))]
;; this is a private field
@ -385,6 +387,7 @@ If the namespace does not, they are colored the unbound color.
(set! tacked-hash-table (make-hasheq))
(set! arrow-vectors (make-hasheq))
(set! bindings-table (make-hash))
(set! cleanup-texts '())
(let ([f (get-top-level-window)])
(when f
(send f open-status-line 'drscheme:check-syntax:mouse-over))))
@ -405,48 +408,69 @@ If the namespace does not, they are colored the unbound color.
(set! cursor-location #f)
(set! cursor-text #f)
(set! cursor-eles #f)
(when cleanup-texts
(for-each (λ (text) (send text thaw-colorer))
cleanup-texts))
(set! cleanup-texts #f)
(when any-tacked?
(invalidate-bitmap-cache))
(update-docs-background #f)
(let ([f (get-top-level-window)])
(when f
(send f close-status-line 'drscheme:check-syntax:mouse-over))))))
;; syncheck:add-to-cleanup-texts : (is-a?/c text%) -> void
(define/public (syncheck:add-to-cleanup-texts txt)
(cond
[cleanup-texts
(unless (memq txt cleanup-texts)
(send txt freeze-colorer)
(set! cleanup-texts (cons txt cleanup-texts)))
#t]
[else #f]))
(define/public (syncheck:add-menu text start-pos end-pos key make-menu)
(when (and (<= 0 start-pos end-pos (last-position)))
(add-to-range/key text start-pos end-pos make-menu key #t)))
(when arrow-vectors
(when (and (<= 0 start-pos end-pos (last-position)))
(add-to-range/key text start-pos end-pos make-menu key #t))))
(define/public (syncheck:add-background-color text color start fin key)
(when (is-a? text text:basic<%>)
(add-to-range/key text start fin (make-colored-region color text start fin) key #f)))
(when arrow-vectors
(when (is-a? text text:basic<%>)
(add-to-range/key text start fin (make-colored-region color text start fin) key #f))))
;; syncheck:add-arrow : symbol text number number text number number boolean -> void
;; pre: start-editor, end-editor are embedded in `this' (or are `this')
(define/public (syncheck:add-arrow start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right
actual? level)
(let* ([arrow (make-var-arrow #f #f #f #f
start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right
actual? level)])
(when (add-to-bindings-table
start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right)
(add-to-range/key start-text start-pos-left start-pos-right arrow #f #f)
(add-to-range/key end-text end-pos-left end-pos-right arrow #f #f))))
(when arrow-vectors
(let* ([arrow (make-var-arrow #f #f #f #f
start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right
actual? level)])
(when (add-to-bindings-table
start-text start-pos-left start-pos-right
end-text end-pos-left end-pos-right)
(add-to-range/key start-text start-pos-left start-pos-right arrow #f #f)
(add-to-range/key end-text end-pos-left end-pos-right arrow #f #f)))))
;; syncheck:add-tail-arrow : text number text number -> void
(define/public (syncheck:add-tail-arrow from-text from-pos to-text to-pos)
(let ([tail-arrow (make-tail-arrow #f #f #f #f to-text to-pos from-text from-pos)])
(add-to-range/key from-text from-pos (+ from-pos 1) tail-arrow #f #f)
(add-to-range/key to-text to-pos (+ to-pos 1) tail-arrow #f #f)))
(when arrow-vectors
(let ([tail-arrow (make-tail-arrow #f #f #f #f to-text to-pos from-text from-pos)])
(add-to-range/key from-text from-pos (+ from-pos 1) tail-arrow #f #f)
(add-to-range/key to-text to-pos (+ to-pos 1) tail-arrow #f #f))))
;; syncheck:add-jump-to-definition : text start end id filename -> void
(define/public (syncheck:add-jump-to-definition text start end id filename)
(add-to-range/key text start end (make-def-link id filename) #f #f))
(when arrow-vectors
(add-to-range/key text start end (make-def-link id filename) #f #f)))
;; syncheck:add-mouse-over-status : text pos-left pos-right string -> void
(define/public (syncheck:add-mouse-over-status text pos-left pos-right str)
(add-to-range/key text pos-left pos-right str #f #f))
(when arrow-vectors
(add-to-range/key text pos-left pos-right str #f #f)))
;; add-to-range/key : text number number any any boolean -> void
;; adds `key' to the range `start' - `end' in the editor
@ -981,17 +1005,12 @@ If the namespace does not, they are colored the unbound color.
(when (is-current-tab?)
(send (get-frame) hide-error-report)))
(define cleanup-texts '())
(define/public (syncheck:clear-highlighting)
(let* ([definitions (get-defs)]
[locked? (send definitions is-locked?)])
(send definitions begin-edit-sequence #f)
(send definitions lock #f)
(send definitions syncheck:clear-arrows)
(for-each (λ (text)
(send text thaw-colorer))
cleanup-texts)
(set! cleanup-texts '())
(send definitions lock locked?)
(send definitions end-edit-sequence)))
@ -1004,12 +1023,6 @@ If the namespace does not, they are colored the unbound color.
(send (get-defs) syncheck:clear-arrows)
(inner (void) on-close))
;; syncheck:add-to-cleanup-texts : (is-a?/c text%) -> void
(define/public (syncheck:add-to-cleanup-texts txt)
(unless (memq txt cleanup-texts)
(send txt freeze-colorer)
(set! cleanup-texts (cons txt cleanup-texts))))
(super-new)))
(define unit-frame-mixin
@ -2416,8 +2429,8 @@ If the namespace does not, they are colored the unbound color.
(let ([style (send (send source get-style-list)
find-named-style
style-name)])
(add-to-cleanup-texts source)
(send source change-style style start finish #f)))
(when (add-to-cleanup-texts source)
(send source change-style style start finish #f))))
;; hash-table[syntax -o> (listof syntax)] -> void
(define (add-tail-ht-links tail-ht)
@ -2488,10 +2501,9 @@ If the namespace does not, they are colored the unbound color.
;; add-to-cleanup-texts : (is-a?/c editor<%>) -> void
(define (add-to-cleanup-texts ed)
(let ([ed (find-outermost-editor ed)])
(when (is-a? ed drscheme:unit:definitions-text<%>)
(let ([tab (send ed get-tab)])
(send tab syncheck:add-to-cleanup-texts ed)))))
(let ([outermost (find-outermost-editor ed)])
(and (is-a? outermost drscheme:unit:definitions-text<%>)
(send outermost syncheck:add-to-cleanup-texts ed))))
(define (find-outermost-editor ed)
(let loop ([ed ed])