From: Matt Birkholz Date: Wed, 12 Jul 2017 21:51:56 +0000 (-0700) Subject: gtk plugins: Expect c-peek-cstring to return a string, not bytes. X-Git-Tag: mit-scheme-pucked-9.2.12~107 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f00904086f2734d174d748e7c90744a4ea4d0b94;p=mit-scheme.git gtk plugins: Expect c-peek-cstring to return a string, not bytes. --- diff --git a/src/cairo/cairo.scm b/src/cairo/cairo.scm index 9e9a1cd77..0308b37f0 100644 --- a/src/cairo/cairo.scm +++ b/src/cairo/cairo.scm @@ -59,7 +59,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (let ((msg (C-call "cairo_status_to_string" (make-alien '(* (const char))) status))) - (error (utf8->string (c-peek-cstring msg)) surface))))) + (error (c-peek-cstring msg) surface))))) (define (guarantee-cairo-surface object operator) (if (and (alien? object) (eq? (alien/ctype object) '|cairo_surface_t|)) @@ -119,7 +119,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (let ((msg (C-call "cairo_status_to_string" (make-alien '(* (const char))) status))) - (error (utf8->string (c-peek-cstring msg)) pattern))))) + (error (c-peek-cstring msg) pattern))))) (define (guarantee-cairo-pattern object operator) (if (and (alien? object) (eq? (alien/ctype object) '|cairo_pattern_t|)) @@ -165,7 +165,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (let ((msg (C-call "cairo_status_to_string" (make-alien '(* (const char))) status))) - (error (utf8->string (c-peek-cstring msg)) cairo))))) + (error (c-peek-cstring msg) cairo))))) (define (guarantee-cairo object operator) (if (and (alien? object) (eq? (alien/ctype object) '|cairo_t|)) diff --git a/src/glib/gio.scm b/src/glib/gio.scm index dd0782ebc..d9f4e8187 100644 --- a/src/glib/gio.scm +++ b/src/glib/gio.scm @@ -60,11 +60,6 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ((pathname=? again simpler) again) (else (loop again (fix:1+ count))))))) -(define (->string object) - (if (string? object) - object - (utf8->string object))) - (define (make-g-stream-source gstream) (let ((open? #t)) (make-non-channel-input-source @@ -309,7 +304,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (begin (C->= pointer "* GError" 0) (C-call "g_error_free" gerror))) - (->string message))) + message)) (define-integrable (%queue! queue value) ;; The GIO finish callbacks use this procedure to queue a value on a @@ -776,15 +771,13 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (cond ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_INVALID")) (error "Invalid attribute:" name)) ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_STRING")) - (->string - (c-peek-cstring - (C-call "g_file_info_get_attribute_string" - (make-alien 'char) alien name-bv)))) + (c-peek-cstring + (C-call "g_file_info_get_attribute_string" + (make-alien 'char) alien name-bv))) ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_BYTE_STRING")) - (->string - (c-peek-cstring - (C-call "g_file_info_get_attribute_byte_string" - (make-alien 'uchar) alien name-bv)))) + (c-peek-cstring + (C-call "g_file_info_get_attribute_byte_string" + (make-alien 'uchar) alien name-bv))) ((fix:= type (C-enum "G_FILE_ATTRIBUTE_TYPE_BOOLEAN")) (not (fix:zero? (C-call "g_file_info_get_attribute_boolean" alien name-bv)))) @@ -1103,18 +1096,18 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (named-lambda (mount-password-callback gmountop message user domain flags) (%trace-auth ";mount-password-callback "(gfile-uri gfile) " "gmountop - " "(->string (c-peek-cstring message)) - " "(->string (c-peek-cstring user)) - " "(->string (c-peek-cstring domain)) + " "(c-peek-cstring message) + " "(c-peek-cstring user) + " "(c-peek-cstring domain) " "(->ask-password-flags flags)"\n") (let ((old (g-mount-operation-ask-password-flags gmountop)) (new (->ask-password-flags flags))) (set-g-mount-operation-message! gmountop - (->string (c-peek-cstring message))) + (c-peek-cstring message)) (set-g-mount-operation-username! gmountop - (->string (c-peek-cstring user))) + (c-peek-cstring user)) (set-g-mount-operation-domain! gmountop - (->string (c-peek-cstring domain))) + (c-peek-cstring domain)) (set-g-mount-operation-ask-password-flags! gmountop new) (cond ((not old) ;; Punt, %queuing "Password dialog cancelled". @@ -1147,13 +1140,13 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%trace-auth ";make-mount-question-callback" " "(gfile-uri gfile) " "gmountop - " "(->string (c-peek-cstring message)) + " "(c-peek-cstring message) " "(peek-gstrv! choices)"\n") (warn "Unimplemented" 'mount-question-callback))) (define (peek-gstrv! alien) (let loop () - (let ((str (->string (c-peek-cstringp! alien)))) + (let ((str (c-peek-cstringp! alien))) (if (null? str) '() (cons str (loop)))))) @@ -1163,7 +1156,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%trace-auth ";make-mount-processes-callback" " "gfile " "gmountop - " "(->string (c-peek-cstring message)) + " "(c-peek-cstring message) " "processes " "(peek-gstrv! choices)"\n") (warn "Unimplemented" 'mount-processes-callback))) @@ -1223,7 +1216,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (C-> scan "* uchar" cstr) (if (alien-null? cstr) '() - (let ((str (->string (c-peek-cstring cstr)))) + (let ((str (c-peek-cstring cstr))) (alien-byte-increment! scan (C-sizeof "* uchar")) (cons str (loop))))))) diff --git a/src/glib/glib-tests.scm b/src/glib/glib-tests.scm index 4dc83863c..38173e814 100644 --- a/src/glib/glib-tests.scm +++ b/src/glib/glib-tests.scm @@ -79,6 +79,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)) + (c-peek-cstring alien) alien))) (access malloced-aliens ffi)))))) \ No newline at end of file diff --git a/src/glib/gobject.scm b/src/glib/gobject.scm index 3e33e13ba..4ded11da6 100644 --- a/src/glib/gobject.scm +++ b/src/glib/gobject.scm @@ -196,9 +196,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ((int:= type (C-enum "G_TYPE_STRING")) (let ((alien (make-alien '(const (* |gchar|))))) (C-call "g_value_get_string" alien gvalue) - (let ((bv (c-peek-cstring alien))) + (let ((str (c-peek-cstring alien))) (free alien) - (utf8->string bv)))) + str))) ((int:= type (C-enum "G_TYPE_POINTER")) (let ((alien (make-alien '|gpointer|))) (C-call "g_value_get_pointer" alien gvalue) @@ -316,7 +316,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ;; GCLASS should be an alien of type GObjectClass. (let ((c* (make-alien '(* |gchar|)))) (C-call "G_OBJECT_CLASS_NAME" c* gclass) - (utf8->string (c-peek-cstring c*)))) + (c-peek-cstring c*))) (define (gobject-get-gtype gobject) (let ((ret (make-alien '|GType|))) diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm index 558db5be8..898735270 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 (bytes->string (c-peek-cstring alien))) + (let ((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 ba92aa3a0..8e862ffaa 100644 --- a/src/gtk/gdk.scm +++ b/src/gtk/gdk.scm @@ -141,9 +141,8 @@ 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)) - (bytes->string - (c-peek-cstring - (C-> gerror "GError message")))) + (c-peek-cstring + (C-> gerror "GError message"))) "GError pointer not set."))) (set-pixbuf-loader-error-message! loader message)) (note-done)) @@ -308,7 +307,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (declare (ignore clipboard)) (if (alien-null? char*) (queue! queue #t) - (queue! queue (bytes->string (c-peek-cstring char*))))))) + (queue! queue (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 482b7b670..72523658d 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) - (bytes->string (c-peek-cstring alien))))) + (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 72206f07b..158cfef0e 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)) - (bytes->string (c-peek-cstring alien)) + (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 3c0563ebd..7ff195fb7 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-bytes (c-peek-cstring (C-> gerror "GError message")))) + (let ((errmsg (c-peek-cstring (C-> gerror "GError message")))) (without-interruption (lambda () (C->= gerror* "* GError" 0) (C-call "g_error_free" gerror))) - (apply error message (bytes->string errmsg-bytes) data))))) + (apply error message errmsg data))))) (define-class ( (constructor ())) ()) @@ -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)) - (bytes->string (c-peek-cstring retval)))) + (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 93c6a1fa6..6fc6f64cc 100644 --- a/src/gtk/gtk.scm +++ b/src/gtk/gtk.scm @@ -105,13 +105,4 @@ 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)) - -(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 + color)) \ No newline at end of file diff --git a/src/gtk/main.scm b/src/gtk/main.scm index 6f4df7c1d..3a8d8baa8 100644 --- a/src/gtk/main.scm +++ b/src/gtk/main.scm @@ -101,8 +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 (bytes->string - (c-peek-cstringp! vector-scan)) + (cons (c-peek-cstringp! vector-scan) args)) (reverse! args))))) (free bytes) diff --git a/src/pango/pango.scm b/src/pango/pango.scm index 89c060c70..01c9df92f 100644 --- a/src/pango/pango.scm +++ b/src/pango/pango.scm @@ -212,9 +212,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (lambda () (let ((cstr (make-alien '|char|))) (C-call "pango_font_description_to_string" cstr font) - (let ((str-bv (c-peek-cstring cstr))) + (let ((str (c-peek-cstring cstr))) (C-call "g_free" cstr) - (utf8->string str-bv))))))) + str)))))) (define (pango-font-description-copy font) (guarantee-pango-font-description font 'pango-font-description-copy) @@ -360,7 +360,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (pango-font-family-get-name PangoFontFamily) (let ((name (make-alien '(const char)))) (C-call "pango_font_family_get_name" name PangoFontFamily) - (utf8->string (c-peek-cstring name)))) + (c-peek-cstring name))) (define (pango-font-family-is-monospace? PangoFontFamily) (not (fix:zero? (C-call "pango_font_family_is_monospace" PangoFontFamily)))) @@ -391,4 +391,4 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (pango-font-face-get-name PangoFontFace) (let ((name (make-alien '(const char)))) (C-call "pango_font_face_get_face_name" name PangoFontFace) - (utf8->string (c-peek-cstring name)))) \ No newline at end of file + (c-peek-cstring name))) \ No newline at end of file