From: Matt Birkholz <matt@birchwood-abbey.net>
Date: Fri, 7 Jul 2017 14:55:44 +0000 (-0700)
Subject: gtk plugin: Apply bytes->string to value of c-peek-cstring.
X-Git-Tag: mit-scheme-pucked-9.2.12~110
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=c8a93ab552acb1874bf05f61dc5d48f46c9f86c4;p=mit-scheme.git

gtk plugin: Apply bytes->string to value of c-peek-cstring.
---

diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm
index 2d480dfd9..558db5be8 100644
--- a/src/gtk/fix-layout.scm
+++ b/src/gtk/fix-layout.scm
@@ -242,7 +242,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 	   (length (C-> GdkEvent "GdkEvent key length"))
 	   (state (C-> GdkEvent "GdkEvent key state"))
 	   (keyval (C-> GdkEvent "GdkEvent key keyval")))
-       (let ((string (utf8->string (c-peek-cstring alien)))
+       (let ((string (bytes->string (c-peek-cstring alien)))
 	     (char-bits (gdk-key-state->char-bits state)))
 	 (cond ((zero? (string-length string))
 		(cond ((fix:= length 1)
diff --git a/src/gtk/gdk.scm b/src/gtk/gdk.scm
index 85cdbe520..ba92aa3a0 100644
--- a/src/gtk/gdk.scm
+++ b/src/gtk/gdk.scm
@@ -141,7 +141,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 	(define (note-error)
 	  (let* ((gerror (C-> gerror* "* GError"))
 		 (message (or (and (not (alien-null? gerror))
-				   (utf8->string
+				   (bytes->string
 				    (c-peek-cstring
 				     (C-> gerror "GError message"))))
 			      "GError pointer not set.")))
@@ -308,7 +308,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
      (declare (ignore clipboard))
      (if (alien-null? char*)
 	 (queue! queue #t)
-	 (queue! queue (utf8->string (c-peek-cstring char*)))))))
+	 (queue! queue (bytes->string (c-peek-cstring char*)))))))
 
 (define (queue! queue value)
   (thread-queue/queue! queue value)
diff --git a/src/gtk/gtk-ev.scm b/src/gtk/gtk-ev.scm
index d761847b1..482b7b670 100644
--- a/src/gtk/gtk-ev.scm
+++ b/src/gtk/gtk-ev.scm
@@ -384,7 +384,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 				 (C-> GdkEvent "GdkEvent key keyval")))
 		 (text (let ((alien (make-alien '|gchar|)))
 			 (C-> GdkEvent "GdkEvent key string" alien)
-			 (utf8->string (c-peek-cstring alien)))))
+			 (bytes->string (c-peek-cstring alien)))))
 	     (cat "Keyval: "keyval" Text: "text"\n")))
 	  (else
 	   #f))))
diff --git a/src/gtk/gtk-tests.scm b/src/gtk/gtk-tests.scm
index a0eef89fd..72206f07b 100644
--- a/src/gtk/gtk-tests.scm
+++ b/src/gtk/gtk-tests.scm
@@ -47,6 +47,6 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 	       (map (lambda (elt)
 		      (let ((alien (weak-car elt)))
 			(if (eq? 'uchar (alien/ctype alien))
-			    (utf8->string (c-peek-cstring alien))
+			    (bytes->string (c-peek-cstring alien))
 			    alien)))
 		    (access malloced-aliens ffi))))))
\ No newline at end of file
diff --git a/src/gtk/gtk-widget.scm b/src/gtk/gtk-widget.scm
index 6a3b93b89..3c0563ebd 100644
--- a/src/gtk/gtk-widget.scm
+++ b/src/gtk/gtk-widget.scm
@@ -352,12 +352,12 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 (define (error-if-gerror* gerror* message . data)
   (let ((gerror (C-> gerror* "* GError")))
     (if (not (alien-null? gerror))
-	(let ((errmsg-bv (c-peek-cstring (C-> gerror "GError message"))))
+	(let ((errmsg-bytes (c-peek-cstring (C-> gerror "GError message"))))
 	  (without-interruption
 	   (lambda ()
 	     (C->= gerror* "* GError" 0)
 	     (C-call "g_error_free" gerror)))
-	  (apply error message (utf8->string errmsg-bv) data)))))
+	  (apply error message (bytes->string errmsg-bytes) data)))))
 
 (define-class (<gtk-css-provider> (constructor ()))
     (<gobject-with-gerror*>))
@@ -509,7 +509,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
   (guarantee-gtk-label label 'gtk-label-get-text)
   (let ((retval (make-alien '|gchar|)))
     (C-call "gtk_label_get_text" retval (gobject-alien label))
-    (utf8->string (c-peek-cstring retval))))
+    (bytes->string (c-peek-cstring retval))))
 
 (define (gtk-label-set-text label string)
   (guarantee-gtk-label label 'gtk-label-set-text)
diff --git a/src/gtk/gtk.scm b/src/gtk/gtk.scm
index 6fc6f64cc..93c6a1fa6 100644
--- a/src/gtk/gtk.scm
+++ b/src/gtk/gtk.scm
@@ -105,4 +105,13 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
     (set-color-green! color green)
     (set-color-blue! color blue)
     (set-color-alpha! color alpha)
-    color))
\ No newline at end of file
+    color))
+
+(declare (integrate-operator bytes->string))
+(define (bytes->string bytes)
+  (cond ((string? bytes)
+	 bytes)
+	((bytevector? bytes)
+	 (utf8->string bytes))
+	(else
+	 (error:wrong-type-argument bytes "a string or bytevector"))))
\ No newline at end of file
diff --git a/src/gtk/main.scm b/src/gtk/main.scm
index 7b9b01072..6f4df7c1d 100644
--- a/src/gtk/main.scm
+++ b/src/gtk/main.scm
@@ -101,7 +101,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
 		   (let loop ((i 0)(args '()))
 		     (if (fix:< i new-argc)
 			 (loop (fix:1+ i)
-			       (cons (utf8->string
+			       (cons (bytes->string
 				      (c-peek-cstringp! vector-scan))
 				     args))
 			 (reverse! args)))))