- 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

original commit: 87d4811781d7e9183f7710aa6a809b850a38454f

LOG

@@ -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

c/expeditor.c

@@ -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;
+  msg = S_strerror(errno);
-
-  if (msg != Sfalse)
   S_error1("expeditor", "error reading from console: ~a", msg);
-  else
-    S_error("expeditor", "error reading from console");
 
+  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) {
+static void s_ee_write_char(wchar_t wch) {
-  if ((unsigned)c > 255) c = '?';
+  locale_t old; char buf[MB_LEN_MAX]; size_t n;
-  putchar(c);
+
+  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) {

s/expeditor.ss

@@ -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))
+      (unless (or (char? key)
-                  (and (string? key) (fx> (string-length key) 0) (andmap ascii? (string->list key))))
+                  (and (string? key) (fx> (string-length key) 0)))
-        ($oops 'ee-bind-key "~s is not a valid key (ascii character or nonempty ascii string)" key))
+        ($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)
+              (define (^char c)
-                (fxlogand (char->integer c) #b11111))
+                (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))))
+              (s-lookup table (fx+ i 1) (^char (string-ref key i))))
-            (define (s-lookup table i code)
+            (define (s-lookup table i key)
-              (let ([x (vector-ref table code)])
+              (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)])
+          (begin
-            (when (dispatch-table? (vector-ref base-dispatch-table code))
+            (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))