Moved in-update? flag from <tty-screen> to <screen>.

<gtk-screen> 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 5cc4fcd3d34451d0348d92b384ad013cfa7b7ac1..15c9b1dd01d4e5ed83e26658ed2c49c2156026c3 100644 (file)
--- 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 616a2718747c1dba5290de536c33284e1c7d8b8e..49ed4b79421d8a93cdbc0eb47492b97468f4ea62 100644 (file)
--- 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 <gtk-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 <gtk-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 <gtk-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 <gtk-screen>) display-style)
   (%trace "; (update-screen! <gtk-screen>) "screen" "display-style"\n")
-  (cond
-   ((display-style/no-screen-output? display-style)
-    (%trace "; (update-screen! <gtk-screen>) done: no-output\n")
-    'NO-OUTPUT)
-   ((eq? (screen-visibility screen) 'OBSCURED)
-    (update-name screen)
-    (%trace "; (update-screen! <gtk-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! <gtk-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! <gtk-screen>) done: finished\n")
-          #t)))))
+  (with-screen-in-update
+   screen
+   (lambda ()
+     (cond
+      ((display-style/no-screen-output? display-style)
+       (%trace "; (update-screen! <gtk-screen>) done: no-output\n")
+       'NO-OUTPUT)
+      ((eq? (screen-visibility screen) 'OBSCURED)
+       (update-name screen)
+       (%trace "; (update-screen! <gtk-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! <gtk-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! <gtk-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 <gtk-screen>) window display-style)
   (%trace "; (update-screen-window! <gtk-screen>) "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! <gtk-screen>) done: finished\n")
-             #t)
-           (begin
-             (%trace "; (update-screen-window! <gtk-screen>) done: halted\n")
-             #f)))))))
+  (let ((v (update-screens! display-style)))
+    (%trace "; (update-screen-window! <gtk-screen>) "screen" "window" => "v"\n")
+    v))
 
 (define (update-widget-buffer widget)
   (%trace ";     update-widget-buffer "widget"\n")