From: Matt Birkholz Date: Tue, 23 May 2017 23:44:55 +0000 (-0700) Subject: x11 plugin: Convert to iso8859-1 rather than utf8. X-Git-Tag: mit-scheme-pucked-9.2.12~14^2~41 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=71a92c65cbf0e7e126a229f1a829912612a60774;p=mit-scheme.git x11 plugin: Convert to iso8859-1 rather than utf8. And avoid converting if the string is already ASCII. Also fix the subsystem version number, and update README, NEWS, etc. following the examples of the other plugins. --- diff --git a/src/x11/AUTHORS b/src/x11/AUTHORS index 2af146e02..9adb7e807 100644 --- a/src/x11/AUTHORS +++ b/src/x11/AUTHORS @@ -2,6 +2,6 @@ To find out what should go in this file, see "Information For Maintainers of GNU Software" (maintain.texi), the section called "Recording Changes". -Matt Birkholz The conversion to a separate package. +Matt Birkholz The conversion to a plugin. The MIT/GNU Scheme Team The original prx11 microcode module and runtime/x11graph.scm. diff --git a/src/x11/Makefile.am b/src/x11/Makefile.am index 12e793b11..18a63f058 100644 --- a/src/x11/Makefile.am +++ b/src/x11/Makefile.am @@ -45,8 +45,9 @@ scmlib_sub_DATA += make.scm @MIT_SCHEME_PKD@ #AM_MAKEINFOHTMLFLAGS = --no-split AM_CPPFLAGS = -I@MIT_SCHEME_INCLUDEDIR@ -AM_CFLAGS = @MIT_CFLAGS@ -AM_CFLAGS += `pkg-config --cflags x11` +AM_CFLAGS = `pkg-config --cflags x11` +AM_CFLAGS += @MIT_CFLAGS@ + LIBS = `pkg-config --libs x11` x11_shim_la_LIBADD = x11base.lo x11color.lo x11graph.lo x11term.lo diff --git a/src/x11/NEWS b/src/x11/NEWS index d3f47f308..a0dec5c33 100644 --- a/src/x11/NEWS +++ b/src/x11/NEWS @@ -5,24 +5,33 @@ Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017 Massachusetts Institute of Technology -This file is part of an x11 plugin for MIT/GNU Scheme. +This file is part of MIT/GNU Scheme. -This plugin is free software; you can redistribute it and/or modify it -under the terms of the GNU General Public License as published by the -Free Software Foundation; either version 2 of the License, or (at your -option) any later version. +MIT/GNU Scheme is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. -This plugin is distributed in the hope that it will be useful, but -WITHOUT ANY WARRANTY; without even the implied warranty of +MIT/GNU Scheme is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License -along with this plugin; if not, write to the Free Software Foundation, -Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. +along with MIT/GNU Scheme; if not, write to the Free Software +Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA +02110-1301, USA. -mit-scheme-x11 3.116 - Matt Birkholz, 2016-02-19 -================================================ +mit-scheme-x11 0.2 - Matt Birkholz, 2017-05-23 +============================================== -* Convert to plugin, moving X11 data parsing (x_event_to_object) to - Scheme/FFI code, using libtool and automake... +Use new Unicode support. Convert (restrict) strings (atom names and +xterm content) to iso8859-1. This should be transparent if you were +using standard Latin1 property names and writing only Latin1 graphical +characters to your xterms. + +mit-scheme-x11 0.1 - Matt Birkholz, 2016-02-19 +============================================== + +Converted to a libtool plugin. Moved X11 data parsing +(x_event_to_object) to Scheme/FFI code. diff --git a/src/x11/README b/src/x11/README index 5c9a8b430..e58025ab8 100644 --- a/src/x11/README +++ b/src/x11/README @@ -1,19 +1,26 @@ The X11 option. -This is a drop-in replacement for the x11 microcode module and -runtime/x11graph.scm. It is not part of the core build and can be -built outside the core build tree in the customary way: +This plugin creates an (x11) package, a drop-in replacement for the +microcode module based (runtime x-graphics) package. It is built in +the customary GNU way: ./configure ... make all check install -The install target copies a shared library shim and compiled Scheme -files into the system library path, and re-writes the optiondb.scm -found there. You can override the default command name "mit-scheme" -(and thus the system library path) by setting MIT_SCHEME_EXE. +To load: -To use: (load-option 'X11) and import the bindings you want. They are -not exported to the global environment because they would conflict -with the exports from (runtime x-graphics). Once this option is -loaded, make-graphics-device will create X11 graphics devices rather -than X graphics devices. + (load-option 'x11) + +Loading this plugin re-assigns the bindings in (runtime x-graphics). +Any existing X graphics devices will stop working, and make-graphics- +device will begin creating X11 graphics devices instead. + +To import into a CREF package set, add this to your .pkg file: + + (global-definitions x11/) + + (define-package (your package name) + (parent (your package parent)) + (import (x11) + xterm-open-window + ...)) diff --git a/src/x11/make.scm b/src/x11/make.scm index dacdbe01f..e565d66d3 100644 --- a/src/x11/make.scm +++ b/src/x11/make.scm @@ -5,7 +5,7 @@ Load the X11 option. |# (with-loader-base-uri (system-library-uri "x11/") (lambda () (load-package-set "x11"))) -(add-subsystem-identification! "X11" '(0 1)) +(add-subsystem-identification! "X11" '(0 2)) ;; Until the microcode module based X Graphics system is removed, ;; reassign the define-primitives bindings in (runtime x-graphics) to diff --git a/src/x11/x11-base.scm b/src/x11/x11-base.scm index c7af38ed3..ed50a8b5a 100644 --- a/src/x11/x11-base.scm +++ b/src/x11/x11-base.scm @@ -51,16 +51,31 @@ 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 (->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-window-set-name window name) (guarantee-xwindow window 'x-window-set-name) - (if (not (zero? (C-call "x_window_set_name" window (->utf8 name)))) + (if (not (zero? (C-call "x_window_set_name" window (->bytes 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 (->utf8 name)))) + (if (not (zero? (C-call "x_window_set_icon_name" window (->bytes name)))) (error "XStringListToTextProperty failed."))) ;;; Open/Close @@ -69,7 +84,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (let ((alien (make-alien '(struct |xdisplay|)))) (C-call "x_open_display" alien (if (eq? #f display-name) 0 - (->utf8 display-name))) + (->bytes display-name))) (if (alien-null? alien) (error "Could not open display:" display-name) alien))) @@ -89,7 +104,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 (->utf8 font-name)))) + (if (not (zero? (c-call "x_set_default_font" display (->bytes font-name)))) (error "Could not load font:" font-name))) ;;; Event Processing @@ -284,7 +299,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ((> nbytes 0) (let ((bv (make-bytevector nbytes))) (c-peek-bytes buffer 0 nbytes bv 0) - (utf8->string bv))) + (iso8859-1->string bv))) (else "")) ;; Create Scheme bucky bits (kept independent ;; of the character). X has already @@ -418,9 +433,9 @@ 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) (let ((alien (C-call "x_display_get_default" (make-alien 'char) - display (->utf8 resource-name) (->utf8 class-name)))) + display (->bytes resource-name) (->bytes class-name)))) (and (not (alien-null? alien)) - (utf8->string (c-peek-cstring alien))))) + (c-peek-cstring alien)))) (define (x-window-query-pointer window) (guarantee-xwindow window 'x-window-query-pointer) @@ -472,7 +487,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 (->utf8 color))) + (C-call "x_window_set_foreground_color_name" window (->bytes color))) ((integer? color) (C-call "x_window_set_foreground_color_pixel" window color)) (else @@ -482,7 +497,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 (->utf8 color))) + (C-call "x_window_set_background_color_name" window (->bytes color))) ((integer? color) (C-call "x_window_set_background_color_pixel" window color)) (else @@ -492,7 +507,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 (->utf8 color))) + (C-call "x_window_set_border_color_name" window (->bytes color))) ((integer? color) (C-call "x_window_set_border_color_pixel" window color)) (else @@ -502,7 +517,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 (->utf8 color))) + (C-call "x_window_set_cursor_color_name" window (->bytes color))) ((integer? color) (C-call "x_window_set_cursor_color_pixel" window color)) (else @@ -512,7 +527,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 (->utf8 color))) + (C-call "x_window_set_mouse_color_name" window (->bytes color))) ((integer? color) (C-call "x_window_set_mouse_color_pixel" window color)) (else @@ -527,7 +542,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 (->utf8 font))))) + (not (zero? (C-call "x_window_set_font" window (->bytes font))))) (define (x-window-set-border-width window width) (guarantee-xwindow window 'x-window-set-border-width) @@ -605,7 +620,7 @@ 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) - (let ((name (->utf8 name/id))) + (let ((name (->bytes name/id))) (add-alien-cleanup! font-struct (named-lambda (font-struct-init-by-name! copy) @@ -710,8 +725,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (let loop ((i 0)) (if (< i actual-count) (begin - (vector-set! result i (utf8->string - (c-peek-cstringp! scan 0))) + (vector-set! result i (c-peek-cstringp! scan 0)) (loop (1+ i))))) (cleanup-alien! names) (free actual-count-return) @@ -721,7 +735,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 (->utf8 name) (if soft? 1 0))) + (c-call "x_intern_atom" display (->bytes name) (if soft? 1 0))) (define (x-get-atom-name display atom) @@ -743,7 +757,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 (utf8->string (c-peek-cstringp name-return)))) + (let ((name (c-peek-cstringp name-return))) (cleanup-alien! name-return) name) (error "XGetAtomName failed:" code))))) @@ -836,9 +850,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. result)) (define (char-ptr-to-prop-data-8 data length) - (let ((bytevector (make-bytevector length))) - (c-peek-bytes data 0 length bytevector 0) - (utf8->string bytevector))) + (let ((string ((ucode-primitive string-allocate 1) length))) + (if (> length 0) + (c-peek-bytes data 0 length string 0)) + string)) (define (x-change-property display window property type format mode data) (guarantee-xdisplay display 'x-change-property) @@ -899,7 +914,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (cons bytes length))) (define (prop-data-8->bytes.length string) - (let* ((bytevector (->utf8 string)) + (let* ((bytevector (->bytes string)) (length (bytevector-length bytevector)) (bytes (malloc length 'uchar))) (c-poke-bytes bytes 0 length bytevector 0) diff --git a/src/x11/x11-graphics.scm b/src/x11/x11-graphics.scm index 847f56e63..f160f5542 100644 --- a/src/x11/x11-graphics.scm +++ b/src/x11/x11-graphics.scm @@ -58,6 +58,23 @@ 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 @@ -82,9 +99,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (let ((window (c-call "x_graphics_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 window:" geometry)) @@ -120,12 +137,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->utf8 string))) + (C-call "x_graphics_draw_string" window x y (->bytes 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->utf8 string))) + (C-call "x_graphics_draw_image_string" window x y (->bytes string))) (define (x-graphics-set-function window function) (if (not (zero? (C-call "x_graphics_set_function" window function))) diff --git a/src/x11/x11.pkg b/src/x11/x11.pkg index 5a30f7d53..071ba2e4c 100644 --- a/src/x11/x11.pkg +++ b/src/x11/x11.pkg @@ -33,6 +33,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-package (x11 base) (files "x11-base") (parent (x11)) + (import (runtime ustring) + cp1-ref + ustring-cp-size + ustring?) (export (x11) x-visual-deallocate x-close-display @@ -137,6 +141,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-package (x11 graphics) (files "x11-graphics") (parent (x11)) + (import (runtime ustring) + cp1-ref + ustring-cp-size + ustring?) (export (x11) x-graphics-set-vdc-extent x-graphics-vdc-extent