From 76a4cfa95253cccafc6f85e14f400f894884571e Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Sat, 26 Apr 2014 13:39:26 +0900
Subject: [PATCH] Fixing 4 byte utf8 read-char. Fixing resized strings in
 custom ports.

---
 eval.c               |  2 +-
 sexp.c               | 13 +++++++++----
 tests/r7rs-tests.scm | 22 ++++++++++++++--------
 3 files changed, 24 insertions(+), 13 deletions(-)

diff --git a/eval.c b/eval.c
index 55cb7af9..fe4faf29 100644
--- a/eval.c
+++ b/eval.c
@@ -1755,7 +1755,7 @@ sexp sexp_read_utf8_char (sexp ctx, sexp port, int i) {
       i = ((i&0x1F)<<12) + ((sexp_read_char(ctx, port)&0x3F)<<6);
       i += sexp_read_char(ctx, port)&0x3F;
     } else {
-      i = ((i&0x0F)<<16) + ((sexp_read_char(ctx, port)&0x3F)<<12);
+      i = ((i&0x0F)<<18) + ((sexp_read_char(ctx, port)&0x3F)<<12);
       i += (sexp_read_char(ctx, port)&0x3F)<<6;
       i += sexp_read_char(ctx, port)&0x3F;
     }
diff --git a/sexp.c b/sexp.c
index eb02ad22..88337d13 100644
--- a/sexp.c
+++ b/sexp.c
@@ -1418,7 +1418,7 @@ sexp sexp_open_output_file_descriptor (sexp ctx, sexp self, sexp_sint_t n, sexp
 #else  /* ! SEXP_USE_STRING_STREAMS */
 
 int sexp_buffered_read_char (sexp ctx, sexp p) {
-  sexp_gc_var1(tmp);
+  sexp_gc_var2(tmp, origbytes);
   int res = 0;
   if (sexp_port_offset(p) < sexp_port_size(p)) {
     return ((unsigned char*)sexp_port_buf(p))[sexp_port_offset(p)++];
@@ -1439,20 +1439,25 @@ int sexp_buffered_read_char (sexp ctx, sexp p) {
              ? ((unsigned char*)sexp_port_buf(p))[sexp_port_offset(p)++] : EOF);
     }
   } else if (sexp_port_customp(p)) {
-    sexp_gc_preserve1(ctx, tmp);
+    sexp_gc_preserve2(ctx, tmp, origbytes);
     tmp = sexp_list2(ctx, SEXP_ZERO, sexp_make_fixnum(SEXP_PORT_BUFFER_SIZE));
-    tmp = sexp_cons(ctx, sexp_port_binaryp(p) ? sexp_string_bytes(sexp_port_buffer(p)) : sexp_port_buffer(p), tmp);
+    origbytes = sexp_port_binaryp(p) ? sexp_string_bytes(sexp_port_buffer(p)) : sexp_port_buffer(p);
+    tmp = sexp_cons(ctx, origbytes, tmp);
     tmp = sexp_apply(ctx, sexp_port_reader(p), tmp);
     if (sexp_fixnump(tmp) && sexp_unbox_fixnum(tmp) > 0) {
       sexp_port_offset(p) = 0;
       sexp_port_size(p) = sexp_unbox_fixnum(tmp);
+      if (!sexp_port_binaryp(p) && origbytes != sexp_string_bytes(sexp_port_buffer(p))) {
+        /* handle resize */
+        memcpy(sexp_port_buf(p), sexp_bytes_data(sexp_string_bytes(sexp_port_buffer(p))), sexp_port_size(p));
+      }
       res = ((sexp_port_offset(p) < sexp_port_size(p))
              ? ((unsigned char*)sexp_port_buf(p))[sexp_port_offset(p)++] : EOF);
     } else {
       res = EOF;
       sexp_port_size(p) = 0;
     }
-    sexp_gc_release1(ctx);
+    sexp_gc_release2(ctx);
   } else {
     res = EOF;
   }
diff --git a/tests/r7rs-tests.scm b/tests/r7rs-tests.scm
index 184e25d2..3cb73c65 100644
--- a/tests/r7rs-tests.scm
+++ b/tests/r7rs-tests.scm
@@ -1101,6 +1101,11 @@
 
 (test "a-c" (let ((str (string #\a #\b #\c))) (string-set! str 1 #\-) str))
 
+(test (string #\a #\x1F700 #\c)
+    (let ((s (string #\a #\b #\c)))
+      (string-set! s 1 #\x1F700)
+      s))
+
 (test #t (string=? "" ""))
 (test #t (string=? "abc" "abc" "abc"))
 (test #f (string=? "" "abc"))
@@ -1763,17 +1768,18 @@
 (test "abc" (read-string 3 (open-input-string "abcd")))
 (test "abc" (read-string 3 (open-input-string "abc\ndef\n")))
 
-(let* ((s (string #\x1F700 #\x1F701 #\x1F702))
-       (in (open-input-string s)))
-  (test #\x1F700 (string-ref s 0))
-  (test #\x1F701 (string-ref s 1))
-  (test #\x1F702 (string-ref s 2))
+(let ((in (open-input-string (string #\x10F700 #\x10F701 #\x10F702))))
   (let* ((c1 (read-char in))
          (c2 (read-char in))
          (c3 (read-char in)))
-    (test #\x1F700 c1)
-    (test #\x1F701 c2)
-    (test #\x1F702 c3)))
+    (test #\x10F700 c1)
+    (test #\x10F701 c2)
+    (test #\x10F702 c3)))
+
+(test (string #\x10F700)
+    (let ((out (open-output-string)))
+      (write-char #\x10F700 out)
+      (get-output-string out)))
 
 (test "abc"
     (let ((out (open-output-string)))