From: Matt Birkholz Date: Wed, 14 Sep 2011 18:38:23 +0000 (-0700) Subject: Smarter %trace syntax transformers. Fiddled some trace messages. X-Git-Tag: mit-scheme-pucked-9.2.12~366^2~109 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=308ab266902b4347e4320be79dd236aa2b18447c;p=mit-scheme.git 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 88bed9e6c..616a27187 100644 --- 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 ) display-style) - (%trace ";((update-screen! ) "screen")\n") + (%trace "; (update-screen! ) "screen" "display-style"\n") (cond ((display-style/no-screen-output? display-style) - (%trace "; display-style: no-output\n") + (%trace "; (update-screen! ) done: no-output\n") 'NO-OUTPUT) ((eq? (screen-visibility screen) 'OBSCURED) (update-name screen) - (%trace "; display-style: completely obscured\n") + (%trace "; (update-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! ) 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! ) done: finished\n") #t))))) (define (update-blinking screen) @@ -1414,7 +1416,7 @@ USA. (define-method update-screen-window! ((screen ) window display-style) - (%trace ";((update-screen-window! ) "screen" "window")\n") + (%trace "; (update-screen-window! ) "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! ) done: finished\n") #t) (begin - (%trace "; redraw aborted\n") + (%trace "; (update-screen-window! ) 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