(if (not (zero? (C-call "x_window_set_input_hint" window (if hint? 1 0))))
(error "XAllocWMHints failed.")))
+(define-integrable primitive-u8-set! (ucode-primitive bytevector-u8-set! 3))
+
(define (->bytes string)
- (if (and (or (bytevector? string)
- (and (ustring? string)
- (fix:= 1 (ustring-cp-size string))))
- (let ((end (string-length string)))
- (every-loop (lambda (cp) (fix:< cp #x80))
- cp1-ref string 0 end)))
+ (if (bytevector? string)
string
- (string->iso8859-1 string)))
-
-(define-integrable (every-loop proc ref string start end)
- (let loop ((i start))
- (if (fix:< i end)
- (and (proc (ref string i))
- (loop (fix:+ i 1)))
- #t)))
+ (let* ((end (string-length string))
+ (result (make-bytevector (fix:1+ end))))
+ (do ((i 0 (fix:+ i 1)))
+ ((not (fix:< i end))
+ (primitive-u8-set! result i #x00))
+ (primitive-u8-set! result i (char->integer (string-ref string i))))
+ result)))
(define (x-window-set-name window name)
(guarantee-xwindow window 'x-window-set-name)
(define (x-graphics-reconfigure window width height)
(C-call "x_graphics_reconfigure" window width height))
-(define (->bytes string)
- (if (and (or (bytevector? string)
- (and (ustring? string)
- (fix:= 1 (ustring-cp-size string))))
- (let ((end (string-length string)))
- (every-loop (lambda (cp) (fix:< cp #x80))
- cp1-ref string 0 end)))
- string
- (string->iso8859-1 string)))
-
-(define-integrable (every-loop proc ref string start end)
- (let loop ((i start))
- (if (fix:< i end)
- (and (proc (ref string i))
- (loop (fix:+ i 1)))
- #t)))
-
(define (x-graphics-open-window display geometry suppress-map)
;; Open a window on DISPLAY using GEOMETRY. If GEOMETRY is false
;; map window interactively. If third argument SUPPRESS-MAP? is
(let ((window
(c-call "xterm_open_window" (make-alien '(struct |xwindow|))
display
- (string->utf8 geometry)
- (string->utf8 name)
- (string->utf8 class)
+ (->bytes geometry)
+ (->bytes name)
+ (->bytes class)
(if map? 1 0))))
(if (alien-null? window)
(error "Could not open xterm:" geometry))
(define (xterm-write-substring! xterm x y string start end highlight)
(guarantee-all-ascii string 'xterm-write-substring!)
(let ((code (c-call "xterm_write_substring"
- xterm x y (string->utf8 string) start end highlight)))
+ xterm x y (->bytes string) start end highlight)))
(case code
((1) (error:bad-range-argument x 'xterm-write-substring!))
((2) (error:bad-range-argument y 'xterm-write-substring!))
(parent (x11))
(export ()
x-close-all-displays)
- (import (runtime ustring)
- cp1-ref
- ustring-cp-size
- ustring?)
(export (x11)
+ ->bytes
x-visual-deallocate
x-close-display
x-window-set-input-hint