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.
#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
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.
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
+ ...))
(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
(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
(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)))
(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
((> 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
(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)
(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
(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
(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
(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
(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
(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)
(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)
(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)
(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)
(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)))))
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)
(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)
(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 "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))
(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)))
(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
(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
projects / mit-scheme.git / commitdiff