(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|))
(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|))
(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|))
((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
(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
(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))))
(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".
(%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))))))
(%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)))
(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)))))))
(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
((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)
;; 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|)))
(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)
(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))
(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)
(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))))
(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
(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 (<gtk-css-provider> (constructor ()))
(<gobject-with-gerror*>))
(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)
(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
(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)
(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)
(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))))
(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
projects / mit-scheme.git / commitdiff