Fixed GError GC-cleanup, again.

And integrated gerror->message back into create-pixbuf-loader-thread.

diff --git a/src/gtk/gio.scm b/src/gtk/gio.scm
index b54ef5229bcf98a5321cf5b72635cb797ff59d94..8ae5dd7092040c1915f5cc54b2524f9cbdb6e5f1 100644 (file)
--- 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 <g-stream> 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 <g-input-stream>))
   (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 <g-output-stream>))
   (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 03541dffd672c769e96134dbff47d945dcb12269..bdffeae7e3bfeb1ae4f60bddf5f87a35accc5ddf 100644 (file)
--- 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))
 \f
 ;;; 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)))