From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Thu, 2 Feb 2017 01:21:33 +0000 (-0700)
Subject: gtk: Use read-bytevector! and punt external strings.
X-Git-Tag: mit-scheme-pucked-9.2.12~230
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=71ea348830a03023bbd52fc58cfbcee565e636b3;p=mit-scheme.git

gtk: Use read-bytevector! and punt external strings.
---

diff --git a/src/gtk/gdk.scm b/src/gtk/gdk.scm
index e6d7763b2..1ecdad5c6 100644
--- a/src/gtk/gdk.scm
+++ b/src/gtk/gdk.scm
@@ -117,48 +117,52 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
 (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* (make-gerror-pointer))
-	      (buff (allocate-external-string 4200)))
-	  (C->= gerror* "* GError" 0)
-	  (let ((buff-address (external-string-descriptor buff)))
-
-	    (define (note-done)
-	      (gerror-pointer-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))))
-
-	    (define (note-error)
-	      (let* ((gerror (C-> gerror* "* GError"))
-		     (message (or (and (not (alien-null? gerror))
-				       (c-peek-cstring
-					(C-> gerror "GError message")))
-				  "GError pointer not set.")))
-		(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*))
-			   (note-error)
-			   (note-done)))
-		      ((not (fix:zero?
-			     (C-call "gdk_pixbuf_loader_write"
-				     alien buff-address n gerror*)))
-		       (loop))
-		      (else
-		       (note-error))))))))))
+      #f
+    (lambda ()
+      (%trace "; "loader" started in "(current-thread)"\n")
+      (let ((port (pixbuf-loader-port loader))
+	    (alien (gobject-alien loader))
+	    (gerror* (make-gerror-pointer))
+	    (buffer (make-bytevector 4200)))
+	(C->= gerror* "* GError" 0)
+
+	(define (note-done)
+	  (gerror-pointer-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)))
+	  unspecific)
+
+	(define (note-error)
+	  (let* ((gerror (C-> gerror* "* GError"))
+		 (message (or (and (not (alien-null? gerror))
+				   (c-peek-cstring
+				    (C-> gerror "GError message")))
+			      "GError pointer not set.")))
+	    (set-pixbuf-loader-error-message! loader message))
+	  (note-done))
+
+	(let loop ()
+	  (let ((n (read-bytevector! buffer port)))
+	    (cond ((eof-object? n)
+		   (if (fix:zero? (C-call "gdk_pixbuf_loader_close"
+					  alien gerror*))
+		       (note-error)
+		       (note-done)))
+		  ((or (not (fix:fixnum? n))
+		       (fix:zero? n))
+		   (note-error))
+		  ((not (fix:zero?
+			 (C-call "gdk_pixbuf_loader_write"
+				 alien buffer n gerror*)))
+		   (loop))
+		  (else
+		   (note-error)))))))))
 
 (define (make-gerror-pointer)
   (let ((alien (make-alien '(* |GError|)))
@@ -269,7 +273,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 
 (define (gdk-display-set-clipboard-text display string)
   (%trace "; gdk-display-set-clipboard-text "display"\n")
-  (let ((string (string->utf8-string string)))
+  (let ((string (string->utf8 string)))
     (C-call "gtk_clipboard_set_text"
 	     (clipboard display)
 	     string (string-length string))))