(alien define accessor
initializer (lambda () (make-alien '|GObject|)))
- ;; A pair, shared with finalize thunk closures. The cdr of this
+ ;; A pair, shared with cleanup thunks. The cdr of this
;; pair is the alist associating signal names with Scheme callback
;; IDs and toolkit handles. In this alist, a callback ID will be #f
;; if the signal was disconnected.
;; Arrange for all gobject signal handlers to be de-registered if
;; GCed. The object itself is g_object_unref'ed.
(add-gc-cleanup object
- (gobject-finalize-thunk
- (gobject-alien object)
- (gobject-signals object))))
-
-(define (gobject-finalize-thunk alien signals)
- ;; Return a thunk closed over ALIEN and SIGNALS (but not the gobject).
- (lambda ()
- (gobject-finalize! alien signals)))
-
-(define (gobject-finalize! alien signals)
- ;; This is finalization from Scheme perspective, not necessarily the
- ;; toolkit's.
-
+ (gobject-cleanup-thunk (gobject-alien object)
+ (gobject-signals object))))
+
+(define (gobject-cleanup-thunk alien signals)
+ ;; Return a thunk closed over ALIEN and SIGNALS (but not the
+ ;; gobject).
+ (named-lambda (gobject::cleanup-thunk)
+ (trace ";gobject::cleanup-thunk "alien"\n")
+ (gobject-cleanup alien signals)
+ (trace ";gobject::cleanup-thunk done with "alien"\n")))
+
+(define (gobject-cleanup alien signals)
+ ;; Run as a gc-cleanup, without-interrupts. Calls g_object_unref
+ ;; (if necessary), and de-registers the Scheme signal handlers.
+ (trace ";gobject::cleanup "alien"\n")
(if (not (alien-null? alien))
(begin
(C-call "g_object_unref" alien)
(alien-null! alien)))
-
(for-each (lambda (name.id.handle)
- (let ((id.handle (cdr name.id.handle)))
- ;; Hacking this ID.HANDLE pair atomically.
- (without-interrupts
- (lambda ()
- (let ((id (car id.handle)))
- (if id
- (begin
- (de-register-c-callback id)
- (set-car! id.handle #f)
- (set-cdr! id.handle #f))))))))
- (cdr signals)))
+ (let* ((id.handle (cdr name.id.handle))
+ (id (car id.handle)))
+ (if id
+ (begin
+ (de-register-c-callback id)
+ (set-car! id.handle #f)
+ (set-cdr! id.handle #f)))))
+ (cdr signals))
+ (trace ";gobject::cleanup done with "alien"\n"))
(define (gobject-unref object)
;; Calls g_object_unref to release Scheme's reference to the toolkit
;; called once (per wrapper object).
(without-interrupts
(lambda ()
- (gobject-finalize! (gobject-alien object) (gobject-signals object)))))
+ (gobject-cleanup (gobject-alien object) (gobject-signals object)))))
-(define (g-signal-connect object alien-function closure)
+(define (g-signal-connect object alien-function handler)
;; Allocate a callback and connect it with g_signal_connect_... The
;; signal name is assumed to be the same as ALIEN-FUNCTION's name,
;; e.g. in
(lambda ()
(let ((id (car id.handle)))
(if (not id)
- (let ((newid (register-c-callback closure)))
+ (let ((newid (register-c-callback handler)))
(set-car! id.handle newid)
(set-cdr! id.handle
(C-call "g_signal_connect_data"
;;; check first for a nulled alien before freeing a resource, and null
;;; that alien without interrupts after the resource is freed.
-(define gc-cleanups '())
+;;; These cleanups are run by the gtk-thread, for easy error handling.
+;;; They are rather complex to run at after-gc interrupt level (as
+;;; gc-daemons). They callout and thus may run callbacks that run
+;;; callouts...
+
+(define gc-cleanups)
(define (initialize-gc-cleanups!)
- (set! gc-cleanups '())
- (add-gc-daemon! run-gc-cleanups))
+ (set! gc-cleanups '()))
(define (run-gc-cleanups)
+ (trace ";run-gc-cleanups\n")
(let loop ((alist gc-cleanups)
(prev #f))
(if (pair? alist)
(if prev
(set-cdr! prev next)
(set! gc-cleanups next))
- (loop next prev))))))
+ (loop next prev)))))
+ (trace ";run-gc-cleanups done\n"))
(define (reset-gc-cleanups!)
(set! gc-cleanups '()))
(<gobject>)
(port define standard initial-value #f)
(thread define standard initial-value #f)
+ (size define standard initial-value #f)
+ (pixbuf define standard initial-value #f)
(error-message define standard initial-value #f)
- (pixbuf define standard initializer (lambda () (make-alien '|GdkPixbuf|))))
+ (closed? define standard initial-value #f)
+ (size-hook define standard initial-value #f
+ modifier %set-pixbuf-loader-size-hook!)
+ (pixbuf-hook define standard initial-value #f
+ modifier %set-pixbuf-loader-pixbuf-hook!)
+ (update-hook define standard initial-value #f)
+ (close-hook define standard initial-value #f
+ modifier %set-pixbuf-loader-close-hook!))
+
+(define-class (<pixbuf> (constructor ()))
+ (<gobject>))
+
+(define-method initialize-instance ((pixbuf <pixbuf>))
+ (call-next-method pixbuf)
+ (set-alien/ctype! (gobject-alien pixbuf) '|GdkPixbuf|))
(define-method initialize-instance ((loader <pixbuf-loader>))
(call-next-method loader)
- (add-gc-cleanup loader (pixbuf-loader-finalize-thunk
- (pixbuf-loader-pixbuf loader)))
(C-call "gdk_pixbuf_loader_new" (gobject-alien loader))
+ (g-signal-connect loader (C-callback "size_prepared")
+ (pixbuf-loader-size-prepared loader))
(g-signal-connect loader (C-callback "area_prepared")
- (pixbuf-loader-area-prepared loader)))
-
-(define (pixbuf-loader-finalize-thunk pixbuf-alien)
- (named-lambda (pixbuf-loader::finalize-thunk)
-
- (if (not (alien-null? pixbuf-alien))
- (begin
- (C-call "g_object_unref" pixbuf-alien)
- (alien-null! pixbuf-alien)))
- ;; Signals finalized by initialize-instance(<gobject>...) method's
- ;; gc-cleanup.
- ))
+ (pixbuf-loader-area-prepared loader))
+ (g-signal-connect loader (C-callback "area_updated")
+ (pixbuf-loader-area-updated loader)))
+
+(define (pixbuf-loader-size-prepared loader)
+ (named-lambda (pixbuf-loader::size-prepared GdkPixbufLoader width height)
+ GdkPixbufLoader ;;Ignored.
+ (trace "; pixbuf-loader::size-prepared "loader" "width" "height"\n")
+ (let ((size (pixbuf-loader-size loader)))
+ (if size (ferror loader" already has a size: "(car size)"x"(cdr size)))
+ (set-pixbuf-loader-size! loader (cons width height))
+ (let ((receiver (pixbuf-loader-size-hook loader)))
+ (if receiver (receiver width height))))))
(define (pixbuf-loader-area-prepared loader)
(named-lambda (pixbuf-loader::area-prepared GdkPixbufLoader)
-
- (let ((pixbuf (pixbuf-loader-pixbuf loader)))
- (C-call "gdk_pixbuf_loader_get_pixbuf" pixbuf GdkPixbufLoader)
- (C-call "g_object_ref" pixbuf))))
-
-(define-integrable (pixbuf-loader-started? loader)
- (not (eq? #f (pixbuf-loader-port loader))))
-
-(define-integrable (pixbuf-loader-done? loader)
- (let ((port (pixbuf-loader-port loader)))
- (and port (not (port/input-open? port)))))
+ (trace "; pixbuf-loader::area-prepared "loader"\n")
+ (let* ((pixbuf (let ((p (pixbuf-loader-pixbuf loader)))
+ (if p
+ (ferror loader" already has a pixbuf: "p)
+ (make-pixbuf))))
+ (alien (gobject-alien pixbuf)))
+ (C-call "gdk_pixbuf_loader_get_pixbuf" alien GdkPixbufLoader)
+ (C-call "g_object_ref" #f alien)
+ (set-pixbuf-loader-pixbuf! loader pixbuf)
+ (let ((receiver (pixbuf-loader-pixbuf-hook loader)))
+ (if receiver (receiver pixbuf))))))
+
+(define (pixbuf-loader-area-updated loader)
+ (named-lambda (pixbuf-loader::area-updated GdkPixbufLoader x y width height)
+ GdkPixbufLoader ;;Ignored.
+ (let ((rect (make-rect x y width height)))
+ (trace "; pixbuf-loader::area-updated "loader" "rect"\n")
+ (let ((receiver (pixbuf-loader-update-hook loader)))
+ (if receiver (receiver rect))))))
(define (start-pixbuf-loader loader input-port)
(without-interrupts
(lambda ()
- (if (pixbuf-loader-started? loader)
- (if (pixbuf-loader-done? loader)
- (ferror loader" is already finished.")
- (ferror loader" has already started.")))
- (set-pixbuf-loader-port! loader input-port)))
- (set-pixbuf-loader-thread!
- loader (create-pixbuf-loader-thread loader)))
+ (if (pixbuf-loader-port loader)
+ (ferror loader" has already started."))
+ (set-pixbuf-loader-port! loader input-port)
+ (set-pixbuf-loader-thread! loader (create-pixbuf-loader-thread loader)))))
(define (create-pixbuf-loader-thread loader)
(create-thread
#f (lambda ()
+ (trace "; "loader" started in "(current-thread)"\n")
(let ((port (pixbuf-loader-port loader))
(alien (gobject-alien loader))
(GError-ptr (malloc (C-sizeof "*") '(* |GError|)))
(C->= GError-ptr "* GError" 0)
(let ((buff-address (external-string-descriptor buff)))
+ (define (note-done)
+ (without-interrupts
+ (lambda ()
+ (set-pixbuf-loader-closed?! loader #t)
+ (close-input-port port)
+ (trace "; "loader" closed by "(current-thread)"\n")
+ (let ((proc (pixbuf-loader-close-hook loader)))
+ (if proc
+ (proc loader))))))
+
(define (note-error)
(let* ((GError (C-> GError-ptr "*" (make-alien '|GError|)))
- (message (and (not (alien-null? GError))
- (c-peek-cstring
- (C-> GError "GError message")))))
- (set-pixbuf-loader-error-message!
- loader (or message "Bogus GError address."))
+ (message (or (and (not (alien-null? GError))
+ (c-peek-cstring
+ (C-> GError "GError message")))
+ "GError not set.")))
+ (set-pixbuf-loader-error-message! loader message)
(C-call "g_error_free" GError)
- (free GError-ptr)))
+ (free GError-ptr)
+ (note-done)))
(let loop ()
(let ((n (input-port/read-string! port buff)))
- ;; Adaptively grow the buff if n == 4200?
(cond ((and (fix:zero? n) (eof-object? (peek-char port)))
- (if (fix:zero?
- (C-call "gdk_pixbuf_loader_close" alien GError-ptr))
+ (if (fix:zero? (C-call "gdk_pixbuf_loader_close"
+ alien GError-ptr))
(note-error)
- (close-input-port port))
- ;; (gobject-unref loader) Need to ref the pixbuf first!
- unspecific)
+ (note-done)))
((not (fix:zero?
(C-call "gdk_pixbuf_loader_write"
alien buff-address n GError-ptr)))
(loop))
(else
- (note-error)
- unspecific)))))))))
+ (note-error))))))))))
(define (load-pixbuf-from-file loader filename)
(start-pixbuf-loader
loader (open-binary-input-file (->namestring (->truename filename)))))
+(define (set-pixbuf-loader-size-hook! loader receiver)
+ (without-interrupts
+ (lambda ()
+ (%set-pixbuf-loader-size-hook! loader receiver)
+ (let ((size (pixbuf-loader-size loader)))
+ (if size (receiver (car size) (cdr size)))))))
+
+(define (set-pixbuf-loader-pixbuf-hook! loader receiver)
+ (without-interrupts
+ (lambda ()
+ (%set-pixbuf-loader-pixbuf-hook! loader receiver)
+ (let ((pixbuf (pixbuf-loader-pixbuf loader)))
+ (if pixbuf (receiver pixbuf))))))
+
+(define (set-pixbuf-loader-close-hook! loader thunk)
+ (without-interrupts
+ (lambda ()
+ (%set-pixbuf-loader-close-hook! loader thunk)
+ (if (pixbuf-loader-closed? loader)
+ (thunk)))))
+
(define (initialize-package!)
+ (initialize-gc-cleanups!)
(add-event-receiver! event:after-restore reset-quark-cache!)
(add-event-receiver! event:after-restore reset-gc-cleanups!)
- unspecific)
\ No newline at end of file
+ unspecific)
+
+(define trace? #f)
+
+(define-syntax trace
+ (syntax-rules ()
+ ((_ . ARGS) (if trace? ((lambda () (outf-console . ARGS)))))))
\ No newline at end of file
|#
;;;; GtkObjects/GtkWidgets/GtkContainers
-;;; package: (gtk object)
+;;; package: (gtk gtk-object)
(c-include "gtk")
(define-method initialize-instance ((object <gtk-object>))
;; Arrange for all gtk-objects to be destroyed by gtk_object_destroy
;; when GCed. Does NOT chain (further) up; gtk-object-cleanup is
- ;; sufficient. g_object_unref probably should NOT be called!
+ ;; sufficient.
(add-gc-cleanup object
- (gtk-object-cleanup-thunk
- (gobject-alien object)
- (gobject-signals object))))
+ (gtk-object-cleanup-thunk (gobject-alien object)
+ (gobject-signals object))))
(define (gtk-object-cleanup-thunk alien signals)
;; Return a thunk closed over ALIEN and SIGNALS (but not the gtk-object).
- (lambda ()
- (gtk-object-cleanup alien signals)))
+ (named-lambda (gtk-object::cleanup-thunk)
+ (trace ";gtk-object::cleanup-thunk "alien"\n")
+ (gtk-object-cleanup alien signals)
+ (trace ";gtk-object::cleanup-thunk done with "alien"\n")))
(define (gtk-object-cleanup alien signals)
- (without-interrupts
- (lambda ()
- (if (not (alien-null? alien))
- (begin
- (C-call "gtk_object_destroy" alien)
- (alien-null! alien)))))
+ ;; Run as a gc-cleanup, without-interrupts. Calls
+ ;; gtk_object_destroy (if necessary), and de-registers the Scheme
+ ;; signal handlers.
+ (trace ";gtk-object::cleanup "alien"\n")
+ (if (not (alien-null? alien))
+ (begin
+ (C-call "gtk_object_destroy" alien)
+ (alien-null! alien)))
;; De-register signals. Nulled alien will not be g_object_unrefed.
- (gobject-finalize! alien signals))
+ (gobject-cleanup alien signals)
+ (trace ";gtk-object::cleanup done with "alien"\n"))
(define-generic gtk-object-destroy (object))
(define-method gtk-object-destroy ((object <gtk-object>))
;; Calls gtk_object_destroy and sets the destroyed? flag.
- (if (not (gtk-object-destroyed? object))
- (begin
- (set-gtk-object-destroyed?! object #t)
- (gtk-object-cleanup (gobject-alien object) (gobject-signals object)))))
+ (without-interrupts
+ (lambda ()
+ (if (not (gtk-object-destroyed? object))
+ (begin
+ (set-gtk-object-destroyed?! object #t)
+ (gtk-object-cleanup
+ (gobject-alien object) (gobject-signals object)))))))
\f
;;;; GtkAdjustments
(C-call "gtk_window_set_title" (gobject-alien window) string))
(define (gtk-window-set-default-size window width height)
- (C-call "gtk_window_set_default_size" (gobject-alien window) width height))
\ No newline at end of file
+ (C-call "gtk_window_set_default_size" (gobject-alien window) width height))
+
+(define trace? #f)
+
+(define-syntax trace
+ (syntax-rules ()
+ ((_ . ARGS) (if trace? ((lambda () (outf-console . ARGS)))))))
\ No newline at end of file
(parent ())
(files "gtk"))
-(define-package (gtk main)
- (parent (gtk))
- (files "main")
- (import (runtime load)
- *unused-command-line*
- hook/process-command-line
- default/process-command-line)
- (export (gtk)
- gtk-time-slice-window?
- gtk-time-slice-window!
- gtk-select-trace?
- gtk-select-trace!)
- (initialization (initialize-package!)))
-
-(define-package (gtk thread)
- (parent (runtime thread))
- (files "thread")
- (export (gtk)
- create-gtk-thread
- kill-gtk-thread)
- (import (runtime primitive-io)
- select-registry-handle))
-
(define-package (gtk gobject)
(parent (gtk))
(files "gobject")
(export (gtk)
<gobject> gobject-alien
- gobject-unref gobject-finalized? gobject-finalize!
+ gobject-unref gobject-finalized?
g-signal-connect g-signal-disconnect add-gc-cleanup
gobject-get-property gobject-set-properties
gquark-from-string gquark-to-string
<pixbuf-loader> make-pixbuf-loader load-pixbuf-from-file
- pixbuf-loader-started? pixbuf-loader-done?)
+ pixbuf-loader-size-hook set-pixbuf-loader-size-hook!
+ pixbuf-loader-pixbuf-hook set-pixbuf-loader-pixbuf-hook!
+ pixbuf-loader-update-hook set-pixbuf-loader-update-hook!
+ pixbuf-loader-close-hook set-pixbuf-loader-close-hook!
+ pixbuf-loader-pixbuf pixbuf-loader-error-message)
(initialization (initialize-package!)))
-(define-package (gtk object)
+(define-package (gtk gtk-object)
(parent (gtk))
(files "gtk-object")
(export (gtk)
pango-font-families pango-context-list-families
pango-font-family-get-name pango-font-family-is-monospace?
pango-font-family-faces pango-font-face-get-name)
- (import (gtk gobject) gobject-finalize! gobject-signals))
+ (import (gtk gobject) gobject-cleanup gobject-signals))
(define-package (gtk widget)
(parent (gtk))
text-item? text-item-xy-to-index
call-with-text-item-grapheme-rect
- <image-item> add-image-item-from-file
+ <image-item> add-image-item-from-file))
- image-item-area-updated image-item-area-prepared
- image-item-size-prepared))
+(define-package (gtk thread)
+ (parent (runtime thread))
+ (files "thread")
+ (export (gtk)
+ create-gtk-thread
+ kill-gtk-thread)
+ (import (gtk gobject)
+ run-gc-cleanups)
+ (import (runtime primitive-io)
+ select-registry-handle))
+
+(define-package (gtk main)
+ (parent (gtk))
+ (files "main")
+ (import (runtime load)
+ *unused-command-line*
+ hook/process-command-line
+ default/process-command-line)
+ (export (gtk)
+ gtk-time-slice-window?
+ gtk-time-slice-window!
+ gtk-select-trace?
+ gtk-select-trace!)
+ (initialization (initialize-package!)))
(define-package (gtk event-viewer)
(parent (gtk))
(apply make-primitive-procedure (cdr form)))))
(define (initialize-package!)
- (let ((processor hook/process-command-line))
- (set! hook/process-command-line
- (lambda (line)
- (processor (list->vector (gtk-init (vector->list line))))
- (gtk-main+))))
- (gtk-init *unused-command-line*)
+ (let ((program-name ((ucode-primitive scheme-program-name 0))))
+ (let ((processor hook/process-command-line))
+ (set! hook/process-command-line
+ (lambda (line)
+ (processor
+ (list->vector
+ (gtk-init program-name (vector->list line))))
+ (gtk-main+))))
+ (gtk-init program-name *unused-command-line*))
(gtk-main+))
-(define (gtk-init args)
+(define (gtk-init name args)
;; Call gtk_init_check. Signals an error if gtk_init_check returns 0.
;; Returns a list of unused ARGS.
(let ((arg-count (guarantee-list-of-type->length
'GTK-INIT))
(vars-size (+ (C-sizeof "int") ;gtk_init_check return var
(C-sizeof "* * char")))) ;gtk_init_check return var
- (let* ((vector-size
- (* (C-sizeof "* char") (+ arg-count 1))) ; null terminated vector
+ (guarantee-string name 'GTK-INIT)
+ (let* ((words (cons name args))
+ (vector-size
+ (* (C-sizeof "* char") (+ 1 arg-count)))
(total-size
(+ vars-size vector-size
(fold-left (lambda (sum arg)
(+ sum (string-length arg) 1)) ;null terminated
- 0 args)))
+ 0 words)))
(bytes (malloc total-size #f))
(vector (alien-byte-increment bytes vars-size))
- (arg-scan (alien-byte-increment vector vector-size))
+ (word-scan (alien-byte-increment vector vector-size))
(vector-scan (copy-alien vector))
(count-var bytes)
(vector-var (alien-byte-increment count-var (C-sizeof "int"))))
- (for-each (lambda (arg)
- (c-poke-pointer! vector-scan arg-scan)
- (c-poke-string! arg-scan arg))
- args)
- (C->= count-var "int" arg-count)
+ (for-each (lambda (word)
+ (c-poke-pointer! vector-scan word-scan)
+ (c-poke-string! word-scan word))
+ words)
+ (C->= count-var "int" (+ 1 arg-count))
(C->= vector-var "* * char" vector)
(if (fix:zero? (C-call "gtk_init_check" count-var vector-var))
(error "Could not initialize Gtk.")
(cons (c-peek-cstringp! vector-scan) args))
(reverse! args)))))
(free bytes)
- new-args))))))
+ (cdr new-args)))))))
(define (gtk-main+)
;; Establishes a GMainLoop in which scheme is an idle task.
;;;; A <scm-widget> implementing a scrollable GtkDrawingArea-like widget.
;;; package: (gtk layout)
-(declare (usual-integrations))
-\f
(c-include "gtk")
(named-lambda (scm-layout::size-request GtkWidget GtkRequisition)
GtkWidget ;;Ignored.
-;;; (%trace ";((scm-layout-size-request "widget") "GtkWidget" "
+;;; (trace ";((scm-layout-size-request "widget") "GtkWidget" "
;;; GtkRequisition")\n")
(let ((alien (gobject-alien widget)))
(height(C-> alien "GtkWidget requisition height")))
(C->= GtkRequisition "GtkRequisition width" width)
(C->= GtkRequisition "GtkRequisition height" height)
- (%trace "; Requisition: "widget"x"height" from "widget"\n")
+ (trace "; Requisition: "widget"x"height" from "widget"\n")
))))
(define (scm-layout-size-allocate widget)
(named-lambda (scm-layout::size-allocate GtkWidget GtkAllocation)
-;;; (%trace ";((scm-layout-size-allocate "widget") "GtkWidget" "GtkAllocation")\n")
+;;; (trace ";((scm-layout-size-allocate "widget") "GtkWidget" "GtkAllocation")\n")
(let ((x (C-> GtkAllocation "GtkAllocation x"))
(y (C-> GtkAllocation "GtkAllocation y"))
(height (C-> GtkAllocation "GtkAllocation height"))
(rect (scm-layout-geometry widget)))
(set-rect! rect x y width height)
- (%trace "; Allocation: "rect" to "widget"\n")
+ (trace "; Allocation: "rect" to "widget"\n")
(set-rect-size! (scm-layout-on-screen-area widget) width height)
;; For the random toolkit GtkWidget method.
(C->= GtkWidget "GtkWidget allocation x" x)
(define (scm-layout-realize widget)
(named-lambda (scm-layout::realize GtkWidget)
-;;; (%trace ";((scm-layout-realize "widget") "GtkWidget")\n")
+;;; (trace ";((scm-layout-realize "widget") "GtkWidget")\n")
;; ScmWidget automatically sets GTK_REALIZED.
(GtkStyle (C-> GtkWidget "GtkWidget style"))
(parent-GdkWindow (make-alien '|GdkWindow|))
(GdkVisual (make-alien '|GdkVisual|))
- (GdkColormap (make-alien '|GdkColormap|)))
+ (GdkColormap (make-alien '|GdkColormap|))
+ (check-!null (lambda (alien message)
+ (if (alien-null? alien)
+ (ferror "scm-layout: "message)
+ alien))))
;; Create widget window.
(check-!null main-GdkWindow "Could not create main window.")
(C->= GtkWidget "GtkWidget window" main-GdkWindow)
(C-call "gdk_window_set_user_data" main-GdkWindow GtkWidget)
- (%trace "; Realize "widget" on "main-GdkWindow"\n")
+ (trace "; Realize "widget" on "main-GdkWindow"\n")
;; Style
(define (scm-layout-event widget)
(named-lambda (scm-layout::event GtkWidget GdkEvent)
GtkWidget widget ;;Ignored, thus far.
-;;; (%trace ";((scm-layout-event "widget") "GtkWidget" "GdkEvent")\n")
+;;; (trace ";((scm-layout-event "widget") "GtkWidget" "GdkEvent")\n")
(let ((type (C-> GdkEvent "GdkEvent any type")))
(drawing (scm-layout-drawing widget))
(widget-window (scm-layout-window widget)))
(cond ((not (alien=? window widget-window))
- (%trace "; Expose a strange window "window
+ (trace "; Expose a strange window "window
" (not "widget-window").\n"))
(drawing
(let* ((scroll (scm-layout-on-screen-area widget))
(offx (rect-x scroll))
(offy (rect-y scroll)))
- (%trace "; Expose area "widget"x"height"+"x"+"y
+ (trace "; Expose area "width"x"height"+"x"+"y
" of "widget".\n")
(drawing-expose drawing widget window
(make-rect (int:+ x offx) (int:+ y offy)
(let ((name (C-enum "GdkEventType" type))
(addr (alien/address-string
(C-> GdkEvent "GdkEvent any window"))))
- (%trace "; "name" on "GtkWidget" (window 0x"addr").\n")))))
+ (trace "; "name" on "GtkWidget" (window 0x"addr").\n")))))
1 ;;TRUE -- "handled" -- done.
))
GtkWidget hGtkAdjustment vGtkAdjustment)
GtkWidget ;;Ignored.
-;;; (%trace ";((scm-layout-set-scroll-adjustments "widget")"
+;;; (trace ";((scm-layout-set-scroll-adjustments "widget")"
;;; " "GtkWidget" "hGtkAdjustment" "vGtkAdjustment")\n")
(let ((haddr (alien/address-string hGtkAdjustment))
(vaddr (alien/address-string vGtkAdjustment)))
- (%trace "; Adjustments: 0x"haddr" 0x"vaddr"\n"))
+ (trace "; Adjustments: 0x"haddr" 0x"vaddr"\n"))
(connect-adjustment (scm-layout-hadjustment widget) hGtkAdjustment
widget set-scm-layout-hadjustment!)
(connect-adjustment (scm-layout-vadjustment widget) vGtkAdjustment
(named-lambda (scm-layout::adjustment-value-changed GtkAdjustment)
GtkAdjustment ;;Ignored.
-;;; (%trace ";((scm-layout-adjustment-value-changed "widget" "adjustment")"
+;;; (trace ";((scm-layout-adjustment-value-changed "widget" "adjustment")"
;;; " "GtkAdjustment")\n")
(let ((alien-widget (gobject-alien widget))
(cond ((eq? adjustment vadjustment)
(let* ((y (rect-y window-area))
(dy (int:- value y)))
- (%trace "; Vadjustment to "value" (dy:"dy")\n")
+ (trace "; Vadjustment to "value" (dy:"dy")\n")
(if (not (int:zero? dy))
(let ((width (rect-width window-area)))
(set-rect-y! window-area value)
(let* ((x (rect-x window-area))
(height (rect-height window-area))
(dx (int:- value x)))
- (%trace "; Hadjustment to "value" (dx:"dx")\n")
+ (trace "; Hadjustment to "value" (dx:"dx")\n")
(if (not (int:zero? dx))
(begin
(set-rect-x! window-area value)
(define (drawing-damage item #!optional rect)
;; Invalidates any widget areas affected by RECT in ITEM. By
;; default, RECT is ITEM's entire area.
-;;; (%trace ";(drawing-damage "drawing" "item")\n")
+;;; (trace ";(drawing-damage "drawing" "item")\n")
(let ((area (if (default-object? rect)
(drawn-item-area item)
(define-method drawn-item-expose ((item <box-item>) widget window area)
area ;;Ignored. Assumed clipping already set.
-;;; (%trace "; (Re)Drawing "item" on "widget".\n")
+;;; (trace "; (Re)Drawing "item" on "widget".\n")
(let ((widgets (drawn-item-widgets item)))
(if (or (eq? #f widgets)
(define-method drawn-item-expose ((item <hline-item>) widget window area)
area ;;Ignored. Assumed clipping already set.
-;;; (%trace "; (Re)Drawing "item" on "widget".\n")
+;;; (trace "; (Re)Drawing "item" on "widget".\n")
(let ((widgets (drawn-item-widgets item)))
(if (or (eq? #f widgets)
(define-method drawn-item-expose ((item <vline-item>) widget window area)
area ;;Ignored. Assumed clipping already set.
-;;; (%trace "; (Re)Drawing "item" on "widget".\n")
+;;; (trace "; (Re)Drawing "item" on "widget".\n")
(let ((widgets (drawn-item-widgets item)))
(if (or (eq? #f widgets)
(define-method initialize-instance ((item <text-item>) where)
(call-next-method item where)
(add-gc-cleanup item
- (text-item-finalize-thunk (text-item-pango-layout item))))
+ (text-item-cleanup-thunk (text-item-pango-layout item))))
-(define (text-item-finalize-thunk pango-layout)
- ;; Return a thunk closed over PANGO-LAYOUT (NOT the item).
- (lambda ()
+(define (text-item-cleanup-thunk pango-layout)
+ ;; Return a thunk closed over PANGO-LAYOUT (but not the item).
+ ;; Thunk is run as a gc-cleanup, without-interrupts.
+ (named-lambda (text-item::cleanup-thunk)
+ (trace ";text-item::cleanup-thunk "pango-layout"\n")
(if (not (alien-null? pango-layout))
(begin
(C-call "g_object_unref" pango-layout)
- (alien-null! pango-layout)))))
+ (alien-null! pango-layout)))
+ (trace ";text-item::cleanup-thunk done with "pango-layout"\n")))
(define-method drawn-item-expose ((item <text-item>) widget window area)
area ;;Ignored. Assumed clipping already set.
-;;; (%trace "; (Re)Drawing "item" on "widget".\n")
+;;; (trace "; (Re)Drawing "item" on "widget".\n")
(let ((widgets (drawn-item-widgets item)))
(if (or (eq? #f widgets)
(define-class (<image-item> (constructor add-image-item (drawing) 1))
(<drawn-item>)
- (pixbuf-loader define accessor
- initializer make-pixbuf-loader)
- (pixbuf define standard initial-value #f))
+ ;; This slot is set to a <pixbuf> soon after loading has begun.
+ (pixbuf define standard initial-value #f)
+ ;; This slot is set to #f when the pixbuf has been successfully loaded.
+ (loader define standard initializer make-pixbuf-loader))
(define-method initialize-instance ((item <image-item>) where)
(call-next-method item where)
- (let ((loader (image-item-pixbuf-loader item)))
- (g-signal-connect loader (C-callback "size_prepared")
- (image-item-size-prepared item))
- (g-signal-connect loader (C-callback "area_prepared")
- (image-item-area-prepared item))
- (g-signal-connect loader (C-callback "area_updated")
- (image-item-area-updated item))))
+ (let ((loader (image-item-loader item)))
+ (set-pixbuf-loader-size-hook! loader (image-item-size-prepared item))
+ (set-pixbuf-loader-pixbuf-hook! loader (image-item-pixbuf-prepared item))
+ (set-pixbuf-loader-update-hook! loader (image-item-pixbuf-updated item))
+ (set-pixbuf-loader-close-hook! loader (image-item-pixbuf-loaded item))))
(define (image-item-size-prepared item)
- (named-lambda (image-item::size-prepared GdkPixbufLoader width height)
- GdkPixbufLoader ;;Ignored.
- (%trace "; image-item::size-prepared "item" "width" "height"\n")
-
+ (named-lambda (image-item::size-prepared width height)
+ (trace "; image-item::size-prepared "item" "width" "height"\n")
(%set-drawn-item-size! item width height)))
-(define (image-item-area-prepared item)
- (named-lambda (image-item::area-prepared GdkPixbufLoader)
- GdkPixbufLoader ;;Ignored.
-
- (let ((loader (image-item-pixbuf-loader item))
- (pixbuf (if (not (image-item-pixbuf item))
- (let ((a (make-alien '|GdkPixbuf|)))
- (set-image-item-pixbuf! item a)
- a)
- (ferror "Image-item "item" already has a pixbuf!"))))
- (C-call "gdk_pixbuf_loader_get_pixbuf" pixbuf (gobject-alien loader))
- ;; Fill with non-background (non-fg) color? (Pick from a GtkStyle!!!)
- (%trace "; image-item::area-prepared "item" ("pixbuf")\n"))))
-
-(define (image-item-area-updated item)
- (named-lambda (image-item::area-updated GdkPixbufLoader x y width height)
- GdkPixbufLoader ;;Ignored.
-
- (let ((rect (make-rect x y width height)))
- (%trace "; image-item::area-updated "item" "rect"\n")
- (drawing-damage item rect))))
+(define (image-item-pixbuf-prepared item)
+ (named-lambda (image-item::pixbuf-prepared pixbuf)
+ (trace "; image-item::pixbuf-prepared "item" "pixbuf"\n")
+ (set-image-item-pixbuf! item pixbuf)))
+
+(define (image-item-pixbuf-updated item)
+ (named-lambda (image-item::pixbuf-updated rectangle)
+ (trace "; image-item::pixbuf-updated "item" "rectangle"\n")
+ (drawing-damage item rectangle)))
+
+(define (image-item-pixbuf-loaded item)
+ (named-lambda (image-item::pixbuf-loaded loader)
+ (trace "; image-item::pixbuf-loaded "item" ("(image-item-pixbuf item)")"
+ " "(pixbuf-loader-error-message loader)"\n")
+ (if (not (pixbuf-loader-error-message loader))
+ (begin
+ (set-image-item-loader! item #f)
+ (gobject-unref loader))
+ (begin
+ ;; Hack the pixbuf with a "broken image" overlay?
+ ;;
+ ;; Leave the loader, with dead thread and closed
+ ;; input-port, for debugging purposes.
+ unspecific))))
(define-method drawn-item-expose ((item <image-item>) widget window area)
-;;; (%trace "; (Re)Drawing "item" on "widget".\n")
+;;; (trace "; (Re)Drawing "item" on "widget".\n")
(let ((widgets (drawn-item-widgets item)))
(if (or (eq? #f widgets)
(memq widget widgets))
- (let ((pixbuf (image-item-pixbuf item)))
+ (let ((pixbuf (let ((p (image-item-pixbuf item)))
+ (if p (gobject-alien p) #f))))
(if (and pixbuf (not (alien-null? pixbuf)))
(let ((item-area (drawn-item-area item))
(scroll (scm-layout-on-screen-area widget))
(define (add-image-item-from-file drawing where filename)
;; WHERE can be 'TOP (or #f) or 'BOTTOM.
(let ((item (add-image-item drawing (check-where where))))
- (load-pixbuf-from-file (image-item-pixbuf-loader item) filename)
+ (load-pixbuf-from-file (image-item-loader item) filename)
item))
(define (check-where where)
obj)
(ferror "Not a non-negative integer: "obj)))
-(define (check-!null alien message)
- (if (alien-null? alien)
- (ferror "scm-layout: "message)
- alien))
-
-(define %trace? #f)
-(define (%trace . objects)
- (if %trace?
+(define trace? #f)
+(define (trace . objects)
+ (if trace?
(apply outf-console objects)))
\ No newline at end of file
;;; parent: (runtime thread)
-(define tracing? #f)
-
-(define-syntax trace
- (syntax-rules ()
- ((_ . MSG)
- (if tracing? ((lambda () (outf-console . MSG)))))))
-
(define gtk-thread #f)
;;; With the following thread always running, the runtime system
(set! gtk-thread
(create-thread
#f (lambda ()
- (let ((self (current-thread)))
+ (let ((self (current-thread))
+ (done-tick 0))
(let gtk-thread-loop ()
- (let ((time (time-limit self)))
- (trace ";run-gtk until "time"\n")
- ((ucode-primitive run-gtk 2)
- (select-registry-handle io-registry) time)
- (trace ";run-gtk done at "(real-time-clock)"\n"))
- (signal-thread-events)
+ (without-interrupts
+ (lambda ()
+ (let ((gc-tick (car (gc-timestamp))))
+ (if (fix:< done-tick gc-tick)
+ (begin
+ (run-gc-cleanups)
+ (set! done-tick gc-tick))))))
+ (without-interrupts
+ (lambda ()
+ (let ((time (time-limit self)))
+ (trace ";run-gtk until "time"\n")
+ ((ucode-primitive run-gtk 2)
+ (select-registry-handle io-registry) time)
+ (trace ";run-gtk done at "(real-time-clock)"\n"))
+ (maybe-signal-io-thread-events)))
(yield-current-thread)
(gtk-thread-loop)))))))
-(define (signal-thread-events)
- ;; NOTE: This should match the start of thread-timer-interrupt-handler.
- (set! next-scheduled-timeout #f)
- (deliver-timer-events)
- (maybe-signal-io-thread-events))
-
(define (time-limit self)
(if (thread/next self)
0
(define (kill-gtk-thread)
(if (not gtk-thread) (error "A GTk thread is not running."))
(signal-thread-event
- gtk-thread (lambda () (exit-current-thread #t))))
\ No newline at end of file
+ gtk-thread (lambda () (exit-current-thread #t))))
+
+(define trace? #f)
+
+(define-syntax trace
+ (syntax-rules ()
+ ((_ . MSG)
+ (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! tracing? #f)
+ (set! trace? #f)
(detach-thread (make-thread #f))
(add-event-receiver! event:before-exit stop-thread-timer))
(flo:set-environment! fp-env)
(%resume-current-thread thread))))))
-(define tracing? #f)
+(define trace? #f)
(define-syntax trace
(syntax-rules ()
((_ . MSG)
- (if tracing? ((lambda () (outf-console . MSG)))))))
+ (if trace? ((lambda () (outf-console . MSG)))))))
(define (yield-current-thread)
(without-interrupts
projects / mit-scheme.git / commitdiff