From: Matt Birkholz Date: Fri, 24 Feb 2017 20:38:46 +0000 (-0700) Subject: x11: Use bytevectors instead of strings. X-Git-Tag: mit-scheme-pucked-9.2.12~220^2~2 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=b663b37843c19465696923419ddf18bdb851b63a;p=mit-scheme.git x11: Use bytevectors instead of strings. --- diff --git a/src/x11/x11-base.scm b/src/x11/x11-base.scm index ad13a12b1..884c1f0bd 100644 --- a/src/x11/x11-base.scm +++ b/src/x11/x11-base.scm @@ -51,21 +51,25 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))) @@ -85,7 +89,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 @@ -278,9 +282,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 @@ -413,9 +417,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -467,7 +472,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 @@ -477,7 +482,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 @@ -487,7 +492,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 @@ -497,7 +502,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 @@ -507,7 +512,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 @@ -522,7 +527,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -600,11 +605,12 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 @@ -704,7 +710,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -714,7 +721,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -736,7 +743,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))))) @@ -829,15 +836,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. 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) @@ -898,9 +899,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) diff --git a/src/x11/x11-graphics.scm b/src/x11/x11-graphics.scm index 7efce5f19..847f56e63 100644 --- a/src/x11/x11-graphics.scm +++ b/src/x11/x11-graphics.scm @@ -81,7 +81,11 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))) @@ -116,12 +120,12 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))) @@ -184,12 +188,11 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. 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) diff --git a/src/x11/x11-terminal.scm b/src/x11/x11-terminal.scm index a83e38b00..1cee3cb1e 100644 --- a/src/x11/x11-terminal.scm +++ b/src/x11/x11-terminal.scm @@ -74,7 +74,11 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))) @@ -105,9 +109,23 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ((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!)) @@ -148,24 +166,25 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ((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))))