suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

- add unicode support to the expression editor. entry and display now work

Browse Source 
except that combining characters are not treated correctly for
  line-wrapping.  this addresses github issue #32 and part of issue #81.
    c/expeditor.c, s/expeditor.ss

original commit: 87d4811781d7e9183f7710aa6a809b850a38454f
This commit is contained in:
Jason Felice 2016-07-12 17:02:03 -04:00
parent f16869bb35
commit 14aadeab83
3 changed files with 62 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
LOG
View File

@ -256,3 +256,7 @@
- fixed three instances of unchecked mallocs reported by laqrix in
github issue #77.
io.c, schlib.c, thread.c
- add unicode support to the expression editor. entry and display now work
except that combining characters are not treated correctly for
line-wrapping. this addresses github issue #32 and part of issue #81.
c/expeditor.c, s/expeditor.ss

49
c/expeditor.c
View File

@ -539,6 +539,9 @@ static ptr s_ee_get_clipboard(void) {
#include <time.h>
#include <fcntl.h>
#include <sys/ioctl.h>
#include <wchar.h>
#include <locale.h>
#include <xlocale.h>
#if defined(TIOCGWINSZ) && defined(SIGWINCH) && defined(EINTR)
#define HANDLE_SIGWINCH
@ -561,6 +564,9 @@ static void handle_sigwinch(UNUSED int sig) {
#define STDOUT_FD 1
static IBOOL disable_auto_margin = 0, avoid_last_column = 0;
static locale_t term_locale;
static mbstate_t term_in_mbs;
static mbstate_t term_out_mbs;
static IBOOL s_ee_init_term(void) {
int errret;
@ -613,6 +619,10 @@ static IBOOL s_ee_init_term(void) {
sigaction(SIGWINCH, &act, (struct sigaction *)0);
#endif
term_locale = newlocale(LC_ALL_MASK, "", NULL);
memset(&term_out_mbs, 0, sizeof(term_out_mbs));
memset(&term_in_mbs, 0, sizeof(term_in_mbs));
init_status = 1;
} else {
init_status = 0;
@ -624,7 +634,8 @@ static IBOOL s_ee_init_term(void) {
/* returns char, eof, #t (winched), or #f (nothing ready), the latter
only if blockp is false */
static ptr s_ee_read_char(IBOOL blockp) {
ptr msg; int fd = STDIN_FD; int n; char buf[1];
ptr msg; int fd = STDIN_FD; int n; char buf[1]; wchar_t wch; size_t sz;
locale_t old_locale;
#ifdef PTHREADS
ptr tc = get_thread_context();
#endif
@ -657,18 +668,24 @@ static ptr s_ee_read_char(IBOOL blockp) {
n = READ(fd, buf, 1);
}
#endif /* PTHREADS */
} while (n < 0 && errno == EINTR);
if (n == 1) return Schar(buf[0]);
if (n == 1) {
old_locale = uselocale(term_locale);
sz = mbrtowc(&wch, buf, 1, &term_out_mbs);
uselocale(old_locale);
if (sz == 1) {
return Schar(wch);
}
}
} while ((n < 0 && errno == EINTR) || (n == 1 && sz == (size_t)-2));
if (n == 0) return Seof_object;
msg = n < 0 ? S_strerror(errno) : Sfalse;
if (msg != Sfalse)
S_error1("expeditor", "error reading from console: ~a", msg);
else
S_error("expeditor", "error reading from console");
msg = S_strerror(errno);
S_error1("expeditor", "error reading from console: ~a", msg);
memset(&term_out_mbs, 0, sizeof(term_out_mbs));
return Svoid;
}
@ -997,9 +1014,17 @@ static ptr s_ee_get_clipboard(void) {
#endif /* WIN32 */
static void s_ee_write_char(INT c) {
if ((unsigned)c > 255) c = '?';
putchar(c);
static void s_ee_write_char(wchar_t wch) {
locale_t old; char buf[MB_LEN_MAX]; size_t n;
old = uselocale(term_locale);
n = wcrtomb(buf, wch, &term_in_mbs);
if (n == (size_t)-1) {
putchar('?');
} else {
fwrite(buf, 1, n, stdout);
}
uselocale(old);
}
static void s_ee_flush(void) {

45
s/expeditor.ss
View File

@ -111,9 +111,6 @@
[(x ...) (p x ... e)]
[(x ... y) b1 b2 ...]))]))
; expression editor presently handles only ascii key bindings
(define (ascii? c) ($fxu< (char->integer c) 256))
; screen initialization and manipulation routines
(module (init-screen raw-mode no-raw-mode
@ -137,7 +134,7 @@
(define init-term (foreign-procedure "(cs)ee_init_term" () boolean))
(define $ee-read-char (foreign-procedure "(cs)ee_read_char" (boolean) scheme-object))
(define $ee-write-char (foreign-procedure "(cs)ee_write_char" (int) void))
(define $ee-write-char (foreign-procedure "(cs)ee_write_char" (wchar_t) void))
(define ee-flush (foreign-procedure "(cs)ee_flush" () void))
(define get-screen-size (foreign-procedure "(cs)ee_get_screen_size" () scheme-object))
(define raw-mode (foreign-procedure "(cs)ee_raw" () void))
@ -226,9 +223,9 @@
(if (fx= cursor-col cols)
(begin
(exit-am-mode)
($ee-write-char (char->integer c))
($ee-write-char c)
(enter-am-mode))
($ee-write-char (char->integer c))))
($ee-write-char c)))
; comments regarding ee-write-char above apply also to ee-display-string
(define (ee-display-string s)
@ -1915,7 +1912,7 @@
(let ([c (ee-read-char)])
(let ([x (if (eof-object? c)
(lambda (ee entry c) #f)
(and (ascii? c) (vector-ref table (char->integer c))))])
(hashtable-ref table c ee-insert-self))])
(cond
[(procedure? x)
(let ([n (eestate-repeat-count ee)])
@ -2852,15 +2849,15 @@
(module (dispatch-table? base-dispatch-table ee-bind-key)
(define make-dispatch-table
(lambda ()
(make-vector 256 #f)))
(make-eqv-hashtable 256)))
(define dispatch-table? vector?)
(define dispatch-table? hashtable?)
(define ee-bind-key
(lambda (key proc)
(unless (or (and (char? key) (ascii? key))
(and (string? key) (fx> (string-length key) 0) (andmap ascii? (string->list key))))
($oops 'ee-bind-key "~s is not a valid key (ascii character or nonempty ascii string)" key))
(unless (or (char? key)
(and (string? key) (fx> (string-length key) 0)))
($oops 'ee-bind-key "~s is not a valid key (character or nonempty string)" key))
(unless (procedure? proc)
($oops 'ee-bind-key "~s is not a procedure" proc))
@ -2871,7 +2868,7 @@
(case c
[(#\\) (s-backslash table (fx+ i 1))]
[(#\^) (s-caret table (fx+ i 1))]
[else (s-lookup table (fx+ i 1) (char->integer c))])))
[else (s-lookup table (fx+ i 1) c)])))
(define (s-backslash table i)
(when (fx= i n)
($oops 'ee-bind-key
@ -2879,28 +2876,28 @@
key))
(let ([c (string-ref key i)])
(case c
[(#\e) (s-lookup table (fx+ i 1) 27)]
[(#\e) (s-lookup table (fx+ i 1) #\esc)]
[(#\\ #\^) (s-lookup table (fx+ i 1) c)]
[else ($oops 'ee-bind-key
"malformed key ~s (unexpected character following \\)"
key)])))
(define (s-caret table i)
(define (^char->integer c)
(fxlogand (char->integer c) #b11111))
(define (^char c)
(integer->char (fxlogand (char->integer c) #b11111)))
(when (fx= i n)
($oops 'ee-bind-key
"malformed key ~s (nothing following ^)"
key))
(s-lookup table (fx+ i 1) (^char->integer (string-ref key i))))
(define (s-lookup table i code)
(let ([x (vector-ref table code)])
(s-lookup table (fx+ i 1) (^char (string-ref key i))))
(define (s-lookup table i key)
(let ([x (hashtable-ref table key #f)])
(cond
[(fx= i n)
(when (dispatch-table? x)
(warningf 'ee-bind-key
"definition for key ~s disables its use as a prefix"
key))
(vector-set! table code proc)]
(hashtable-set! table key proc)]
[(dispatch-table? x) (s0 x i)]
[else
(when (procedure? x)
@ -2908,15 +2905,15 @@
"definition for key ~s disables its use as a prefix"
key))
(let ([x (make-dispatch-table)])
(vector-set! table code x)
(hashtable-set! table key x)
(s0 x i))])))
(s0 base-dispatch-table 0))
(let ([code (char->integer key)])
(when (dispatch-table? (vector-ref base-dispatch-table code))
(begin
(when (dispatch-table? (hashtable-ref base-dispatch-table key #f))
(warningf 'ee-bind-key
"definition for key ~s disables its use as a prefix"
key))
(vector-set! base-dispatch-table code proc)))))
(hashtable-set! base-dispatch-table key proc)))))
(define base-dispatch-table (make-dispatch-table))