From 7ef8efd117032bf7aa1716b70c810161668b7c1e Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Mon, 28 Aug 2017 11:33:32 -0700 Subject: [PATCH] x11: null terminate strings; punt unused optimization. --- src/x11/x11-base.scm | 24 ++++++++++-------------- src/x11/x11-graphics.scm | 17 ----------------- src/x11/x11-terminal.scm | 8 ++++---- src/x11/x11.pkg | 5 +---- 4 files changed, 15 insertions(+), 39 deletions(-) diff --git a/src/x11/x11-base.scm b/src/x11/x11-base.scm index ed50a8b5a..496d2b109 100644 --- a/src/x11/x11-base.scm +++ b/src/x11/x11-base.scm @@ -51,22 +51,18 @@ 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 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) diff --git a/src/x11/x11-graphics.scm b/src/x11/x11-graphics.scm index f160f5542..d2753b089 100644 --- a/src/x11/x11-graphics.scm +++ b/src/x11/x11-graphics.scm @@ -58,23 +58,6 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 diff --git a/src/x11/x11-terminal.scm b/src/x11/x11-terminal.scm index 1cee3cb1e..fdf6925e9 100644 --- a/src/x11/x11-terminal.scm +++ b/src/x11/x11-terminal.scm @@ -75,9 +75,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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)) @@ -125,7 +125,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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!)) diff --git a/src/x11/x11.pkg b/src/x11/x11.pkg index f9e0137d8..ceb8d09ab 100644 --- a/src/x11/x11.pkg +++ b/src/x11/x11.pkg @@ -35,11 +35,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 -- 2.25.1