(if (not (zero? (C-call "x_window_set_input_hint" window (if hint? 1 0))))
(error "XAllocWMHints failed.")))
+(define-integrable ->utf8 string->utf8)
+
(define (x-window-set-name window name)
(guarantee-xwindow window 'x-window-set-name)
- (if (not (zero? (C-call "x_window_set_name" window name)))
+ (if (not (zero? (C-call "x_window_set_name" window (->utf8 name))))
(error "XStringListToTextProperty failed.")))
(define (x-window-set-icon-name window name)
(guarantee-xwindow window 'x-window-set-icon-name)
- (if (not (zero? (C-call "x_window_set_icon_name" window name)))
+ (if (not (zero? (C-call "x_window_set_icon_name" window (->utf8 name))))
(error "XStringListToTextProperty failed.")))
;;; Open/Close
(define (x-open-display display-name)
(let ((alien (make-alien '(struct |xdisplay|))))
- (C-call "x_open_display" alien (if (eq? #f display-name) 0 display-name))
+ (C-call "x_open_display" alien (if (eq? #f display-name)
+ 0
+ (->utf8 display-name)))
(if (alien-null? alien)
(error "Could not open display:" display-name)
alien)))
(define (x-set-default-font display font-name)
(guarantee-xdisplay display 'x-set-default-font)
- (if (not (zero? (c-call "x_set_default_font" display font-name)))
+ (if (not (zero? (c-call "x_set_default_font" display (->utf8 font-name))))
(error "Could not load font:" font-name)))
;;; Event Processing
(char->integer #\backspace)))
(char->string #\Delete))
((> nbytes 0)
- (let ((s (make-legacy-string nbytes)))
- (c-peek-bytes buffer 0 nbytes s 0)
- s))
+ (let ((bv (make-bytevector nbytes)))
+ (c-peek-bytes buffer 0 nbytes bv 0)
+ (utf8->string bv)))
(else ""))
;; Create Scheme bucky bits (kept independent
;; of the character). X has already
(define (x-display-get-default display resource-name class-name)
(guarantee-xdisplay display 'x-display-get-default)
- (c-peek-cstring
- (C-call "x_display_get_default" (make-alien 'char)
- display resource-name class-name)))
+ (let ((alien (C-call "x_display_get_default" (make-alien 'char)
+ display (->utf8 resource-name) (->utf8 class-name))))
+ (and (not (alien-null? alien))
+ (utf8->string (c-peek-cstring alien)))))
(define (x-window-query-pointer window)
(guarantee-xwindow window 'x-window-query-pointer)
(define (x-window-set-foreground-color window color)
(guarantee-xwindow window 'x-window-set-foreground-color)
(cond ((string? color)
- (C-call "x_window_set_foreground_color_name" window color))
+ (C-call "x_window_set_foreground_color_name" window (->utf8 color)))
((integer? color)
(C-call "x_window_set_foreground_color_pixel" window color))
(else
(define (x-window-set-background-color window color)
(guarantee-xwindow window 'x-window-set-background-color)
(cond ((string? color)
- (C-call "x_window_set_background_color_name" window color))
+ (C-call "x_window_set_background_color_name" window (->utf8 color)))
((integer? color)
(C-call "x_window_set_background_color_pixel" window color))
(else
(define (x-window-set-border-color window color)
(guarantee-xwindow window 'x-window-set-border-color)
(cond ((string? color)
- (C-call "x_window_set_border_color_name" window color))
+ (C-call "x_window_set_border_color_name" window (->utf8 color)))
((integer? color)
(C-call "x_window_set_border_color_pixel" window color))
(else
(define (x-window-set-cursor-color window color)
(guarantee-xwindow window 'x-window-set-cursor-color)
(cond ((string? color)
- (C-call "x_window_set_cursor_color_name" window color))
+ (C-call "x_window_set_cursor_color_name" window (->utf8 color)))
((integer? color)
(C-call "x_window_set_cursor_color_pixel" window color))
(else
(define (x-window-set-mouse-color window color)
(guarantee-xwindow window 'x-window-set-mouse-color)
(cond ((string? color)
- (C-call "x_window_set_mouse_color_name" window color))
+ (C-call "x_window_set_mouse_color_name" window (->utf8 color)))
((integer? color)
(C-call "x_window_set_mouse_color_pixel" window color))
(else
(define (x-window-set-font window font)
(guarantee-xwindow window 'x-window-set-font)
(guarantee string? font 'x-window-set-font)
- (not (zero? (C-call "x_window_set_font" window (string->utf8 font)))))
+ (not (zero? (C-call "x_window_set_font" window (->utf8 font)))))
(define (x-window-set-border-width window width)
(guarantee-xwindow window 'x-window-set-border-width)
(guarantee-xdisplay display 'x-font-structure)
(let ((font-struct (make-alien '(struct |XFontStruct|))))
(cond ((string? name/id)
- (add-alien-cleanup!
- font-struct
- (named-lambda (font-struct-init-by-name! copy)
- (C-call "x_font_structure_by_name" copy display name/id))
- font-struct-cleanup!))
+ (let ((name (->utf8 name/id)))
+ (add-alien-cleanup!
+ font-struct
+ (named-lambda (font-struct-init-by-name! copy)
+ (C-call "x_font_structure_by_name" copy display name))
+ font-struct-cleanup!)))
((integer? name/id)
(add-alien-cleanup!
font-struct
(let loop ((i 0))
(if (< i actual-count)
(begin
- (vector-set! result i (c-peek-cstringp! scan 0))
+ (vector-set! result i (utf8->string
+ (c-peek-cstringp! scan 0)))
(loop (1+ i)))))
(cleanup-alien! names)
(free actual-count-return)
(define (x-intern-atom display name soft?)
(guarantee-xdisplay display 'x-intern-atom)
- (c-call "x_intern_atom" display name (if soft? 1 0)))
+ (c-call "x_intern_atom" display (->utf8 name) (if soft? 1 0)))
(define (x-get-atom-name display atom)
(add-alien-cleanup! name-return cleanup-name-return! init-name-return!)
(let ((code (c-call "x_get_atom_name" display atom name-return)))
(if (zero? code)
- (let ((name (c-peek-cstringp name-return)))
+ (let ((name (utf8->string (c-peek-cstringp name-return))))
(cleanup-alien! name-return)
name)
(error "XGetAtomName failed:" code)))))
result))
(define (char-ptr-to-prop-data-8 data length)
- (let ((scan (copy-alien data))
- (result (make-legacy-string length)))
- (let loop ((index 0))
- (if (< index length)
- (begin
- (string-set! result index (integer->char (c-> scan "uchar")))
- (alien-byte-increment! scan (c-sizeof "uchar"))
- (loop (1+ index)))))
- result))
+ (let ((bytevector (make-bytevector length)))
+ (c-peek-bytes data 0 length bytevector 0)
+ (utf8->string bytevector)))
(define (x-change-property display window property type format mode data)
(guarantee-xdisplay display 'x-change-property)
(cons bytes length)))
(define (prop-data-8->bytes.length string)
- (let* ((length (string-length string))
+ (let* ((bytevector (->utf8 string))
+ (length (bytevector-length bytevector))
(bytes (malloc length 'uchar)))
- (c-poke-bytes bytes 0 length string 0)
+ (c-poke-bytes bytes 0 length bytevector 0)
(cons bytes length)))
(define (x-delete-property display window property)
(values #f #f #f)))
(let ((window
(c-call "x_graphics_open_window" (make-alien '(struct |xwindow|))
- display geometry name class (if map? 1 0))))
+ display
+ (string->utf8 geometry)
+ (string->utf8 name)
+ (string->utf8 class)
+ (if map? 1 0))))
(if (alien-null? window)
(error "Could not open window:" geometry))
window)))
(define (x-graphics-draw-string window x y string)
;; Draw characters in the current font at the given coordinates, with
;; transparent background.
- (C-call "x_graphics_draw_string" window x y string))
+ (C-call "x_graphics_draw_string" window x y (string->utf8 string)))
(define (x-graphics-draw-image-string window x y string)
;; Draw characters in the current font at the given coordinates, with
;; solid background.
- (C-call "x_graphics_draw_image_string" window x y string))
+ (C-call "x_graphics_draw_image_string" window x y (string->utf8 string)))
(define (x-graphics-set-function window function)
(if (not (zero? (C-call "x_graphics_set_function" window function)))
result)))
(define (x-bytes-into-image vector image)
- ;; VECTOR is a vector or vector-8b of pixel values stored in row-major
- ;; order; it must have the same number of pixels as IMAGE.
- ;; These pixels are written onto IMAGE by repeated calls to XPutPixel.
- ;; This procedure is equivalent to calling X-SET-PIXEL-IN-IMAGE for each
- ;; pixel in VECTOR.
- (guarantee string? vector 'x-bytes-into-image)
+ ;; VECTOR is a bytevector of pixel values stored in row-major order; it must
+ ;; have the same number of pixels as IMAGE. These pixels are written onto
+ ;; IMAGE by repeated calls to XPutPixel. This procedure is equivalent to
+ ;; calling X-SET-PIXEL-IN-IMAGE for each pixel in VECTOR.
+ (guarantee bytevector? vector 'x-bytes-into-image)
(C-call "x_bytes_into_image" vector image))
(define (x-get-pixel-from-image image x y)
(values 0 0 #f)))
(let ((window
(c-call "xterm_open_window" (make-alien '(struct |xwindow|))
- display geometry name class (if map? 1 0))))
+ display
+ (string->utf8 geometry)
+ (string->utf8 name)
+ (string->utf8 class)
+ (if map? 1 0))))
(if (alien-null? window)
(error "Could not open xterm:" geometry))
window)))
((2) (error:bad-range-argument y 'xterm-write-char!))
((3) (error:bad-range-argument highlight 'xterm-write-char!)))))
+(define (all-ascii? string)
+ (let ((len (string-length string)))
+ (let loop ((i 0))
+ (if (fix:< i len)
+ (and (char-ascii? (string-ref string i))
+ (loop (fix:+ i 1)))
+ #t))))
+
+(define (guarantee-all-ascii string operator)
+ (if (not (all-ascii? string))
+ (error:wrong-type-argument string "an ASCII string" operator))
+ string)
+
(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 start end highlight)))
+ xterm x y (string->utf8 string) start end highlight)))
(case code
((1) (error:bad-range-argument x 'xterm-write-substring!))
((2) (error:bad-range-argument y 'xterm-write-substring!))
((5) (error:bad-range-argument lines 'xterm-scroll-lines-down)))))
(define (xterm-save-contents xterm x-start x-end y-start y-end)
- ;; Get the contents of the terminal screen rectangle as a string.
- ;; The string contains alternating (CHARACTER, HIGHLIGHT) pairs.
+ ;; Get the contents of the terminal screen rectangle as a bytevector.
+ ;; The bytevector contains alternating (CHARACTER, HIGHLIGHT) pairs.
;; The pairs are organized in row-major order from (X-START, Y-START).
- (let* ((string (make-legacy-string (* 2
- (- x-end x-start)
- (- y-end y-start))))
+ (let* ((bytevector (make-bytevector (* 2
+ (- x-end x-start)
+ (- y-end y-start))))
(code (c-call "xterm_save_contents"
- xterm x-start x-end y-start y-end string)))
+ xterm x-start x-end y-start y-end bytevector)))
(case code
((1) (error:bad-range-argument x-end 'xterm-save-contents))
((2) (error:bad-range-argument y-end 'xterm-save-contents))
((3) (error:bad-range-argument x-start 'xterm-save-contents))
- ((4) (error:bad-range-argument y-start 'xterm-save-contents)))))
+ ((4) (error:bad-range-argument y-start 'xterm-save-contents)))
+ bytevector))
(define (xterm-restore-contents xterm x-start x-end y-start y-end contents)
;; Replace the terminal screen rectangle with CONTENTS.
;; See `XTERM-SCREEN-CONTENTS' for the format of CONTENTS.
- (if (not (= (string-length string)
+ (if (not (= (bytevector-length contents)
(* 2
(- x-end x-start)
(- y-end y-start))))
projects / mit-scheme.git / commitdiff