From 3c8c6fe1021e8fbfb5f79c999a1dc0b8837207b2 Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Wed, 20 Jul 2011 17:15:18 -0700 Subject: [PATCH] Fixed GError GC-cleanup, again. And integrated gerror->message back into create-pixbuf-loader-thread. --- src/gtk/gio.scm | 85 +++++++++++++++++++++++++-------------------- src/gtk/gobject.scm | 42 +++++++++++----------- 2 files changed, 67 insertions(+), 60 deletions(-) diff --git a/src/gtk/gio.scm b/src/gtk/gio.scm index b54ef5229..8ae5dd709 100644 --- a/src/gtk/gio.scm +++ b/src/gtk/gio.scm @@ -99,9 +99,9 @@ USA. ;;; When these streams are GCed, any pending operation must be ;;; cancelled. This ensures that the operation's finish callback will ;;; not be called and can be safely de-registered. The cancel-info -;;; includes the GError *ptr, GCancellable, the finish callback ids, -;;; AND a flag to indicate whether an operation is pending and thus -;;; whether the GCancellable should be used. +;;; includes the GError *pointer, GCancellable, the finish callback +;;; ids, AND a flag to indicate whether an operation is pending and +;;; thus whether the GCancellable should be used. ;;; The subclasses' cancel-info is separated from the so ;;; that the latter can be GCed while the -info stays with a @@ -119,17 +119,16 @@ USA. (make-alien '(* |GError|))) (define-structure g-input-stream-cancel-info - pending-op ; #f, OPEN, READ, SKIP, CLOSE or ERROR. - callback-id ; #f or the open/close finish callback ID - gcancellable ; a GCancellable alien - gerror-pointer ; null or malloced GError* that MAY ref. a GError + pending-op ; #f, OPEN, READ, SKIP, CLOSE or ERROR. + callback-id ; #f or the open/close finish callback ID + gcancellable ; a GCancellable alien + gerror-pointer ; null or malloced GError* that MAY ref. a GError ;; To avoid registering read or skip finish callbacks for every read ;; or skip (a LOT of registering/deregistering!), the open operation ;; (i.e. gfile-read) registers them in advance. - read-id ; #f or the read finish callback ID - skip-id ; #f or the skip finish callback ID - ) + read-id + skip-id) (define-method initialize-instance ((object )) (call-next-method object) @@ -137,7 +136,9 @@ USA. (gerror* (g-input-stream-cancel-info-gerror-pointer info))) (add-gc-cleanup object (make-g-input-stream-cleanup info)) - ((ucode-primitive c-malloc 2) gerror* (C-sizeof "*")))) + ((ucode-primitive c-malloc 2) gerror* (C-sizeof "*")) + (error-if-null gerror* "Could not create:" gerror*) + (C->= gerror* "*" 0))) (define (make-g-input-stream-cleanup info) (named-lambda (g-input-stream-cleanup) @@ -176,7 +177,8 @@ USA. (C-> gerror* "* GError" gerror) (if (not (alien-null? gerror)) (C-call "g_error_free" gerror)) - ((ucode-primitive c-free 1) gerror*)))) + ((ucode-primitive c-free 1) gerror*) + (alien-null! gerror*)))) (define (g-input-stream-read gstream buffer start end) (let* ((info (g-input-stream-cancel-info gstream)) @@ -211,19 +213,22 @@ USA. (named-lambda (g-input-stream-read-finish-callback source result) (let ((bytes (C-call "g_input_stream_read_finish" source result gerror*))) (if (fix:= bytes -1) - (let ((message (gerror-message gerror*))) + (let ((message (%gerror-message gerror*))) (%trace ";g-input-stream-read-finish-callback "message" "queue"\n") (%queue! queue message)) (begin (%trace ";g-input-stream-read-finish-callback "bytes" "queue"\n") (%queue! queue bytes))))))) -(define-integrable (gerror-message pointer) - (let* ((GError (C-> pointer "* GError")) - (message (or (and (not (alien-null? GError)) - (c-peek-cstring (C-> GError "GError message"))) +(define-integrable-operator (%gerror-message pointer) + (let* ((gerror (C-> pointer "* GError")) + (message (or (and (not (alien-null? gerror)) + (c-peek-cstring (C-> gerror "GError message"))) "GError pointer not set."))) - (C->= pointer "* GError" 0) + (if (not (alien-null? gerror)) + (begin + (C->= pointer "* GError" 0) + (C-call "g_error_free" gerror))) message)) (define-integrable (%queue! queue value) @@ -262,7 +267,7 @@ USA. (named-lambda (g-input-stream-skip-finish-callback source result) (let ((bytes (C-call "g_input_stream_skip_finish" source result gerror*))) (if (fix:= bytes -1) - (let ((message (gerror-message gerror*))) + (let ((message (%gerror-message gerror*))) (%trace ";g-input-stream-skip-finish-callback "message" "queue"\n") (%queue! queue message)) (begin @@ -307,7 +312,7 @@ USA. (named-lambda (g-input-stream-close-finish-callback source result) (if (fix:zero? (C-call "g_input_stream_close_finish" source result gerror*)) - (let ((message (gerror-message gerror*))) + (let ((message (%gerror-message gerror*))) (%trace ";g-input-stream-close-finish-callback "message" "queue"\n") (%queue! queue message)) (begin @@ -323,10 +328,10 @@ USA. #f #f (make-gcancellable) (make-alien '(* |GError|)) #f #f)))) (define-structure g-output-stream-cancel-info - pending-op ; #f, OPEN, WRITE, FLUSH, CLOSE or ERROR. - callback-id ; #f or the open/close finish callback ID - gcancellable ; a GCancellable alien - gerror-pointer ; null or malloced GError* that MAY ref. a GError + pending-op ; #f, OPEN, WRITE, FLUSH, CLOSE or ERROR. + callback-id ; #f or the open/close finish callback ID + gcancellable ; a GCancellable alien + gerror-pointer ; null or malloced GError* that MAY ref. a GError ;; To avoid registering write or flush finish callbacks for every ;; write or flush (a LOT of registering/deregistering!), the open @@ -337,9 +342,13 @@ USA. (define-method initialize-instance ((object )) (call-next-method object) - (add-gc-cleanup object - (make-g-output-stream-cleanup - (g-output-stream-cancel-info object)))) + (let* ((info (g-output-stream-cancel-info object)) + (gerror* (g-output-stream-cancel-info-gerror-pointer info))) + (add-gc-cleanup object + (make-g-output-stream-cleanup info)) + ((ucode-primitive c-malloc 2) gerror* (C-sizeof "*")) + (error-if-null gerror* "Could not create:" gerror*) + (C->= gerror* "*" 0))) (define (make-g-output-stream-cleanup info) (named-lambda (g-output-stream-cleanup) @@ -391,7 +400,7 @@ USA. (let ((bytes (C-call "g_output_stream_write_finish" source result gerror*))) (if (fix:= bytes -1) - (let ((message (gerror-message gerror*))) + (let ((message (%gerror-message gerror*))) (%trace ";g-output-stream-write-finish-callback "message " "queue"\n") (%queue! queue message)) @@ -427,7 +436,7 @@ USA. (named-lambda (g-output-stream-flush-finish-callback source result) (if (fix:zero? (C-call "g_output_stream_flush_finish" source result gerror*)) - (let ((message (gerror-message gerror*))) + (let ((message (%gerror-message gerror*))) (%trace ";g-output-stream-flush-finish-callback "message" "queue"\n") (%queue! queue message)) (begin @@ -473,7 +482,7 @@ USA. (named-lambda (g-output-stream-close-finish-callback source result) (if (fix:zero? (C-call "g_output_stream_close_finish" source result gerror*)) - (let ((message (gerror-message gerror*))) + (let ((message (%gerror-message gerror*))) (%trace ";g-output-stream-close-finish-callback "message" "queue"\n") (%queue! queue message)) (begin @@ -529,7 +538,7 @@ USA. (named-lambda (gfile-read-finish-callback source result) (let ((bytes (C-call "g_file_read_finish" alien source result gerror*))) (if (fix:= bytes -1) - (let ((message (gerror-message gerror*))) + (let ((message (%gerror-message gerror*))) (%trace ";g-file-read-finish-callback \""message"\" "queue"\n") (%queue! queue message)) (begin @@ -546,7 +555,7 @@ USA. (define (gfile-append-to gfile . flags) (let ((flags* (->gfile-create-flags flags))) - (gfile-open gfile + (gfile-open gfile 'append-to (lambda (gfile priority gcancellable callback id) (C-call "g_file_append_to_async" gfile flags* @@ -571,7 +580,7 @@ USA. (define (gfile-create gfile . flags) (let ((flags* (->gfile-create-flags flags))) - (gfile-open gfile + (gfile-open gfile 'create (lambda (gfile priority gcancellable callback id) (C-call "g_file_create_async" gfile flags* @@ -588,7 +597,7 @@ USA. (let ((etag (->gfile-etag etag)) (make-backups (if backup? 1 0)) (flags* (->gfile-create-flags flags))) - (gfile-open gfile + (gfile-open gfile 'replace (lambda (gfile priority gcancellable callback id) (C-call "g_file_replace_async" gfile etag make-backups flags* @@ -609,7 +618,7 @@ USA. (C-call "g_file_replace_finish" alien source result gerror*) (g-output-stream-finish alien queue gerror* 'replace)))) -(define-integrable (gfile-open gfile callout make-callback) +(define-integrable-operator (gfile-open gfile op callout make-callback) (let* ((gstream (make-g-output-stream)) (info (g-output-stream-cancel-info gstream)) (gerror* (g-output-stream-cancel-info-gerror-pointer info)) @@ -619,7 +628,7 @@ USA. (lambda () (let* ((alien (gobject-alien gstream)) (id (make-callback alien queue gerror*))) - (set-g-output-stream-cancel-info-pending-op! info 'OPEN) + (set-g-output-stream-cancel-info-pending-op! info op) (set-g-output-stream-cancel-info-callback-id! info id) id))))) (callout (gobject-alien gfile) @@ -645,9 +654,9 @@ USA. (make-g-output-stream-flush-finish-callback queue gerror*)))) gstream))))) -(define-integrable (g-output-stream-finish alien queue gerror* op) +(define-integrable-operator (g-output-stream-finish alien queue gerror* op) (if (alien-null? alien) - (let ((message (gerror-message gerror*))) + (let ((message (%gerror-message gerror*))) (%trace ";g-output-stream-"op"-callback "message" "queue"\n") (%queue! queue message)) (begin diff --git a/src/gtk/gobject.scm b/src/gtk/gobject.scm index 03541dffd..bdffeae7e 100644 --- a/src/gtk/gobject.scm +++ b/src/gtk/gobject.scm @@ -462,15 +462,6 @@ USA. (set! gquark-from-string-cache (make-string-hash-table)) (set! gquark-to-string-cache (make-eqv-hash-table)) unspecific) - -(define-integrable (gerror->message pointer) - (let* ((GError (C-> pointer "* GError")) - (message (or (and (not (alien-null? GError)) - (c-peek-cstring (C-> GError "GError message"))) - "GError pointer not set."))) - (C->= pointer "* GError" 0) - (C-call "g_error_free" GError) - message)) ;;; GdkPixbufLoaders @@ -550,37 +541,44 @@ USA. (%trace "; "loader" started in "(current-thread)"\n") (let ((port (pixbuf-loader-port loader)) (alien (gobject-alien loader)) - (*gerror (malloc (C-sizeof "*") '(* |GError|))) + (gerror* (malloc (C-sizeof "*") '(* |GError|))) (buff (allocate-external-string 4200))) - (C->= *gerror "* GError" 0) + (C->= gerror* "* GError" 0) (let ((buff-address (external-string-descriptor buff))) (define (note-done) - (free *gerror) + (free gerror*) (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)))))) + (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) - (set-pixbuf-loader-error-message! loader - (gerror->message *gerror)) + (let* ((gerror (C-> gerror* "* GError")) + (message (or (and (not (alien-null? gerror)) + (c-peek-cstring + (C-> gerror "GError message"))) + "GError pointer not set."))) + (if (not (alien-null? gerror)) + (begin + (C-call "g_error_free" gerror))) + (set-pixbuf-loader-error-message! loader message)) (note-done)) (let loop () (let ((n (input-port/read-string! port buff))) (cond ((and (fix:zero? n) (eof-object? (peek-char port))) (if (fix:zero? (C-call "gdk_pixbuf_loader_close" - alien *gerror)) + alien gerror*)) (note-error) (note-done))) ((not (fix:zero? (C-call "gdk_pixbuf_loader_write" - alien buff-address n *gerror))) + alien buff-address n gerror*))) (loop)) (else (note-error)))))))))) @@ -614,7 +612,7 @@ USA. (guarantee-gdk-window gdkwindow 'gdk-window-process-updates) (C-call "gdk_window_process_updates" gdkwindow (if children-too? 1 0))) -(define-integrable (guarantee-gdk-window object operator) +(define-integrable-operator (guarantee-gdk-window object operator) (if (not (and (alien? object) (eq? '|GdkWindow| (alien/ctype object)))) (error:wrong-type-argument object "a GdkWindow address" operator))) -- 2.25.1