From: Matt Birkholz <matt@birkholz.chandler.az.us>
Date: Wed, 20 Jul 2011 22:14:38 +0000 (-0700)
Subject: Fixed GError GC-cleanup.
X-Git-Tag: mit-scheme-pucked-9.2.12~669
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3ed612e47bff564772be0ee3508dbcec36e9600f;p=mit-scheme.git

Fixed GError GC-cleanup.
---

diff --git a/src/gtk/gio.scm b/src/gtk/gio.scm
index 2bb59658d..b54ef5229 100644
--- a/src/gtk/gio.scm
+++ b/src/gtk/gio.scm
@@ -211,13 +211,21 @@ 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")))
+		      "GError pointer not set.")))
+    (C->= pointer "* GError" 0)
+    message))
+
 (define-integrable (%queue! queue value)
   ;; The GIO finish callbacks use this procedure to queue a value on a
   ;; g-stream's queue AND signal the main loop if Scheme has become
@@ -254,7 +262,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
@@ -299,7 +307,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
@@ -383,7 +391,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))
@@ -419,7 +427,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
@@ -465,7 +473,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
@@ -521,7 +529,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
@@ -639,7 +647,7 @@ USA.
 
 (define-integrable (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/gtk.pkg b/src/gtk/gtk.pkg
index 4b617433c..2aeb837f0 100644
--- a/src/gtk/gtk.pkg
+++ b/src/gtk/gtk.pkg
@@ -44,7 +44,6 @@ USA.
 	  add-gc-cleanup punt-gc-cleanup
 	  gobject-get-property gobject-set-properties
 	  gquark-from-string gquark-to-string
-	  gerror->message
 	  <pixbuf-loader> make-pixbuf-loader
 	  load-pixbuf-from-port load-pixbuf-from-file
 	  pixbuf-loader-size-hook set-pixbuf-loader-size-hook!