Smarter %trace syntax transformers. Fiddled some trace messages.

diff --git a/src/gtk-screen/gtk-screen.scm b/src/gtk-screen/gtk-screen.scm
index 88bed9e6cb84eea7c568ad723439ace52691a9d6..616a2718747c1dba5290de536c33284e1c7d8b8e 100644 (file)
--- a/src/gtk-screen/gtk-screen.scm
+++ b/src/gtk-screen/gtk-screen.scm
@@ -245,8 +245,9 @@ USA.
 
 (define (create-blinker-thread screen)
 
-  (define (%trace3 . args)
-    (if %trace-blinker? (apply outf-error args)))
+  (define-syntax %trace3
+    (syntax-rules ()
+      ((_ ARGS ...) (if %trace-blinker? (outf-error ARGS ...)))))
 
   (create-thread
    #f
@@ -1353,14 +1354,14 @@ USA.
 ;; redrawing.
 
 (define-method update-screen! ((screen <gtk-screen>) display-style)
-  (%trace ";((update-screen! <gtk-screen>) "screen")\n")
+  (%trace "; (update-screen! <gtk-screen>) "screen" "display-style"\n")
   (cond
    ((display-style/no-screen-output? display-style)
-    (%trace ";   display-style: no-output\n")
+    (%trace "; (update-screen! <gtk-screen>) done: no-output\n")
     'NO-OUTPUT)
    ((eq? (screen-visibility screen) 'OBSCURED)
     (update-name screen)
-    (%trace ";   display-style: completely obscured\n")
+    (%trace "; (update-screen! <gtk-screen>) done: completely obscured\n")
     'INVISIBLE)
    (else
     (update-name screen)
@@ -1374,7 +1375,7 @@ USA.
                 (%trace ";   update drawings done\n")
                 #t)
               (begin
-                (%trace ";   update drawings aborted\n")
+                (%trace "; (update-screen! <gtk-screen>) done: halted\n")
                 #f)))
         ;; From here on, drawings are up-to-date, a change region
         ;; notwithstanding.
@@ -1384,6 +1385,7 @@ USA.
           (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 (update-blinking screen)
@@ -1414,7 +1416,7 @@ USA.
 
 (define-method update-screen-window!
     ((screen <gtk-screen>) window display-style)
-  (%trace ";((update-screen-window! <gtk-screen>) "screen" "window")\n")
+  (%trace "; (update-screen-window! <gtk-screen>) "screen" "window"\n")
   (cond
    ((display-style/no-screen-output? display-style)
     (%trace ";   display-style: no-output\n")
@@ -1439,13 +1441,14 @@ USA.
              (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 ";   redraw aborted\n")
+             (%trace "; (update-screen-window! <gtk-screen>) done: halted\n")
              #f)))))))
 
-(define (update-widget-drawing widget)
-  (%trace ";     update-widget-drawing "widget"\n")
+(define (update-widget-buffer widget)
+  (%trace ";     update-widget-buffer "widget"\n")
   (let ((screen (edwin-widget-screen widget))
        (window (text-widget-buffer-frame widget)))
            
@@ -1524,7 +1527,8 @@ USA.
             (eq? (%window-char-image-strings bufwin)
                  (buffer-drawing-char-image-strings drawing)))))
 
-    (main)))
+    (main))
+  (%trace ";     update-widget-buffer done\n"))
 
 (define (update-window widget)
   (%trace ";     update-window "widget"\n")
@@ -1606,7 +1610,8 @@ USA.
                        (%trace ";\tupdated "modeline": \""copy"\"\n"))
                      (%trace ";\tunchanged "modeline"\n"))))
              (%trace ";\tno modeline\n")))
-       (%trace ";\tno widget!\n"))))
+       (%trace ";\tno widget!\n")))
+  (%trace ";     update-modeline done\n"))
 
 (define (update-name screen)
   (let ((name (frame-name screen))
@@ -1698,6 +1703,11 @@ USA.
                               (group-end-changes-index group)
                               (mark-index display-end))))
 
+    (define-syntax %trace3
+      (syntax-rules ()
+       ((_ ARGS ...) (if %trace-redraw?
+                         (apply outf-error (%trace-simplify ARGS ...))))))
+
     (define-integrable (main)
       (%trace3 ";\tdrawing/buffer ticks:"
               " "(buffer-drawing-modified-tick drawing)
@@ -2037,7 +2047,7 @@ USA.
        (if (not (fix:= old-num num))
            (set-line-ink-number! line num))
        (if (not (mark= start (line-ink-start line)))
-           (%trace3 "; Warning: mismatched "line"\n"))
+           (warn "mismatched line-ink start:" start line))
        (union-ink! line)
        (next-y-extent extent)))
 
@@ -2065,28 +2075,31 @@ USA.
            (set! pango-layout new)
            new)))
 
-    (define (%trace3 . args)
-      (if %trace-redraw? (apply outf-error (simplify args))))
-
-    (define (simplify args)
-      (map (lambda (obj)
-            (cond ((mark? obj) (mark-index obj))
-                  ((and (pair? obj) (line-ink? (car obj)))
-                   (list (car obj) '...))
-                  (else obj)))
-          args))
-
     (main)))
 
 (define %trace-redraw? #f)
 
+(define (%trace-simplify . args)
+  (map (lambda (obj)
+        (cond ((mark? obj) (mark-index obj))
+              ((and (pair? obj) (line-ink? (car obj)))
+               (list (car obj) '...))
+              (else obj)))
+       args))
+
 (define (redraw-line! line x y pango-layout)
   ;; Updates LINE by (re)parsing its buffer.  (Re)Images and
   ;; (re)lays-out the line to get its dimensions.  (Re)sizes LINE and
   ;; (re)positions it at (X, Y).  A separate PANGO-LAYOUT is (re)used
   ;; during this process, and any cached layout is cleared.
-  (%trace ";\t      redraw-line! "line" from "(line-ink-start line)
-        " ("x","y") with "pango-layout"\n")
+
+  (define-syntax %trace3
+    (syntax-rules ()
+      ((_ ARGS ...) (if %trace-redraw?
+                       (apply outf-error (%trace-simplify ARGS ...))))))
+
+  (%trace3 ";\t      redraw-line! "line" from "(line-ink-start line)
+          " ("x","y") with "pango-layout"\n")
   (clear-cached-pango-layout line)
   (layout-line! line pango-layout)
   (pango-layout-get-pixel-extents
@@ -2094,12 +2107,12 @@ USA.
    (lambda (width height)
      (without-interrupts
       (lambda ()
-       (%trace ";\t        erasing "(fix-ink-extent line)"\n")
+       (%trace3 ";\t        erasing "(fix-ink-extent line)"\n")
        (drawing-damage line)
        (let ((extent (fix-ink-extent line)))
          (set-fix-rect-size! extent width height)
          (set-fix-rect-position! extent x y))
-       (%trace ";\t        drawing "(fix-ink-extent line)"\n")
+       (%trace3 ";\t        drawing "(fix-ink-extent line)"\n")
        (drawing-damage line))))))
 
 (define image-buffer-size (* 50 1024))
@@ -2523,12 +2536,12 @@ USA.
 
 (define-syntax %trace
   (syntax-rules ()
-    ((_ . ARGS) (if %trace? ((lambda () (outf-error . ARGS)))))))
+    ((_ ARGS ...) (if %trace? (outf-error ARGS ...)))))
 
 (define %trace2? #f)
 
 (define-syntax %trace2
   (syntax-rules ()
-    ((_ . ARGS) (if %trace2? ((lambda () (outf-error . ARGS)))))))
+    ((_ ARGS ...) (if %trace2? (outf-error ARGS ...)))))
 
 (initialize-package!)
\ No newline at end of file