1 files changed, 46 insertions, 3 deletions

diff --git a/libguile/strings.c b/libguile/strings.c
index 29509dcbb..e6865a730 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -38,6 +38,7 @@
 #include "libguile/eq.h"
 #include "libguile/fluids.h"
 
+#include "striconveh.h"
 
 
 
@@ -242,6 +243,36 @@ widen_stringbuf (SCM buf)
     }
 }
 
+/* Convert a stringbuf of 32-bit UCS-4-encoded characters to one
+   containing 8-bit Latin-1-encoded characters, if possible.  */
+static void
+narrow_stringbuf (SCM buf)
+{
+  size_t i, len;
+  scm_t_wchar *wmem;
+  char *mem;
+
+  if (!STRINGBUF_WIDE (buf))
+    return;
+
+  len = STRINGBUF_OUTLINE_LENGTH (buf);
+  i = 0;
+  wmem = STRINGBUF_WIDE_CHARS (buf);
+  while (i < len)
+    if (wmem[i++] > 0xFF)
+      return;
+
+  mem = scm_gc_malloc (sizeof (char) * (len + 1), "string");
+  for (i = 0; i < len; i++)
+    mem[i] = (unsigned char) wmem[i];
+
+  scm_gc_free (wmem, sizeof (scm_t_wchar) * (len + 1), "string");
+
+  SCM_SET_CELL_WORD_0 (buf, SCM_CELL_WORD_0 (buf) ^ STRINGBUF_F_WIDE);
+  SCM_SET_CELL_WORD_1 (buf, mem);
+  SCM_SET_CELL_WORD_2 (buf, len);
+}
+
 scm_i_pthread_mutex_t stringbuf_write_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 
 /* Copy-on-write strings.
@@ -462,6 +493,18 @@ scm_i_is_narrow_string (SCM str)
   return !STRINGBUF_WIDE (STRING_STRINGBUF (str));
 }
 
+/* Try to coerce a string to be narrow.  It if is narrow already, do
+   nothing.  If it is wide, shrink it to narrow if none of its
+   characters are above 0xFF.  Return true if the string is narrow or
+   was made to be narrow.  */
+int
+scm_i_try_narrow_string (SCM str)
+{
+  narrow_stringbuf (STRING_STRINGBUF (str));
+
+  return scm_i_is_narrow_string (str);
+}
+
 /* Returns a pointer to the 8-bit Latin-1 encoded character array of
    STR.  */
 const char *
@@ -656,7 +699,7 @@ scm_i_string_set_x (SCM str, size_t p, scm_t_wchar chr)
   if (scm_i_is_narrow_string (str))
     {
       char *dst = scm_i_string_writable_chars (str);
-      dst[p] = (char) (unsigned char) chr;
+      dst[p] = chr;
     }
   else
     {
@@ -666,7 +709,7 @@ scm_i_string_set_x (SCM str, size_t p, scm_t_wchar chr)
 }
 
 /* Symbols.
- 
+
    Basic symbol creation and accessing is done here, the rest is in
    symbols.[hc].  This has been done to keep stringbufs and the
    internals of strings and string-like objects confined to this file.
@@ -917,7 +960,7 @@ SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0, (SCM str),
   else
     e5 = scm_cons (scm_from_locale_symbol ("read-only"),
                    SCM_BOOL_F);
-      
+
   /* Stringbuf info */
   if (!STRINGBUF_WIDE (buf))
     {