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

.

Browse Source 
original commit: d034b3a72827725928870e1abb4f3cb88e46d9e9
This commit is contained in:
Matthew Flatt 2004-05-12 00:49:40 +00:00
parent c08f5fadb9
commit 60b9849aa3
1 changed files with 45 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

99
collects/framework/private/color.ss
View File

@ -169,41 +169,39 @@
;; breaks disabled re-tokenize should be called when lock is not ;; breaks disabled re-tokenize should be called when lock is not
;; held. When it exits, the lock will be held. ;; held. When it exits, the lock will be held.
(define/private (re-tokenize in in-start-pos) (define/private (re-tokenize in in-start-pos)
(let-values (((lexeme type data new-token-start new-token-end) (get-token in))) (let-values ([(lexeme type data new-token-start new-token-end)
;; breaks must be disabled before the semaphore wait so we can't be ;; Allow breaks while getting tokens
;; broken out of the critical section (parameterize-break #t
(break-enabled #f) (get-token in))])
;; If a break occurs while we are suspended, the break will occur ;; Also allow breaks while trying to enter the critical region:
;; and the critical section will not be entered (semaphore-wait/enable-break mutex-lock)
(semaphore-wait/enable-break mutex-lock) (unless (eq? 'eof type)
(unless (eq? 'eof type) (let ((len (- new-token-end new-token-start)))
(let ((len (- new-token-end new-token-start))) (set! current-pos (+ len current-pos))
(set! current-pos (+ len current-pos)) (sync-invalid)
(sync-invalid) (when (and should-color? (should-color-type? type) (not frozen?))
(when (and should-color? (should-color-type? type) (not frozen?)) (set! colors
(set! colors (cons
(cons (let ((color (send (get-style-list) find-named-style
(let ((color (send (get-style-list) find-named-style (token-sym->style type)))
(token-sym->style type))) (sp (+ in-start-pos (sub1 new-token-start)))
(sp (+ in-start-pos (sub1 new-token-start))) (ep (+ in-start-pos (sub1 new-token-end))))
(ep (+ in-start-pos (sub1 new-token-end)))) (lambda ()
(lambda () (change-style color sp ep #f)))
(change-style color sp ep #f))) colors)))
colors))) (insert-last! tokens (new token-tree% (length len) (data type)))
(insert-last! tokens (new token-tree% (length len) (data type))) (send parens add-token data len)
(send parens add-token data len) (cond
(cond ((and (not (send invalid-tokens is-empty?))
((and (not (send invalid-tokens is-empty?)) (= invalid-tokens-start current-pos))
(= invalid-tokens-start current-pos)) (send invalid-tokens search-max!)
(send invalid-tokens search-max!) (send parens merge-tree
(send parens merge-tree (send invalid-tokens get-root-end-position))
(send invalid-tokens get-root-end-position)) (insert-last! tokens invalid-tokens)
(insert-last! tokens invalid-tokens) (set! invalid-tokens-start +inf.0))
(set! invalid-tokens-start +inf.0)) (else
(else (semaphore-post mutex-lock)
(semaphore-post mutex-lock) (re-tokenize in in-start-pos)))))))
(break-enabled #t)
(re-tokenize in in-start-pos)))))))
(define/private (do-insert/delete edit-start-pos change-length) (define/private (do-insert/delete edit-start-pos change-length)
(unless (or stopped? force-stop?) (unless (or stopped? force-stop?)
@ -274,22 +272,15 @@
(let/ec restart (let/ec restart
(parameterize ((current-exception-handler (parameterize ((current-exception-handler
(lambda (exn) (lambda (exn)
;; Lock is not held here because breaks are disabled
;; whenever lock is held
(break-enabled #f)
(restart)))) (restart))))
(break-enabled #t) (with-handlers ((exn:fail?
(with-handlers ((exn:fail? (lambda (exn)
(lambda (exn) (parameterize ((print-struct #t))
(parameterize ((print-struct #t)) (printf "colorer thread: ~s\n" exn))
(printf "colorer thread: ~s\n" exn)) (semaphore-wait mutex-lock))))
(break-enabled #f) (re-tokenize (open-input-text-editor this current-pos end-pos
(semaphore-wait mutex-lock)))) (lambda (x) (values #f 1)))
(re-tokenize (open-input-text-editor this current-pos end-pos current-pos))
(lambda (x) (values #f 1)))
current-pos))
;; Breaks should be disabled from exit of re-tokenize
;; lock will be held
(set! up-to-date? #t) (set! up-to-date? #t)
(semaphore-post mutex-lock) (semaphore-post mutex-lock)
(thread-suspend (current-thread)))) (thread-suspend (current-thread))))
@ -313,10 +304,10 @@
(set! pairs pairs-) (set! pairs pairs-)
(set! parens (new paren-tree% (matches pairs))) (set! parens (new paren-tree% (matches pairs)))
(unless background-thread (unless background-thread
(break-enabled #f) ;; Create background thread with breaks initially disabled:
(set! background-thread (parameterize-break #f
(thread (lambda () (background-colorer-entry)))) (set! background-thread
(break-enabled #t)) (thread (lambda () (background-colorer-entry))))))
(do-insert/delete start-pos 0))) (do-insert/delete start-pos 0)))
;; See docs ;; See docs