From cb73e1afb8ba078da164a09b382fcf234979a049 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Sun, 16 Jan 2011 18:09:48 -0700 Subject: [PATCH] Gerroff the global TRACE binding; use %trace instead. --- src/gtk/fix-demo.scm | 56 ++++++++++++++--------------- src/gtk/fix-layout.scm | 81 +++++++++++++++++++++--------------------- src/gtk/gobject.scm | 24 ++++++------- src/gtk/gtk-ev.scm | 30 ++++++++-------- src/gtk/gtk-object.scm | 6 ++-- src/gtk/swat.scm | 68 +++++++++++++++++------------------ src/gtk/thread.scm | 10 +++--- src/runtime/thread.scm | 40 ++++++++++----------- 8 files changed, 158 insertions(+), 157 deletions(-) diff --git a/src/gtk/fix-demo.scm b/src/gtk/fix-demo.scm index e43a66889..fd682af89 100644 --- a/src/gtk/fix-demo.scm +++ b/src/gtk/fix-demo.scm @@ -35,7 +35,7 @@ USA. (gtk-window-set-title window "fix-layout-demo") (gtk-window-set-default-size window 200 400) (set-gtk-window-delete-event-callback! - window (lambda (w) (trace "; Closed "w".\n") 0)) + window (lambda (w) (%trace "; Closed "w".\n") 0)) (gtk-container-set-border-width window 10) (gtk-container-add scroller1 layout1) (gtk-container-add vbox scroller1) @@ -53,13 +53,13 @@ USA. (set-demo-drawing-cursor-inks! drawing (list (list cursor1 layout1) (list cursor2 layout2)))) (let ((thread (start-blinking drawing))) - (trace "; Cursor blinking courtesy of "thread".\n")) + (%trace "; Cursor blinking courtesy of "thread".\n")) (let ((thread (start-spinning drawing))) - (trace "; Ring spinning courtesy of "thread".\n")) + (%trace "; Ring spinning courtesy of "thread".\n")) (set-fix-layout-drawing! layout1 drawing 175 150) (set-fix-layout-drawing! layout2 drawing 175 150)) (gtk-widget-grab-focus layout1) - (trace "; Created "layout1" and "layout2"\n")) + (%trace "; Created "layout1" and "layout2"\n")) unspecific) (define-class ( (constructor () (width height))) @@ -78,7 +78,7 @@ USA. (define (make-demo-drawing widget) (let ((drawing (%make-demo-drawing))) - (trace ";make-demo-drawing: "drawing"\n") + (%trace ";make-demo-drawing: "drawing"\n") (set-fix-drawing-size! drawing 500 500) (let ((line1 (make-line-ink)) (line2 (make-line-ink)) @@ -119,19 +119,19 @@ USA. (cursor-inks define standard initial-value '())) (define (demo-motion-handler layout modifiers window-x window-y) - (trace2 ";motion-handler "layout" "modifiers" "window-x" "window-y"\n") + (%trace2 ";motion-handler "layout" "modifiers" "window-x" "window-y"\n") (let* ((drawing (fix-layout-drawing layout)) (view (fix-layout-view layout)) (x (+ window-x (fix-rect-x view))) (y (+ window-y (fix-rect-y view)))) - (trace2 "; Pointer moved to ("x","y") in "layout".\n") + (%trace2 "; Pointer moved to ("x","y") in "layout".\n") (for-each (lambda (ink) (if (not (text-ink? ink)) - (trace "; Picked: "ink"\n") + (%trace "; Picked: "ink"\n") (let ((index (text-ink-xy-to-index ink x y)) (text-extent (fix-ink-extent ink))) - (trace "; Picked: "index" in "(simple-text-ink-text ink)"\n") + (%trace "; Picked: "index" in "(simple-text-ink-text ink)"\n") (with-text-ink-grapheme-rect ink index (lambda (xG yG widthG heightG) @@ -153,7 +153,7 @@ USA. #t) (define (demo-button-release-handler layout type button modifiers window-x window-y) - (trace2 ";button-release-handler "layout" "type" "button" "modifiers" "window-x" "window-y"\n") + (%trace2 ";button-release-handler "layout" "type" "button" "modifiers" "window-x" "window-y"\n") (let* ((drawing (fix-layout-drawing layout)) (view (fix-layout-view layout)) (x (+ window-x (fix-rect-x view))) @@ -162,14 +162,14 @@ USA. (for-each (lambda (ink) (if (not (text-ink? ink)) - (trace "; Picked: "ink"\n") + (%trace "; Picked: "ink"\n") (let ((index (text-ink-xy-to-index ink x y))) - (trace "; Picked: "ink" (char "index")\n")))) + (%trace "; Picked: "ink" (char "index")\n")))) (fix-drawing-pick-list drawing layout x y))) #t) (define (demo-key-press-handler layout keyval char-bits) - (trace "; Key press on "layout"\n") + (%trace "; Key press on "layout"\n") (outf-console "; Keyval: "keyval" "char-bits"\n") (if (and (char? keyval) (char=? keyval #\D)) (bkpt 'Test)) @@ -185,7 +185,7 @@ USA. (create-thread #f (lambda () - (trace ";spinning start\n") + (%trace ";spinning start\n") (let* ((frames 10) (x 270) (y 190) (height 30) (width 30) (pi (* (atan 1 1) 4)) @@ -201,12 +201,12 @@ USA. (let ((half-width (vector-ref half-widths frame))) (let ((x (fix:- x half-width)) (width (fix:* 2 half-width))) - (trace2 ";spinning to "width"\n") + (%trace2 ";spinning to "width"\n") (set-arc-ink! arc x y width height))) (let ((widgets (fix-drawing-widgets drawing))) (if (and (not (null? widgets)) (for-all? widgets gtk-object-destroyed?)) - (trace ";spinning ended\n") + (%trace ";spinning ended\n") (loop (modulo (fix:1+ frame) frames))))))))) (define (start-blinking drawing) @@ -218,20 +218,20 @@ USA. (create-thread #f (lambda () - (trace ";blinking start\n") + (%trace ";blinking start\n") (let loop () ;; Off! (for-each (lambda (cursor.widgets) (set-fix-ink-widgets! (car cursor.widgets) '())) (demo-drawing-cursor-inks drawing)) - (trace2 ";blinked off\n") + (%trace2 ";blinked off\n") (sleep-current-thread 500) ;; On! (for-each (lambda (cursor.widgets) (set-fix-ink-widgets! (car cursor.widgets) (cdr cursor.widgets))) (demo-drawing-cursor-inks drawing)) - (trace2 ";blinked on\n") + (%trace2 ";blinked on\n") (sleep-current-thread 500) (if (there-exists? (demo-drawing-cursor-inks drawing) @@ -239,17 +239,17 @@ USA. (there-exists? (cdr cursor.widgets) (lambda (w) (not (gtk-object-destroyed? w)))))) (loop) - (trace ";blinking ended\n")))))) + (%trace ";blinking ended\n")))))) -(define trace? #f) -(define trace2? #f) +(define %trace? #f) +(define %trace2? #f) -;; (trace...) syntax can avoid evaluating expensive expressions among -;; the argument forms when the corresponding trace? flag is off. -(define-syntax trace +;; The (%trace...) syntax avoids evaluating expensive expressions among +;; the argument forms when its corresponding %trace? flag is off. +(define-syntax %trace (syntax-rules () - ((_ . ARGS) (if trace? ((lambda () (outf-console . ARGS))))))) -(define-syntax trace2 + ((_ . ARGS) (if %trace? ((lambda () (outf-console . ARGS))))))) +(define-syntax %trace2 (syntax-rules () - ((_ . ARGS) (if trace2? ((lambda () (outf-console . ARGS))))))) \ No newline at end of file + ((_ . ARGS) (if %trace2? ((lambda () (outf-console . ARGS))))))) \ No newline at end of file diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm index 20e337da1..5c3ac65f3 100644 --- a/src/gtk/fix-layout.scm +++ b/src/gtk/fix-layout.scm @@ -109,7 +109,7 @@ USA. (error:wrong-type-argument obj "a positive fixnum, 0 or -1" (list 'initialize-instance )))) - (trace ";((initialize-instance ) "widget" "width" "height")...\n") + (%trace ";((initialize-instance ) "widget" "width" "height")...\n") (call-next-method widget) (let ((alien (gobject-alien widget))) (let ((w (->requisition-fixnum width)) @@ -262,14 +262,14 @@ USA. ;;; Callbacks. (define (allocation-callback widget GtkAllocation) - (trace2 ";allocation "widget" "GtkAllocation"\n") + (%trace2 ";allocation "widget" "GtkAllocation"\n") (let ((alien (gobject-alien widget)) (x (C-> GtkAllocation "GtkAllocation x")) (y (C-> GtkAllocation "GtkAllocation y")) (width (C-> GtkAllocation "GtkAllocation width")) (height (C-> GtkAllocation "GtkAllocation height")) (rect (fix-layout-geometry widget))) - (trace "; Allocation: "width"x"height" to "widget"\n") + (%trace "; Allocation: "width"x"height" to "widget"\n") (set-fix-rect! rect x y width height) (set-fix-rect-size! (fix-layout-view widget) width height) ;; For the random toolkit GtkWidget method too. @@ -293,7 +293,7 @@ USA. (define-generic fix-layout-realize-callback (layout)) (define-method fix-layout-realize-callback ((widget )) - (trace ";((fix-layout-realize-callback ) "widget")...\n") + (%trace ";((fix-layout-realize-callback ) "widget")...\n") (let ((geometry (fix-layout-geometry widget)) (attr (malloc (C-sizeof "GdkWindowAttr") '|GdkWindowAttr|)) (main-GdkWindow (fix-layout-window widget)) @@ -335,7 +335,7 @@ USA. (C-call "gdk_window_set_user_data" main-GdkWindow GtkWidget) (set-fix-rect! (fix-layout-geometry widget) #f #f width height) (set-fix-rect! (fix-layout-view widget) 0 0 width height) - (trace "; window: "main-GdkWindow"\n")) + (%trace "; window: "main-GdkWindow"\n")) (let ((GtkStyle (C-> GtkWidget "GtkWidget style"))) (C-call "gtk_style_attach" GtkStyle GtkStyle main-GdkWindow) @@ -345,10 +345,11 @@ USA. unspecific)) (define (adjustments-callback widget hGtkAdjustment vGtkAdjustment) - (trace2 ";set-scroll-adjustments "widget" "hGtkAdjustment" "vGtkAdjustment"\n") - (trace "; Adjustments:" - " 0x"(alien/address-string hGtkAdjustment) - " 0x"(alien/address-string vGtkAdjustment)"\n") + (%trace2 ";set-scroll-adjustments "widget + " "hGtkAdjustment" "vGtkAdjustment"\n") + (%trace "; Adjustments:" + " 0x"(alien/address-string hGtkAdjustment) + " 0x"(alien/address-string vGtkAdjustment)"\n") (connect-adjustment (fix-layout-hadjustment widget) hGtkAdjustment widget set-fix-layout-hadjustment!) (connect-adjustment (fix-layout-vadjustment widget) vGtkAdjustment @@ -383,7 +384,7 @@ USA. (define (make-adjustment-value-changed-callback widget) (named-lambda (fix-layout-adjustment-value-changed-callback adjustment) - (trace2 ";adjustment-value-changed "widget" "adjustment"\n") + (%trace2 ";adjustment-value-changed "widget" "adjustment"\n") (let ((window-extent (fix-layout-view widget)) (vadjustment (fix-layout-vadjustment widget)) @@ -391,10 +392,10 @@ USA. (value (floor->exact (C-> (gobject-alien adjustment) "GtkAdjustment value")))) (cond ((eq? adjustment vadjustment) - (trace2 "; Vadjustment to "value"\n") + (%trace2 "; Vadjustment to "value"\n") (scroll widget (fix-rect-x window-extent) value)) ((eq? adjustment hadjustment) - (trace2 "; Hadjustment to "value"\n") + (%trace2 "; Hadjustment to "value"\n") (scroll widget value (fix-rect-y window-extent))) (else (warn "Unexpected adjustment:" adjustment)))))) @@ -431,7 +432,7 @@ USA. page-size step-incr page-incr))))) (define (event-callback layout GdkEvent) - (trace2 ";event "layout" "GdkEvent"\n") + (%trace2 ";event "layout" "GdkEvent"\n") (let ((type (C-> GdkEvent "GdkEvent any type"))) (if (int:= type (C-enum "GDK_EXPOSE")) @@ -444,14 +445,14 @@ USA. (drawing (fix-layout-drawing layout)) (widget-window (fix-layout-window layout))) (cond ((not (alien=? window widget-window)) - (trace "; Expose a strange window "window - " (not "widget-window").\n")) + (%trace "; Expose a strange window "window + " (not "widget-window").\n")) (drawing (let* ((view (fix-layout-view layout)) (offx (fix-rect-x view)) (offy (fix-rect-y view))) - (trace2 "; Expose area "width"x"height" "x","y - " of "layout".\n") + (%trace2 "; Expose area "width"x"height" "x","y + " of "layout".\n") (drawing-expose drawing layout window (make-fix-rect (fix:+ x offx) (fix:+ y offy) @@ -619,7 +620,7 @@ USA. (fix-ink-extent ink) rect)) (drawing (fix-ink-drawing ink))) - (trace2 ";drawing-damage "ink" "(fix-rect-string extent)"\n") + (%trace2 ";drawing-damage "ink" "(fix-rect-string extent)"\n") (cond ((not drawing)) ((not (fix-rect-nominal? extent)) @@ -841,11 +842,11 @@ USA. ;;; For draw-ink expose handlers (without-interrupts in gtk-thread). (define (with-gc options widget receiver) - (trace2 ";(with-gc "options" "widget")") + (%trace2 ";(with-gc "options" "widget")") (if (pair? options) (let* ((alien.mask (malloc-gcvalues options)) (gc (gtk-gc-get widget alien.mask))) - (trace2 " => "alien.mask", "gc"\n") + (%trace2 " => "alien.mask", "gc"\n") (free (car alien.mask)) (receiver gc) (gtk-gc-release gc)) @@ -854,7 +855,7 @@ USA. (C-> gc "GtkStyle fg_gc" gc) (C-array-loc! gc "* GdkGC" (C-enum "GTK_STATE_NORMAL")) (C-> gc "* GdkGC" gc) - (trace2 " => fg:"gc"\n") + (%trace2 " => fg:"gc"\n") (receiver gc)))) (define (gtk-gc-get widget gcvalues.mask) @@ -969,7 +970,7 @@ USA. (define-method fix-ink-expose-callback ((ink ) widget window area) (declare (ignore area)) - (trace2 "; (Re)Drawing "ink" on "widget".\n") + (%trace2 "; (Re)Drawing "ink" on "widget".\n") (let ((view (fix-layout-view widget)) (vector (line-ink-vector ink))) (with-fix-rect @@ -1103,7 +1104,7 @@ USA. (define-method fix-ink-expose-callback ((ink ) widget window area) (declare (ignore area)) - (trace2 "; (Re)Drawing "ink" on "widget".\n") + (%trace2 "; (Re)Drawing "ink" on "widget".\n") (let ((view (fix-layout-view widget)) (rect (rectangle-ink-rect ink))) (with-fix-rect @@ -1237,7 +1238,7 @@ USA. (define-method fix-ink-expose-callback ((ink ) widget window area) (declare (ignore area)) - (trace2 "; (Re)Drawing "ink" on "widget".\n") + (%trace2 "; (Re)Drawing "ink" on "widget".\n") (let ((view (fix-layout-view widget)) (rect (arc-ink-rect ink))) (with-fix-rect @@ -1363,7 +1364,7 @@ USA. (define-method fix-ink-expose-callback ((ink ) widget window area) (declare (ignore area)) - (trace2 "; (Re)Drawing "ink" on "widget".\n") + (%trace2 "; (Re)Drawing "ink" on "widget".\n") (let ((view (fix-layout-view widget)) (rect (fix-ink-extent ink))) (let ((x (fix:- (fix-rect-x rect) (fix-rect-x view))) @@ -1548,7 +1549,7 @@ USA. (loader define standard initializer make-pixbuf-loader)) (define-method initialize-instance ((ink )) - (trace ";((initialize-instance ) "ink")...\n") + (%trace ";((initialize-instance ) "ink")...\n") (call-next-method ink) (let ((loader (image-ink-loader ink))) (set-pixbuf-loader-size-hook! loader (image-ink-size-prepared ink)) @@ -1558,24 +1559,24 @@ USA. (define (image-ink-size-prepared ink) (named-lambda (image-ink-size-prepared-handler width height) - (trace ";image-ink-size-prepared-handler "ink" "width" "height"\n") + (%trace ";image-ink-size-prepared-handler "ink" "width" "height"\n") (set-fix-ink-%size! ink width height))) (define (image-ink-pixbuf-prepared ink) (named-lambda (image-ink-pixbuf-prepared-handler pixbuf) - (trace ";image-ink-pixbuf-prepared-handler "ink" "pixbuf"\n") + (%trace ";image-ink-pixbuf-prepared-handler "ink" "pixbuf"\n") (set-image-ink-pixbuf! ink pixbuf))) (define (image-ink-pixbuf-updated ink) (named-lambda (image-ink-pixbuf-updated-handler x y width height) (let ((rect (make-fix-rect x y width height))) - (trace ";image-ink-pixbuf-updated-handler "ink" "rect"\n") + (%trace ";image-ink-pixbuf-updated-handler "ink" "rect"\n") (drawing-damage ink rect)))) (define (image-ink-pixbuf-loaded ink) (named-lambda (image-ink-pixbuf-loaded-handler loader) - (trace ";image-ink-pixbuf-loaded-handler "ink" ("(image-ink-pixbuf ink)")" - " "(pixbuf-loader-error-message loader)"\n") + (%trace ";image-ink-pixbuf-loaded-handler "ink" ("(image-ink-pixbuf ink)")" + " "(pixbuf-loader-error-message loader)"\n") (if (not (pixbuf-loader-error-message loader)) (begin (set-image-ink-loader! ink #f) @@ -1588,7 +1589,7 @@ USA. unspecific)))) (define-method fix-ink-expose-callback ((ink ) widget window area) - (trace2 "; (Re)Drawing "ink" on "widget".\n") + (%trace2 "; (Re)Drawing "ink" on "widget".\n") (let ((pixbuf (let ((p (image-ink-pixbuf ink))) (if p (gobject-alien p) #f)))) @@ -1636,7 +1637,7 @@ USA. (define-method fix-ink-expose-callback ((ink ) widget window area) (declare (ignore area)) - (trace2 "; (Re)Drawing "ink" on "widget".\n") + (%trace2 "; (Re)Drawing "ink" on "widget".\n") (let ((alien (gobject-alien widget)) (view (fix-layout-view widget)) (extent (fix-ink-extent ink))) @@ -1698,7 +1699,7 @@ USA. #;(define-method fix-ink-expose-callback ((ink ) widget window area) (declare (ignore area)) - (trace2 "; (Re)Drawing "ink" on "widget".\n") + (%trace2 "; (Re)Drawing "ink" on "widget".\n") (let ((alien (gobject-alien widget)) (view (fix-layout-view widget)) (extent (fix-ink-extent ink))) @@ -1901,14 +1902,14 @@ USA. (fix-rect-width rect) (fix-rect-height rect))) -(define trace? #f) +(define %trace? #f) -(define-syntax trace +(define-syntax %trace (syntax-rules () - ((_ . ARGS) (if trace? ((lambda () (outf-console . ARGS))))))) + ((_ . ARGS) (if %trace? ((lambda () (outf-console . ARGS))))))) -(define trace2? #f) +(define %trace2? #f) -(define-syntax trace2 +(define-syntax %trace2 (syntax-rules () - ((_ . ARGS) (if trace2? ((lambda () (outf-console . ARGS))))))) \ No newline at end of file + ((_ . ARGS) (if %trace2? ((lambda () (outf-console . ARGS))))))) \ No newline at end of file diff --git a/src/gtk/gobject.scm b/src/gtk/gobject.scm index 750490e5b..1425e9af5 100644 --- a/src/gtk/gobject.scm +++ b/src/gtk/gobject.scm @@ -73,7 +73,7 @@ USA. ;; Run as a gc-daemon, or with exclusive write access to ALIEN and ;; SIGNALS (or without-interrupts). - (trace ";gobject-cleanup "alien"\n") + (%trace ";gobject-cleanup "alien"\n") (if (not (alien-null? alien)) (begin (for-each @@ -81,7 +81,7 @@ USA. (cdr signals)) (C-call "g_object_unref" alien) (alien-null! alien))) - (trace ";gobject-cleanup done with "alien"\n")) + (%trace ";gobject-cleanup done with "alien"\n")) (define (g-signal-connect gobject alien-function callback) (guarantee-gobject gobject 'g-signal-connect) @@ -153,7 +153,7 @@ USA. (set! gc-cleanups '())) (define (run-gc-cleanups) - (trace ";run-gc-cleanups\n") + (%trace ";run-gc-cleanups\n") (let loop ((alist gc-cleanups) (prev #f)) (if (pair? alist) @@ -166,7 +166,7 @@ USA. (set-cdr! prev next) (set! gc-cleanups next)) (loop next prev))))) - (trace ";run-gc-cleanups done\n")) + (%trace ";run-gc-cleanups done\n")) (define (reset-gc-cleanups!) (set! gc-cleanups '())) @@ -503,7 +503,7 @@ USA. pixbuf-loader-area-updated)) (define (pixbuf-loader-size-prepared loader width height) - (trace "; pixbuf-loader-size-prepared "loader" "width" "height"\n") + (%trace "; pixbuf-loader-size-prepared "loader" "width" "height"\n") (let ((size (pixbuf-loader-size loader))) (if size (error "Pixbuf loader already has a size:" loader)) (set-pixbuf-loader-size! loader (cons width height)) @@ -511,7 +511,7 @@ USA. (if receiver (receiver width height))))) (define (pixbuf-loader-area-prepared loader) - (trace "; pixbuf-loader-area-prepared "loader"\n") + (%trace "; pixbuf-loader-area-prepared "loader"\n") (let* ((alien (gobject-alien loader)) (pixbuf (let ((p (pixbuf-loader-pixbuf loader))) (if p @@ -525,7 +525,7 @@ USA. (if receiver (receiver pixbuf))))) (define (pixbuf-loader-area-updated loader x y width height) - (trace "; pixbuf-loader-area-updated "loader" "x","y" "width"x"height"\n") + (%trace "; pixbuf-loader-area-updated "loader" "x","y" "width"x"height"\n") (let ((receiver (pixbuf-loader-update-hook loader))) (if receiver (receiver x y width height)))) @@ -542,7 +542,7 @@ USA. (define (create-pixbuf-loader-thread loader) (create-thread #f (lambda () - (trace "; "loader" started in "(current-thread)"\n") + (%trace "; "loader" started in "(current-thread)"\n") (let ((port (pixbuf-loader-port loader)) (alien (gobject-alien loader)) (GError-ptr (malloc (C-sizeof "*") '(* |GError|))) @@ -555,7 +555,7 @@ USA. (lambda () (set-pixbuf-loader-closed?! loader #t) (close-input-port port) - (trace "; "loader" closed by "(current-thread)"\n") + (%trace "; "loader" closed by "(current-thread)"\n") (let ((proc (pixbuf-loader-close-hook loader))) (if proc (proc loader)))))) @@ -624,10 +624,10 @@ USA. (add-event-receiver! event:after-restore reset-gc-cleanups!) unspecific) -(define trace? #f) +(define %trace? #f) -(define-syntax trace +(define-syntax %trace (syntax-rules () - ((_ . ARGS) (if trace? ((lambda () (outf-console . ARGS))))))) + ((_ . ARGS) (if %trace? ((lambda () (outf-console . ARGS))))))) (initialize-package!) \ No newline at end of file diff --git a/src/gtk/gtk-ev.scm b/src/gtk/gtk-ev.scm index ff691a475..177b567f2 100644 --- a/src/gtk/gtk-ev.scm +++ b/src/gtk/gtk-ev.scm @@ -60,7 +60,7 @@ USA. initial-value '())) (define-method initialize-instance ((widget )) - (trace ";\t(initialize-instance ) "widget")...\n") + (%trace ";\t(initialize-instance ) "widget")...\n") (call-next-method widget) (let ((alien (gobject-alien widget))) (C->= alien "GtkWidget requisition width" 450) @@ -73,7 +73,7 @@ USA. (set-gtk-widget-event-callback! widget event-callback)) (define (realize-callback widget) - (trace2 ";realize "widget"\n") + (%trace2 ";realize "widget"\n") (let ((alien (gobject-alien widget)) (attr (malloc (C-sizeof "GdkWindowAttr") '|GdkWindowAttr|)) (main-GdkWindow (gtk-event-viewer-window widget)) @@ -136,7 +136,7 @@ USA. unspecific)) (define (unrealize-callback widget) - (trace2 ";unrealize "widget"\n") + (%trace2 ";unrealize "widget"\n") ;; Destroy our event window. (let ((event-GdkWindow (gtk-event-viewer-event-window widget))) (if (not (alien-null? event-GdkWindow)) @@ -148,7 +148,7 @@ USA. unspecific) (define (size-allocate-callback widget GtkAllocation) - (trace2 ";size-allocate "widget" "GtkAllocation"\n") + (%trace2 ";size-allocate "widget" "GtkAllocation"\n") (let ((alien (gobject-alien widget)) (x (C-> GtkAllocation "GtkAllocation x")) (y (C-> GtkAllocation "GtkAllocation y")) @@ -184,10 +184,10 @@ USA. unspecific)))) (define (event-callback widget GdkEvent) - (trace2 ";event-callback "widget" "GdkEvent"\n") + (%trace2 ";event-callback "widget" "GdkEvent"\n") (let ((window (C-> GdkEvent "GdkEvent any window")) (type (C-> GdkEvent "GdkEvent any type"))) - (trace "; "(C-enum "GdkEventType" type) + (%trace "; "(C-enum "GdkEventType" type) " on window 0x"(alien/address-string window)".\n") (if (not (and (alien=? window (gtk-event-viewer-window widget)) @@ -214,7 +214,7 @@ USA. (y (C-> GdkEventExpose "GdkEventExpose area y")) (width (C-> GdkEventExpose "GdkEventExpose area width")) (height (C-> GdkEventExpose "GdkEventExpose area height"))) - (trace "; Expose "x","y" "width"x"height"\n") + (%trace "; Expose "x","y" "width"x"height"\n") (cond ((alien=? (gtk-event-viewer-window widget) window) (paint-window widget x y width height)) ((alien=? (gtk-event-viewer-event-window widget) window) @@ -224,7 +224,7 @@ USA. ) (define (paint-window widget x y width height) - (trace2 ";(paint-window "widget" "x" "y" "width" "height")\n") + (%trace2 ";(paint-window "widget" "x" "y" "width" "height")\n") (let* ((alien (gobject-alien widget)) (window (gtk-event-viewer-window widget)) (rect (gtk-event-viewer-event-box widget)) @@ -294,7 +294,7 @@ USA. unspecific)) (define (paint-event-window widget x y width height) - (trace2 ";(paint-event-window "widget" "x" "y" "width" "height")\n") + (%trace2 ";(paint-event-window "widget" "x" "y" "width" "height")\n") (let ((alien (gobject-alien widget)) (event-window (gtk-event-viewer-event-window widget)) (extent (pango-rectangle)) @@ -438,14 +438,14 @@ USA. (else #f)))) -(define trace? #f) +(define %trace? #f) -(define-syntax trace +(define-syntax %trace (syntax-rules () - ((_ . ARGS) (if trace? ((lambda () (outf-console . ARGS))))))) + ((_ . ARGS) (if %trace? ((lambda () (outf-console . ARGS))))))) -(define trace2? #f) +(define %trace2? #f) -(define-syntax trace2 +(define-syntax %trace2 (syntax-rules () - ((_ . ARGS) (if trace2? ((lambda () (outf-console . ARGS))))))) \ No newline at end of file + ((_ . ARGS) (if %trace2? ((lambda () (outf-console . ARGS))))))) \ No newline at end of file diff --git a/src/gtk/gtk-object.scm b/src/gtk/gtk-object.scm index f871d945c..f7cde673a 100644 --- a/src/gtk/gtk-object.scm +++ b/src/gtk/gtk-object.scm @@ -903,8 +903,8 @@ USA. (declare (ignore GdkEvent)) (callback window))) -(define trace? #f) +(define %trace? #f) -(define-syntax trace +(define-syntax %trace (syntax-rules () - ((_ . ARGS) (if trace? ((lambda () (outf-console . ARGS))))))) \ No newline at end of file + ((_ . ARGS) (if %trace? ((lambda () (outf-console . ARGS))))))) \ No newline at end of file diff --git a/src/gtk/swat.scm b/src/gtk/swat.scm index c0a71bd26..6f5c3de9c 100644 --- a/src/gtk/swat.scm +++ b/src/gtk/swat.scm @@ -42,7 +42,7 @@ USA. (on-death define standard initial-value #f)) (define-method initialize-instance ((widget ) . args) - (trace ";((initialize-instance ) "widget" "args")...\n") + (%trace ";((initialize-instance ) "widget" "args")...\n") (apply call-next-method widget args) ;; Do NOT replace fix-layout's realize callback. (Add a method to ;; fix-layout-realize-callback instead [or support a more generic @@ -59,7 +59,7 @@ USA. on-death))))) (if on-death (begin - (trace ";on-death "object": "on-death"\n") + (%trace ";on-death "object": "on-death"\n") ((cdr on-death)))))) (define-class ( (constructor ())) @@ -88,7 +88,7 @@ USA. ( )) (define-method initialize-instance ((frame )) - (trace ";((initialize-instance ) "frame")...\n") + (%trace ";((initialize-instance ) "frame")...\n") (call-next-method frame "") (gtk-container-add frame (gtk-label-new ""))) @@ -141,7 +141,7 @@ USA. (swat-handlers define standard initial-value '())) (define-method initialize-instance ((canvas ) width height) - (trace ";((initialize-instance ) "canvas" "width" "height")...\n") + (%trace ";((initialize-instance ) "canvas" "width" "height")...\n") (call-next-method canvas width height) (set-fix-layout-drawing! canvas (make-fix-drawing) 0 0)) @@ -163,15 +163,15 @@ USA. (set-fix-layout-button-handler! canvas type (named-lambda (canvas-button-handler canvas type button modifiers x y) - (trace ";canvas-button-handler "type" "button" "modifiers - " "x","y" "canvas"\n") + (%trace ";canvas-button-handler "type" "button" "modifiers + " "x","y" "canvas"\n") (handle-canvas-event canvas (append! (list type button) modifiers) x y)))) '(press release double-press triple-press)) (set-fix-layout-motion-handler! canvas (named-lambda (canvas-motion-handler canvas modifiers x y) - (trace2 ";canvas-motion-handler "modifiers" "x","y" "canvas"\n") + (%trace2 ";canvas-motion-handler "modifiers" "x","y" "canvas"\n") (handle-canvas-event canvas (cons 'motion modifiers) x y)))) (define-class () @@ -352,7 +352,7 @@ USA. ;;; swat-thread (which can sleep). (define (handle-canvas-event canvas event window-x window-y) - (trace2 "; handle-canvas-event "event" "window-x","window-y" "canvas"\n") + (%trace2 "; handle-canvas-event "event" "window-x","window-y" "canvas"\n") (let* ((view (fix-layout-view canvas)) (x (fix:+ window-x (fix-rect-x view))) (y (fix:+ window-y (fix-rect-y view)))) @@ -371,7 +371,7 @@ USA. (create-thread #f (lambda () - (trace ";swat-thread: "(current-thread)"\n") + (%trace ";swat-thread: "(current-thread)"\n") (let main () @@ -407,37 +407,37 @@ USA. (handle event))))))))) (else (handle event))))) - (trace ";swat-thread: done\n") + (%trace ";swat-thread: done\n") (stop-current-thread)))) (define (handle-event key canvas x y) (or (let* ((handlers (swat-canvas-swat-handlers canvas)) (entry (assoc key handlers))) - (trace "; Canvas: "entry"\n") + (%trace "; Canvas: "entry"\n") (and entry ((cdr entry) canvas x y))) (let ((items (pick-list canvas x y))) - (trace "; Pick list: "items"\n") + (%trace "; Pick list: "items"\n") (find (lambda (item) (let* ((handlers (swat-ink-swat-handlers item)) (entry (assoc key handlers))) - (trace "; "entry" "item"\n") + (%trace "; "entry" "item"\n") (and entry ((cdr entry) canvas x y)))) items)))) (define (pick-list canvas x y) - (trace2 "; pick-list "x","y" "canvas"\n") + (%trace2 "; pick-list "x","y" "canvas"\n") (let loop ((items (fix-drawing-display-list (fix-layout-drawing canvas))) (picks '())) (if (pair? items) (loop (cdr items) (let ((item (car items))) (if (not (fix-ink-in-widget? item canvas)) - (trace2 ";\t"item" not in "canvas"\n") + (%trace2 ";\t"item" not in "canvas"\n") (begin - (trace2 ";\t"x","y" in "item" ("(fix-ink-extent item)")? ") + (%trace2 ";\t"x","y" in "item" ("(fix-ink-extent item)")? ") (if (point-in-fix-rect? x y (fix-ink-extent item)) - (trace2 "yes!\n") - (trace2 "no\n")))) + (%trace2 "yes!\n") + (%trace2 "no\n")))) (if (and (fix-ink-in-widget? item canvas) (point-in-fix-rect? x y (fix-ink-extent item))) (cons item @@ -659,7 +659,7 @@ USA. (define (make-label-frobbery label) (named-lambda (label-frobbery value) - (trace ";label-frobbage "label" "value"\n") + (%trace ";label-frobbage "label" "value"\n") (if (string? value) (gtk-label-set-text (gtk-bin-child label) value) (warn "Bogus text for swat-label frobbery:" value label)))) @@ -967,7 +967,7 @@ USA. (create-thread #f (lambda () - (trace ";after-delay "seconds", sleeping "(current-thread)"\n") + (%trace ";after-delay "seconds", sleeping "(current-thread)"\n") (sleep-current-thread (* seconds 1000)) (thunk) (stop-current-thread))))) @@ -1042,7 +1042,7 @@ USA. (define (make-checkbutton-frobbery button) (named-lambda (checkbutton-frobbery value) - (trace ";checkbutton-frobbery: setting "button" to "value"\n") + (%trace ";checkbutton-frobbery: setting "button" to "value"\n") (gtk-check-button-set-active button value))) (define (checkbutton-toggled-callback button) @@ -1052,15 +1052,15 @@ USA. (let ((state (gtk-check-button-get-active button))) (if variable (begin - (trace ";checkbutton-toggled-callback:" - " setting "variable" to "state" for "button"\n") + (%trace ";checkbutton-toggled-callback:" + " setting "variable" to "state" for "button"\n") (frob-active-variable! variable state))) (if callback (begin - (trace ";checkbutton-toggled-callback:" - " calling "callback" for "button"\n") + (%trace ";checkbutton-toggled-callback:" + " calling "callback" for "button"\n") (callback)))) - (trace ";checkbutton-toggled-callback: noop\n")))) + (%trace ";checkbutton-toggled-callback: noop\n")))) (define (checkbutton-variable-on? active) (active-variable-value active)) @@ -1094,9 +1094,9 @@ USA. (let ((width (find-option options '-width #f)) (height (find-option options '-height #f))) (let ((canvas (make-swat-canvas width height))) - (trace ";(make-canvas "options") configuring "canvas"\n") + (%trace ";(make-canvas "options") configuring "canvas"\n") (widget-configure! canvas (delete-options! '(-width -height) options)) - (trace ";(make-canvas "options") => "canvas"\n") + (%trace ";(make-canvas "options") => "canvas"\n") canvas))) (define (make-canvas-item-group canvas items) @@ -1220,16 +1220,16 @@ USA. (trim options)) -(define trace? #f) +(define %trace? #f) -(define-syntax trace +(define-syntax %trace (syntax-rules () - ((_ . ARGS) (if trace? ((lambda () (outf-console . ARGS))))))) + ((_ . ARGS) (if %trace? ((lambda () (outf-console . ARGS))))))) -(define trace2? #f) +(define %trace2? #f) -(define-syntax trace2 +(define-syntax %trace2 (syntax-rules () - ((_ . ARGS) (if trace2? ((lambda () (outf-console . ARGS))))))) + ((_ . ARGS) (if %trace2? ((lambda () (outf-console . ARGS))))))) (initialize-package!) \ No newline at end of file diff --git a/src/gtk/thread.scm b/src/gtk/thread.scm index 52de604f4..69105932a 100644 --- a/src/gtk/thread.scm +++ b/src/gtk/thread.scm @@ -59,11 +59,11 @@ USA. 0 (or next-scheduled-timeout (no-threads-nor-timers))))) - (trace ";run-gtk until "time"\n") + (%trace ";run-gtk until "time"\n") (C-call "run_gtk" (select-registry-handle io-registry) time) - (trace ";run-gtk done at "(real-time-clock)"\n")) + (%trace ";run-gtk done at "(real-time-clock)"\n")) (maybe-signal-io-thread-events))) (yield-current-thread) (gtk-thread-loop)))))) @@ -86,9 +86,9 @@ USA. (define (restart-gtk-thread) (restart-thread gtk-thread #t #f)) -(define trace? #f) +(define %trace? #f) -(define-syntax trace +(define-syntax %trace (syntax-rules () ((_ . MSG) - (if trace? ((lambda () (outf-console . MSG))))))) \ No newline at end of file + (if %trace? ((lambda () (outf-console . MSG))))))) \ No newline at end of file diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index 6f0f0fb94..9175a8d02 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -104,7 +104,7 @@ USA. (set! timer-interval 100) (initialize-io-blocking) (add-event-receiver! event:after-restore initialize-io-blocking) - (set! trace? #f) + (set! %trace? #f) (detach-thread (make-thread #f)) (add-event-receiver! event:before-exit stop-thread-timer)) @@ -210,7 +210,7 @@ USA. unspecific) (define (thread-not-running thread state) - (trace ";thread-not-running: stopping "thread" in state "state"\n") + (%trace ";thread-not-running: stopping "thread" in state "state"\n") (set-thread/execution-state! thread state) (let ((thread* (thread/next thread))) (set-thread/next! thread #f) @@ -218,7 +218,7 @@ USA. (run-first-thread)) (define (run-first-thread) - (trace ";run-first-thread "first-running-thread"\n") + (%trace ";run-first-thread "first-running-thread"\n") (if first-running-thread (run-thread first-running-thread) (begin @@ -299,7 +299,7 @@ USA. ;; Preserve the floating-point environment here to guarantee that the ;; thread timer won't raise or clear exceptions (particularly the ;; inexact result exception) that the interrupted thread cares about. - (trace ";Thread timer: interrupt in "first-running-thread"\n") + (%trace ";Thread timer: interrupt in "first-running-thread"\n") (let ((fp-env (flo:environment))) (flo:set-environment! (flo:default-environment)) (set! next-scheduled-timeout #f) @@ -307,29 +307,29 @@ USA. (deliver-timer-events) (maybe-signal-io-thread-events) (let ((thread first-running-thread)) - (trace ";Thread timer: first runnable: "thread".\n") + (%trace ";Thread timer: first runnable: "thread".\n") (cond ((not thread) (%maybe-toggle-thread-timer) - (trace ";Thread timer: continuing with timer set for " + (%trace ";Thread timer: continuing with timer set for " next-scheduled-timeout".\n")) ((thread/continuation thread) - (trace ";Thread timer: switching to "thread".\n") + (%trace ";Thread timer: switching to "thread".\n") (run-thread thread)) ((not (eq? 'RUNNING-WITHOUT-PREEMPTION (thread/execution-state thread))) - (trace ";Thread timer: yielding to "(thread/next thread)".\n") + (%trace ";Thread timer: yielding to "(thread/next thread)".\n") (yield-thread thread fp-env)) (else - (trace ";Thread timer: continuing with "thread".\n") + (%trace ";Thread timer: continuing with "thread".\n") (flo:set-environment! fp-env) (%resume-current-thread thread)))))) -(define trace? #f) +(define %trace? #f) -(define-syntax trace +(define-syntax %trace (syntax-rules () ((_ . MSG) - (if trace? ((lambda () (outf-console . MSG))))))) + (if %trace? ((lambda () (outf-console . MSG))))))) (define (yield-current-thread) (without-interrupts @@ -359,7 +359,7 @@ USA. (set-thread/next! last-running-thread thread) (set! last-running-thread thread) (set! first-running-thread next) - (trace ";yield-thread: "thread" yields to "next"\n") + (%trace ";yield-thread: "thread" yields to "next"\n") (run-thread next)))))) (define (exit-current-thread value) @@ -457,7 +457,7 @@ USA. (define (wait-for-io) (%maybe-toggle-thread-timer #f) - (trace ";wait-for-io: next timeout = "next-scheduled-timeout"\n") + (%trace ";wait-for-io: next timeout = "next-scheduled-timeout"\n") (let ((catch-errors (lambda (thunk) (let ((thread (console-thread))) @@ -485,7 +485,7 @@ USA. (let ((result (catch-errors (lambda () - (trace ";wait-for-io: blocking for i/o\n") + (%trace ";wait-for-io: blocking for i/o\n") (set-interrupt-enables! interrupt-mask/all) (test-select-registry io-registry #t))))) (set-interrupt-enables! interrupt-mask/gc-ok) @@ -494,13 +494,13 @@ USA. (if thread (if (thread/continuation thread) (begin - (trace ";wait-for-io: running "thread"\n") + (%trace ";wait-for-io: running "thread"\n") (run-thread thread)) (begin - (trace ";wait-for-io: continuing "thread"\n") + (%trace ";wait-for-io: continuing "thread"\n") (%maybe-toggle-thread-timer))) (begin - (trace ";wait-for-io: looping\n") + (%trace ";wait-for-io: looping\n") (wait-for-io)))))))) (define (signal-select-result result) @@ -516,7 +516,7 @@ USA. (define (maybe-signal-io-thread-events) (if io-registrations (let ((result (test-select-registry io-registry #f))) - (trace "maybe-signal-io-thread-events: "result" "io-registry"\n") + (%trace "maybe-signal-io-thread-events: "result" "io-registry"\n") (signal-select-result result)))) (define (block-on-io-descriptor descriptor mode) @@ -850,7 +850,7 @@ USA. (%signal-thread-event thread event) (if (and (not self) first-running-thread) (begin - (trace ";signal-thread-event running "first-running-thread"\n") + (%trace ";signal-thread-event running "first-running-thread"\n") (run-thread first-running-thread)) (%maybe-toggle-thread-timer))))))) -- 2.25.1