From d48332ed263877c4bf619da6247befb21c2a068a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 28 Jul 2009 18:30:21 +0000 Subject: [PATCH] fix for syntax coloring (4.2.1.4) svn: r15608 --- collects/framework/private/color.ss | 40 +++++++++++++++++---------- collects/syntax-color/module-lexer.ss | 9 ++++-- collects/syntax-color/token-tree.ss | 16 +++++++---- src/mzscheme/src/schvers.h | 4 +-- 4 files changed, 45 insertions(+), 24 deletions(-) diff --git a/collects/framework/private/color.ss b/collects/framework/private/color.ss index 8532fda14f..3aee99a9f2 100644 --- a/collects/framework/private/color.ss +++ b/collects/framework/private/color.ss @@ -104,6 +104,7 @@ added get-regions invalid-tokens ; = (new token-tree%) ;; The position right before the ainvalid-tokens tree invalid-tokens-start ; = +inf.0 + invalid-tokens-mode ;; The position right before the next token to be read current-pos ;; Thread a mode through lexing, and remember the mode @@ -126,6 +127,7 @@ added get-regions #t (new token-tree%) +inf.0 + #f start #f (new paren-tree% (matches pairs)))) @@ -264,9 +266,11 @@ added get-regions (< invalid-tokens-start (lexer-state-current-pos ls))) (send invalid-tokens search-min!) - (let ((length (send invalid-tokens get-root-length))) + (let ((length (send invalid-tokens get-root-length)) + (mode (data-lexer-mode (send invalid-tokens get-root-data)))) (send invalid-tokens remove-root!) - (set-lexer-state-invalid-tokens-start! ls (+ invalid-tokens-start length))) + (set-lexer-state-invalid-tokens-start! ls (+ invalid-tokens-start length)) + (set-lexer-state-invalid-tokens-mode! ls mode)) (sync-invalid ls)))) (define/private (re-tokenize ls in in-start-pos in-lexer-mode enable-suspend) @@ -303,7 +307,9 @@ added get-regions (cond ((and (not (send (lexer-state-invalid-tokens ls) is-empty?)) (= (lexer-state-invalid-tokens-start ls) - (lexer-state-current-pos ls))) + (lexer-state-current-pos ls)) + (equal? new-lexer-mode + (lexer-state-invalid-tokens-mode ls))) (send (lexer-state-invalid-tokens ls) search-max!) (send (lexer-state-parens ls) merge-tree (send (lexer-state-invalid-tokens ls) get-root-end-position)) @@ -320,8 +326,8 @@ added get-regions (sync-invalid ls)) (cond ((lexer-state-up-to-date? ls) - (let-values (((orig-token-start orig-token-end valid-tree invalid-tree) - (send (lexer-state-tokens ls) split (- edit-start-pos (lexer-state-start-pos ls))))) + (let-values (((orig-token-start orig-token-end valid-tree invalid-tree orig-data) + (send (lexer-state-tokens ls) split/data (- edit-start-pos (lexer-state-start-pos ls))))) (send (lexer-state-parens ls) split-tree orig-token-start) (set-lexer-state-invalid-tokens! ls invalid-tree) (set-lexer-state-tokens! ls valid-tree) @@ -330,6 +336,7 @@ added get-regions (if (send (lexer-state-invalid-tokens ls) is-empty?) +inf.0 (+ (lexer-state-start-pos ls) orig-token-end change-length))) + (set-lexer-state-invalid-tokens-mode! ls (and orig-data (data-lexer-mode orig-data))) (let ([start (+ (lexer-state-start-pos ls) orig-token-start)]) (set-lexer-state-current-pos! ls start) (set-lexer-state-current-lexer-mode! ls @@ -341,31 +348,34 @@ added get-regions (set-lexer-state-up-to-date?! ls #f) (queue-callback (λ () (colorer-callback)) #f))) ((>= edit-start-pos (lexer-state-invalid-tokens-start ls)) - (let-values (((tok-start tok-end valid-tree invalid-tree) - (send (lexer-state-invalid-tokens ls) split + (let-values (((tok-start tok-end valid-tree invalid-tree orig-data) + (send (lexer-state-invalid-tokens ls) split/data (- edit-start-pos (lexer-state-start-pos ls))))) (set-lexer-state-invalid-tokens! ls invalid-tree) (set-lexer-state-invalid-tokens-start! ls - (+ (lexer-state-invalid-tokens-start ls) tok-end change-length)))) + (+ (lexer-state-invalid-tokens-start ls) tok-end change-length)) + (set-lexer-state-invalid-tokens-mode! ls (and orig-data (data-lexer-mode orig-data))))) ((> edit-start-pos (lexer-state-current-pos ls)) (set-lexer-state-invalid-tokens-start! ls (+ change-length (lexer-state-invalid-tokens-start ls)))) (else - (let-values (((tok-start tok-end valid-tree invalid-tree) - (send (lexer-state-tokens ls) split + (let-values (((tok-start tok-end valid-tree invalid-tree data) + (send (lexer-state-tokens ls) split/data (- edit-start-pos (lexer-state-start-pos ls))))) (send (lexer-state-parens ls) truncate tok-start) (set-lexer-state-tokens! ls valid-tree) (set-lexer-state-invalid-tokens-start! ls (+ change-length (lexer-state-invalid-tokens-start ls))) (let ([start (+ (lexer-state-start-pos ls) tok-start)]) (set-lexer-state-current-pos! ls start) - (if (= start (lexer-state-start-pos ls)) - #f - (begin - (send valid-tree search-max!) - (data-lexer-mode (send valid-tree get-root-data))))))))) + (set-lexer-state-current-lexer-mode! + ls + (if (= start (lexer-state-start-pos ls)) + #f + (begin + (send valid-tree search-max!) + (data-lexer-mode (send valid-tree get-root-data)))))))))) (define/private (do-insert/delete edit-start-pos change-length) (unless (or stopped? force-stop?) diff --git a/collects/syntax-color/module-lexer.ss b/collects/syntax-color/module-lexer.ss index ae9e997ae3..a1d4c08291 100644 --- a/collects/syntax-color/module-lexer.ss +++ b/collects/syntax-color/module-lexer.ss @@ -34,11 +34,16 @@ v))) scheme-lexer)))] [(eq? 'fail get-info) - (copy-port in (open-output-nowhere)) (let*-values ([(end-line end-col end-pos) (port-next-location in)]) (values #f 'error #f start-pos end-pos (lambda (in) - (values #f 'eof #f end-pos end-pos))))] + (let-values ([(line col pos) (port-next-location in)]) + (if (eof-object? (peek-byte in)) + (values #f 'eof #f pos pos) + (begin + (copy-port in (open-output-nowhere)) + (let-values ([(end-line end-col end-pos) (port-next-location in)]) + (values #f 'other #f pos end-pos))))))))] [else ;; Start over using the Scheme lexer (module-lexer in scheme-lexer)])))] diff --git a/collects/syntax-color/token-tree.ss b/collects/syntax-color/token-tree.ss index 729c332161..933f04cf44 100644 --- a/collects/syntax-color/token-tree.ss +++ b/collects/syntax-color/token-tree.ss @@ -257,14 +257,15 @@ ;; pos is on a token boundary, 2 tokens will be dropped. ;; In this case, the start will be for the first dropped ;; token and the stop will be for the second. - (define/public (split pos) + (define/public (split/data pos) (search! pos) (let ((t1 (new token-tree%)) (t2 (new token-tree%))) (cond (root (let ((second-start (get-root-start-position)) - (second-stop (get-root-end-position))) + (second-stop (get-root-end-position)) + (data (node-token-data root))) (send t1 set-root (node-left root)) (send t2 set-root (node-right root)) (set! root #f) @@ -273,10 +274,15 @@ (send t1 search-max!) (let ((first-start (send t1 get-root-start-position))) (send t1 remove-root!) - (values first-start second-stop t1 t2))) + (values first-start second-stop t1 t2 data))) (else - (values second-start second-stop t1 t2))))) - (else (values 0 0 t1 t2))))) + (values second-start second-stop t1 t2 data))))) + (else (values 0 0 t1 t2 #f))))) + + (define/public (split pos) + (let-values ([(orig-token-start orig-token-end valid-tree invalid-tree orig-data) + (split/data pos)]) + (values orig-token-start orig-token-end valid-tree invalid-tree))) ;; (define/public (split) ;; (let ((t1 (new token-tree%)) diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index 170fa9715a..c9b3fd48b5 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.2.1.3" +#define MZSCHEME_VERSION "4.2.1.4" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 2 #define MZSCHEME_VERSION_Z 1 -#define MZSCHEME_VERSION_W 3 +#define MZSCHEME_VERSION_W 4 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)