(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)
(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 (<demo-layout> (constructor () (width height)))
(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))
(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)
#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)))
(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))
(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))
(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)
(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)
(there-exists? (cdr cursor.widgets)
(lambda (w) (not (gtk-object-destroyed? w))))))
(loop)
- (trace ";blinking ended\n"))))))
+ (%trace ";blinking ended\n"))))))
\f
-(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
(error:wrong-type-argument obj "a positive fixnum, 0 or -1"
(list 'initialize-instance <fix-layout>))))
- (trace ";((initialize-instance <fix-layout>) "widget" "width" "height")...\n")
+ (%trace ";((initialize-instance <fix-layout>) "widget" "width" "height")...\n")
(call-next-method widget)
(let ((alien (gobject-alien widget)))
(let ((w (->requisition-fixnum width))
;;; 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.
(define-generic fix-layout-realize-callback (layout))
(define-method fix-layout-realize-callback ((widget <fix-layout>))
- (trace ";((fix-layout-realize-callback <fix-layout>) "widget")...\n")
+ (%trace ";((fix-layout-realize-callback <fix-layout>) "widget")...\n")
(let ((geometry (fix-layout-geometry widget))
(attr (malloc (C-sizeof "GdkWindowAttr") '|GdkWindowAttr|))
(main-GdkWindow (fix-layout-window widget))
(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)
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
(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))
(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))))))
page-size step-incr page-incr)))))
\f
(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"))
(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)
(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))
;;; 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))
(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)
(define-method fix-ink-expose-callback ((ink <line-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
(define-method fix-ink-expose-callback ((ink <rectangle-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
(define-method fix-ink-expose-callback ((ink <arc-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
(define-method fix-ink-expose-callback ((ink <text-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)))
(loader define standard initializer make-pixbuf-loader))
(define-method initialize-instance ((ink <image-ink>))
- (trace ";((initialize-instance <image-ink>) "ink")...\n")
+ (%trace ";((initialize-instance <image-ink>) "ink")...\n")
(call-next-method ink)
(let ((loader (image-ink-loader ink)))
(set-pixbuf-loader-size-hook! loader (image-ink-size-prepared ink))
(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)
unspecific))))
(define-method fix-ink-expose-callback ((ink <image-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))))
(define-method fix-ink-expose-callback ((ink <box-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)))
#;(define-method fix-ink-expose-callback ((ink <hline-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)))
(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
;; 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
(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)
(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)
(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 '()))
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))
(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
(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))))
(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|)))
(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))))))
(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
initial-value '()))
(define-method initialize-instance ((widget <gtk-event-viewer>))
- (trace ";\t(initialize-instance <gtk-event-viewer>) "widget")...\n")
+ (%trace ";\t(initialize-instance <gtk-event-viewer>) "widget")...\n")
(call-next-method widget)
(let ((alien (gobject-alien widget)))
(C->= alien "GtkWidget requisition width" 450)
(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))
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))
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"))
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))
(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)
)
(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))
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))
(else
#f))))
\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
(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
(on-death define standard initial-value #f))
(define-method initialize-instance ((widget <swat-widget>) . args)
- (trace ";((initialize-instance <swat-widget>) "widget" "args")...\n")
+ (%trace ";((initialize-instance <swat-widget>) "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
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 (<swat-button> (constructor ()))
(<swat-widget> <gtk-frame>))
(define-method initialize-instance ((frame <swat-label>))
- (trace ";((initialize-instance <swat-label>) "frame")...\n")
+ (%trace ";((initialize-instance <swat-label>) "frame")...\n")
(call-next-method frame "")
(gtk-container-add frame (gtk-label-new "")))
(swat-handlers define standard initial-value '()))
(define-method initialize-instance ((canvas <swat-canvas>) width height)
- (trace ";((initialize-instance <swat-canvas>) "canvas" "width" "height")...\n")
+ (%trace ";((initialize-instance <swat-canvas>) "canvas" "width" "height")...\n")
(call-next-method canvas width height)
(set-fix-layout-drawing! canvas (make-fix-drawing) 0 0))
(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 <swat-ink> (<fix-ink>)
;;; 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))))
(create-thread
#f
(lambda ()
- (trace ";swat-thread: "(current-thread)"\n")
+ (%trace ";swat-thread: "(current-thread)"\n")
(let main ()
(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
(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))))
(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)))))
(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)
(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))
(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)
(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
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))))))
(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
(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))
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)
(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
;; 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)
(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
(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))))))
\f
(define (exit-current-thread value)
(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)))
(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)
(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))))))))
\f
(define (signal-select-result result)
(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)
(%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)))))))
projects / mit-scheme.git / commitdiff