From: Matt Birkholz Date: Wed, 14 Sep 2011 20:02:37 +0000 (-0700) Subject: Moved in-update? flag from to . X-Git-Tag: mit-scheme-pucked-9.2.12~366^2~108 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c92697b4d9c7c3f3ef1632a4f233991b554d133e;p=mit-scheme.git Moved in-update? flag from to . can use this in its window coord. operations, to avoid looping in with-updated-window. Some of the ops, like window-mark-visible?, are used at the end of screen update and so do not need to (shouldn't!) call update-screens!. Called during command execution, these same ops need to update-screens! (or at least their window's buffer drawing). --- diff --git a/src/edwin/screen.scm b/src/edwin/screen.scm index 5cc4fcd3d..15c9b1dd0 100644 --- a/src/edwin/screen.scm +++ b/src/edwin/screen.scm @@ -41,6 +41,8 @@ USA. (x-size define standard initial-value #f) (y-size define standard initial-value #f) + (in-update? define standard initial-value #f) + ;; Set this variable in the debugger to trace interesting events. (debug-trace define standard initial-value #f)) @@ -86,7 +88,6 @@ USA. (operation/write-substring! define accessor) (preemption-modulus define accessor initial-value #f) (needs-update? define standard initial-value #f) - (in-update? define standard initial-value #f) ;; Description of actual screen contents. (current-matrix define standard) @@ -727,8 +728,8 @@ USA. (define (with-tty-screen-in-update screen display-style thunk) (without-interrupts (lambda () - (let ((old-flag (tty-screen-in-update? screen))) - (set-tty-screen-in-update?! screen true) + (let ((old-flag (screen-in-update? screen))) + (set-screen-in-update?! screen true) (let ((finished? ((tty-screen-operation/wrap-update! screen) screen @@ -745,7 +746,7 @@ USA. (tty-screen-update-cursor screen) #t)) 'INVISIBLE)))))) - (set-tty-screen-in-update?! screen old-flag) + (set-screen-in-update?! screen old-flag) finished?))))) (define (tty-screen-update-cursor screen) diff --git a/src/gtk-screen/gtk-screen.scm b/src/gtk-screen/gtk-screen.scm index 616a27187..49ed4b794 100644 --- a/src/gtk-screen/gtk-screen.scm +++ b/src/gtk-screen/gtk-screen.scm @@ -310,7 +310,7 @@ USA. frame y-point) (%trace "; screen/window-scroll-y-absolute! "screen" "frame" "y-point"\n") (with-updated-window - frame 'SCROLL-Y-ABSOLUTE! + screen frame 'SCROLL-Y-ABSOLUTE! (lambda (widget) (let ((cursor (text-widget-cursor-ink widget)) (view (fix-layout-view widget))) @@ -335,30 +335,29 @@ USA. (fix-layout-scroll-to! widget x y*) (update-start-mark widget))) -(define (with-updated-window frame what operation) - (let* ((widget (window-text-widget* frame)) - (widget* (or widget - (let ((screen (window-screen frame))) - (%trace "; forcibly updating "screen" for "what"\n") - (update-widgets screen) - (window-text-widget* frame))))) - (if (not widget*) - (error "No widget:" frame)) - (if (and widget ignore-change-region) - (operation widget) - (begin - (%trace "; forcibly updating "widget*" for "what"\n") - (and (update-drawing (window-screen frame) - (text-widget-buffer-drawing widget*)) - (fluid-let ((ignore-change-region #t)) - (update-window widget) - (operation widget))))))) +(define (with-updated-window screen frame what operation) + (%trace "; with-updated-window "screen" "frame" "what"\n") + + (if (not (screen-in-update? screen)) + ;; Don't loop when used during screen update(!). + (begin + (%trace "; forcing update...\n") + (update-screens! #t) + (%trace "; ...forced update finished.\n")) + (%trace "; in update, with widget "(window-text-widget* frame)"\n")) + + (let ((widget (window-text-widget* frame))) + (if (not widget) (error "No widget:" frame)) + (%trace "; "what"...\n") + (let ((value (operation widget))) + (%trace "; ..."what" => "value"\n") + value))) (define-method screen/window-scroll-y-relative! ((screen ) frame delta) (%trace "; screen/window-scroll-y-relative! "screen" "frame" "delta"\n") (with-updated-window - frame 'SCROLL-Y-RELATIVE! + screen frame 'SCROLL-Y-RELATIVE! (lambda (widget) (let ((view (fix-layout-view widget)) (delta* (row->y screen delta))) @@ -371,7 +370,7 @@ USA. frame mark force?) (%trace "; screen/set-window-start-mark! "screen" "frame" "mark" "force?"\n") (with-updated-window - frame 'SET-START-MARK! + screen frame 'SET-START-MARK! (lambda (widget) (let ((view (fix-layout-view widget)) (line (find-line-at mark widget))) @@ -395,7 +394,7 @@ USA. (define-method screen/window-mark-visible? ((screen ) frame mark) (%trace "; screen/window-mark-visible? "screen" "frame" "mark"\n") (with-updated-window - frame 'MARK-VISIBLE? + screen frame 'MARK-VISIBLE? (lambda (widget) (let ((view (fix-layout-view widget)) (line (find-line-at mark widget))) @@ -421,7 +420,7 @@ USA. (define-method screen/window-mark->y ((screen ) frame mark) (%trace "; screen/window-mark->y "screen" "frame" "mark"\n") (with-updated-window - frame 'MARK->Y + screen frame 'MARK->Y (lambda (widget) (line->row screen widget (find-line-at mark widget))))) @@ -439,7 +438,7 @@ USA. frame mark) (%trace "; screen/window-mark->coordinates "screen" "frame" "mark"\n") (with-updated-window - frame 'MARK->COORDINATES + screen frame 'MARK->COORDINATES (lambda (widget) (let ((line (find-line-at mark widget))) (cons @@ -459,7 +458,7 @@ USA. frame x y) (%trace "; screen/window-coordinates->mark "screen" "frame" "x" "y"\n") (with-updated-window - frame 'COORDINATES->MARK + screen frame 'COORDINATES->MARK (lambda (widget) (let* ((y* (fix:+ (row->y screen y) (fix-rect-y (fix-layout-view widget)))) @@ -1355,38 +1354,50 @@ USA. (define-method update-screen! ((screen ) display-style) (%trace "; (update-screen! ) "screen" "display-style"\n") - (cond - ((display-style/no-screen-output? display-style) - (%trace "; (update-screen! ) done: no-output\n") - 'NO-OUTPUT) - ((eq? (screen-visibility screen) 'OBSCURED) - (update-name screen) - (%trace "; (update-screen! ) done: completely obscured\n") - 'INVISIBLE) - (else - (update-name screen) - (update-widgets screen) - (and (begin - (%trace "; update drawings\n") - (for-each-text-widget screen update-widget-drawing) - (if (every (lambda (entry) (update-drawing screen (cdr entry))) - (gtk-screen-drawings screen)) - (begin - (%trace "; update drawings done\n") - #t) - (begin - (%trace "; (update-screen! ) done: halted\n") - #f))) - ;; From here on, drawings are up-to-date, a change region - ;; notwithstanding. - (fluid-let ((ignore-change-region #t)) - (%trace "; update windows\n") - (for-each-text-widget screen update-window) - (if (display-style/discard-screen-contents? display-style) - (for-each-text-widget screen gtk-widget-queue-draw)) - (update-blinking screen) - (%trace "; (update-screen! ) done: finished\n") - #t))))) + (with-screen-in-update + screen + (lambda () + (cond + ((display-style/no-screen-output? display-style) + (%trace "; (update-screen! ) done: no-output\n") + 'NO-OUTPUT) + ((eq? (screen-visibility screen) 'OBSCURED) + (update-name screen) + (%trace "; (update-screen! ) done: completely obscured\n") + 'INVISIBLE) + (else + (update-name screen) + (update-widgets screen) + (and (begin + (%trace "; update drawings\n") + (for-each-text-widget screen update-widget-buffer) + (if (every (lambda (entry) (update-drawing screen (cdr entry))) + (gtk-screen-drawings screen)) + (begin + (%trace "; update drawings done\n") + #t) + (begin + (%trace "; (update-screen! ) done: halted\n") + #f))) + ;; From here on, drawings are up-to-date, a change region + ;; notwithstanding. + (fluid-let ((ignore-change-region #t)) + (%trace "; update windows\n") + (for-each-text-widget screen update-window) + (if (display-style/discard-screen-contents? display-style) + (for-each-text-widget screen gtk-widget-queue-draw)) + (update-blinking screen) + (%trace "; (update-screen! ) done: finished\n") + #t))))))) + +(define-integrable with-screen-in-update + (named-lambda (with-screen-in-update screen thunk) + (if (screen-in-update? screen) + (error "Recursive update:" screen)) + (set-screen-in-update?! screen #t) + (let ((v (thunk))) + (set-screen-in-update?! screen #f) + v))) (define (update-blinking screen) ;; Sometimes called by a callback (i.e. without-interrupts). Frobs @@ -1417,35 +1428,9 @@ USA. (define-method update-screen-window! ((screen ) window display-style) (%trace "; (update-screen-window! ) "screen" "window"\n") - (cond - ((display-style/no-screen-output? display-style) - (%trace "; display-style: no-output\n") - 'NO-OUTPUT) - ((not (memq (screen-visibility screen) '(VISIBLE PARTIALLY-OBSCURED))) - (update-name screen) - (%trace "; display-style: completely obscured\n") - 'INVISIBLE) - ((null? (gtk-container-reverse-children (gtk-screen-toplevel screen))) - (%trace "; uninitialized "screen"\n") - 'UNINITIALIZED) - (else - (update-name screen) - (let ((widget (window-text-widget* window))) - (if (not widget) (error "No widget:" window)) - (let ((drawing (text-widget-buffer-drawing widget))) - (if (not drawing) (error "No drawing:" widget)) - (if (update-drawing screen drawing) - (fluid-let ((ignore-change-region #t)) - (%trace "; redraw finished\n") - (update-window widget) - (if (display-style/discard-screen-contents? display-style) - (gtk-widget-queue-draw widget)) - (gdk-window-process-updates (fix-layout-window widget) #f) - (%trace "; (update-screen-window! ) done: finished\n") - #t) - (begin - (%trace "; (update-screen-window! ) done: halted\n") - #f))))))) + (let ((v (update-screens! display-style))) + (%trace "; (update-screen-window! ) "screen" "window" => "v"\n") + v)) (define (update-widget-buffer widget) (%trace "; update-widget-buffer "widget"\n")