Improved Unicode support for command-line arguments, environment variables, the C interface and error messages, and the Windows registry, DLL loading, and process creation

original commit: aa1c2c4ec95c286a12730ea75588a18dd9fb9d59

LOG

@@ -946,3 +946,10 @@
     patch-interpret-0-f-t-f, patch-interpret-3-f-f-f, patch-interpret-3-f-t-f
 - Double FMTBUFSIZE to fix compilation with gcc-8
     c/prim5.c
+- Improved Unicode support for command-line arguments, environment
+  variables, the C interface and error messages, and the Windows
+  registry, DLL loading, and process creation
+    scheme.h, alloc.c, externs.h, fasl.c, foreign.c, io.c, main.c,
+    prim5.c, scheme.c, schlib.c, schsig.c, stats.c, system.h,
+    version.h, windows.c, foreign.stex, system.stex, mkheader.ss,
+    prims.ss

c/alloc.c

@@ -756,6 +756,125 @@ ptr S_string(s, n) const char *s; iptr n; {
     return p;
 }
 
+ptr Sstring_utf8(s, n) const char *s; iptr n; {
+  const char* u8;
+  iptr cc, d, i, n8;
+  ptr p, tc;
+
+  if (n < 0) n = strlen(s);
+
+  if (n == 0) return S_G.null_string;
+
+  /* determine code point count cc */
+  u8 = s;
+  n8 = n;
+  cc = 0;
+  while (n8 > 0) {
+    unsigned char b1 = *(const unsigned char*)u8++;
+    n8--;
+    cc++;
+    if ((b1 & 0x80) == 0)
+      ;
+    else if ((b1 & 0x40) == 0)
+      ;
+    else if ((b1 & 0x20) == 0) {
+      if ((n8 >= 1) && ((*u8 & 0xc0) == 0x80)) {
+        u8++;
+        n8--;
+      }
+    } else if ((b1 & 0x10) == 0) {
+      if ((n8 >= 1) && ((*u8 & 0xc0) == 0x80)) {
+        u8++;
+        n8--;
+        if ((n8 >= 1) && ((*u8 & 0xc0) == 0x80)) {
+          u8++;
+          n8--;
+        }
+      }
+    } else if ((b1 & 0x08) == 0) {
+      if ((n8 >= 1) && ((*u8 & 0xc0) == 0x80)) {
+        u8++;
+        n8--;
+        if ((n8 >= 1) && ((*u8 & 0xc0) == 0x80)) {
+          u8++;
+          n8--;
+          if ((n8 >= 1) && ((*u8 & 0xc0) == 0x80)) {
+            u8++;
+            n8--;
+          }
+        }
+      }
+    }
+  }
+
+  if ((uptr)cc > (uptr)maximum_string_length)
+    S_error("", "invalid string size request");
+
+  tc = get_thread_context();
+  d = size_string(cc);
+  thread_find_room(tc, type_typed_object, d, p);
+  STRTYPE(p) = (cc << string_length_offset) | type_string;
+
+  /* fill the string */
+  u8 = s;
+  n8 = n;
+  i = 0;
+  while (n8 > 0) {
+    unsigned char b1 = *u8++;
+    int c = 0xfffd;
+    n8--;
+    if ((b1 & 0x80) == 0)
+      c = b1;
+    else if ((b1 & 0x40) == 0)
+      ;
+    else if ((b1 & 0x20) == 0) {
+      unsigned char b2;
+      if ((n8 >= 1) && (((b2 = *u8) & 0xc0) == 0x80)) {
+        int x = ((b1 & 0x1f) << 6) | (b2 & 0x3f);
+        u8++;
+        n8--;
+        if (x >= 0x80)
+          c = x;
+      }
+    } else if ((b1 & 0x10) == 0) {
+      unsigned char b2;
+      if ((n8 >= 1) && (((b2 = *u8) & 0xc0) == 0x80)) {
+        unsigned char b3;
+        u8++;
+        n8--;
+        if ((n8 >= 1) && (((b3 = *u8) & 0xc0) == 0x80)) {
+          int x = ((b1 & 0x0f) << 12) | ((b2 & 0x3f) << 6) | (b3 & 0x3f);
+          u8++;
+          n8--;
+          if ((x >= 0x800) && ((x < 0xd800) || (x > 0xdfff)))
+            c = x;
+        }
+      }
+    } else if ((b1 & 0x08) == 0) {
+      unsigned char b2;
+      if ((n8 >= 1) && (((b2 = *u8) & 0xc0) == 0x80)) {
+        unsigned char b3;
+        u8++;
+        n8--;
+        if ((n8 >= 1) && (((b3 = *u8) & 0xc0) == 0x80)) {
+          unsigned char b4;
+          u8++;
+          n8--;
+          if ((n8 >= 1) && (((b4 = *u8) & 0xc0) == 0x80)) {
+            int x = ((b1 & 0x07) << 18) | ((b2 & 0x3f) << 12) | ((b3 & 0x3f) << 6) | (b4 & 0x3f);
+            u8++;
+            n8--;
+            if ((x >= 0x10000) && (x <= 0x10ffff))
+              c = x;
+          }
+        }
+      }
+    }
+    Sstring_set(p, i++, c);
+  }
+  return p;
+}
+
 ptr S_bignum(n, sign) iptr n; IBOOL sign; {
     ptr tc = get_thread_context();
     ptr p; iptr d;

c/externs.h

@@ -351,7 +351,6 @@ extern ptr S_LastErrorString(void);
 extern void *S_ntdlopen(const char *path);
 extern void *S_ntdlsym(void *h, const char *s);
 extern char *S_ntdlerror(void);
-extern char *S_GetRegistry(char *buf, int bufsize, char *s);
 extern int S_windows_flock(int fd, int operation);
 extern int S_windows_chdir(const char *pathname);
 extern int S_windows_chmod(const char *pathname, int mode);

c/fasl.c

@@ -321,7 +321,7 @@ ptr S_boot_read(gzFile file, const char *path) {
   ptr tc = get_thread_context();
   struct unbufFaslFileObj uffo;
 
-  uffo.path = S_string(path, -1);
+  uffo.path = Sstring_utf8(path, -1);
   uffo.type = UFFO_TYPE_GZ;
   uffo.file = file;
   return fasl_entry(tc, &uffo);

c/foreign.c

@@ -171,7 +171,7 @@ void Sforeign_symbol(s, v) const char *s; void *v; {
         SETVECTIT(S_G.foreign_static, b, Scons(Scons(bvstring(s), addr_to_ptr(v)),
                                           Svector_ref(S_G.foreign_static, b)));
     } else if (ptr_to_addr(x) != v)
-        S_error1("Sforeign_symbol", "duplicate symbol entry for ~s", S_string(s, -1));
+        S_error1("Sforeign_symbol", "duplicate symbol entry for ~s", Sstring_utf8(s, -1));
 
     tc_mutex_release()
 }
@@ -229,8 +229,8 @@ static void load_shared_object(path) const char *path; {
 
     handle = dlopen(path, RTLD_NOW);
     if (handle == (void *)NULL)
-        S_error2("", "(while loading ~a) ~a", S_string(path, -1),
+        S_error2("", "(while loading ~a) ~a", Sstring_utf8(path, -1),
-                    S_string(dlerror(), -1));
+                    Sstring_utf8(dlerror(), -1));
     S_foreign_dynamic = Scons(addr_to_ptr(handle), S_foreign_dynamic);
 
     tc_mutex_release()
@@ -281,7 +281,7 @@ static ptr foreign_entries() {
 
     for (b = 0; b < buckets; b++)
         for (p = Svector_ref(S_G.foreign_static, b); p != Snil; p = Scdr(p))
-            entries = Scons(S_string((char *)&BVIT(Scar(Scar(p)), 0), -1), entries);
+            entries = Scons(Sstring_utf8((char *)&BVIT(Scar(Scar(p)), 0), -1), entries);
 
     return entries;
 }

c/io.c

@@ -20,6 +20,8 @@
 #include <limits.h>
 #ifdef WIN32
 #include <io.h>
+#include <shlobj.h>
+#pragma comment(lib, "shell32.lib")
 #else /* WIN32 */
 #include <sys/file.h>
 #include <dirent.h>
@@ -41,19 +43,25 @@ char *S_malloc_pathname(const char *inpath) {
 
 #ifdef WIN32
   if (*inpath == '~' && (*(ip = inpath + 1) == 0 || DIRMARKERP(*ip))) {
-    const char *homedrive, *homepath; size_t n1, n2, n3;
+    wchar_t* homew;
-
+    if (SUCCEEDED(SHGetKnownFolderPath(&FOLDERID_Profile, 0, NULL, &homew))) {
-    if ((homedrive = getenv("HOMEDRIVE")) != NULL && (homepath = getenv("HOMEPATH")) != NULL) {
+      char *home = Swide_to_utf8(homew);
-      n1 = strlen(homedrive);
+      CoTaskMemFree(homew);
-      n2 = strlen(homepath);
+      if (NULL != home) {
-      n3 = strlen(ip) + 1;
+        size_t n1, n2;
-      if ((outpath = malloc(n1 + n2 + n3)) == NULL) S_error("expand_pathname", "malloc failed");
+        n1 = strlen(home);
-      memcpy(outpath, homedrive, n1);
+        n2 = strlen(ip) + 1;
-      memcpy(outpath + n1, homepath, n2);
+        if ((outpath = malloc(n1 + n2)) == NULL) {
-      memcpy(outpath + n1 + n2, ip, n3);
+          free(home);
+          S_error("expand_pathname", "malloc failed");
+        }
+        memcpy(outpath, home, n1);
+        memcpy(outpath + n1, ip, n2);
+        free(home);
         return outpath;
       }
     }
+  }
 #else /* WIN32 */
   if (*inpath == '~') {
     const char *dir; size_t n1, n2; struct passwd *pwent;
@@ -91,25 +99,9 @@ char *S_malloc_pathname(const char *inpath) {
 }
 
 #ifdef WIN32
-/* raises an exception if insufficient space cannot be malloc'd.
-   returns NULL if utf-8 path cannot be converted to wchars.
-   otherwise returns a freshly allocated, wide-character version
-   of inpath with ~ (home directory) prefix expanded, if possible */
 wchar_t *S_malloc_wide_pathname(const char *inpath) {
-  size_t n; char *path; wchar_t *wpath;
+  char *path = S_malloc_pathname(inpath);
-
+  wchar_t *wpath = Sutf8_to_wide(path);
-  path = S_malloc_pathname(inpath);
-  n = strlen(path) + 1;
-  /* counting on utf-8 representation having at least as many chars as wchar representation */
-  if ((wpath = (wchar_t *)malloc(n * sizeof(wchar_t))) == NULL) {
-    free(path);
-    S_error("expand_pathname", "malloc failed");
-  }
-  if (MultiByteToWideChar(CP_UTF8, 0, path, -1, wpath, (int)n) == 0) {
-    free(path);
-    free(wpath);
-    return NULL;
-  }
   free(path);
   return wpath;
 }

c/main.c

@@ -14,13 +14,6 @@
  * limitations under the License.
  */
 
-/****
-  This is the default custom.c file defining main, which must be present
-  in order to build an executable file.
-
-  See the file custom/sample.c for a customized variant of this file.
-****/
-
 #include <stdlib.h>
 #include <string.h>
 #include <stdio.h>
@@ -66,7 +59,24 @@ static const char *path_last(const char *p) {
   return p;
 }
 
+#ifdef WIN32
+#define GETENV Sgetenv
+#define GETENV_FREE free
+int wmain(int argc, wchar_t* wargv[], wchar_t* wenvp[]) {
+  const char** argv = (char**)malloc((argc + 1) * sizeof(char*));
+  for (int i = 0; i < argc; i++) {
+    wchar_t* warg = wargv[i];
+    if (NULL == (argv[i] = Swide_to_utf8(warg))) {
+      fprintf_s(stderr, "Invalid argument: %S\n", warg);
+      exit(1);
+    }
+  }
+  argv[argc] = NULL;
+#else /* WIN32 */
+#define GETENV getenv
+#define GETENV_FREE (void)
 int main(int argc, const char *argv[]) {
+#endif /* WIN32 */
   int n, new_argc = 1;
 #ifdef SAVEDHEAPS
   int compact = 1, savefile_level = 0;
@@ -313,13 +323,23 @@ int main(int argc, const char *argv[]) {
   if (import_notify != 0) {
     CALL1("import-notify", Strue);
   }
-  if (libdirs == 0) libdirs = getenv("CHEZSCHEMELIBDIRS");
+  if (libdirs == 0) {
-  if (libdirs != 0) {
+    char *cslibdirs = GETENV("CHEZSCHEMELIBDIRS");
-    CALL1("library-directories", Sstring(libdirs));
+    if (cslibdirs != 0) {
+      CALL1("library-directories", Sstring_utf8(cslibdirs, -1));
+      GETENV_FREE(cslibdirs);
     }
-  if (libexts == 0) libexts = getenv("CHEZSCHEMELIBEXTS");
+  } else {
-  if (libexts != 0) {
+    CALL1("library-directories", Sstring_utf8(libdirs, -1));
-    CALL1("library-extensions", Sstring(libexts));
+  }
+  if (libexts == 0) {
+    char *cslibexts = GETENV("CHEZSCHEMELIBEXTS");
+    if (cslibexts != 0) {
+      CALL1("library-extensions", Sstring_utf8(cslibexts, -1));
+      GETENV_FREE(cslibexts);
+    }
+  } else {
+    CALL1("library-extensions", Sstring_utf8(libexts, -1));
   }
   if (compile_imported_libraries != 0) {
     CALL1("compile-imported-libraries", Strue);

c/prim5.c

@@ -124,7 +124,17 @@ ptr S_strerror(INT errnum) {
   ptr p; char *msg;
 
   tc_mutex_acquire()
-  p = (msg = strerror(errnum)) == NULL ? Sfalse : Sstring(msg);
+#ifdef WIN32
+  msg = Swide_to_utf8(_wcserror(errnum));
+  if (msg == NULL)
+    p = Sfalse;
+  else {
+    p = Sstring_utf8(msg, -1);
+    free(msg);
+  }
+#else
+  p = (msg = strerror(errnum)) == NULL ? Sfalse : Sstring_utf8(msg, -1);
+#endif
   tc_mutex_release()
   return p;
 }
@@ -356,15 +366,21 @@ static void s_showalloc(IBOOL show_dump, const char *outfn) {
   if (outfn == NULL) {
     out = stderr;
   } else {
+#ifdef WIN32
+    wchar_t *outfnw = Sutf8_to_wide(outfn);
+    out = _wfopen(outfnw, L"w");
+    free(outfnw);
+#else
     out = fopen(outfn, "w");
+#endif
     if (out == NULL) {
       ptr msg = S_strerror(errno);
       if (msg != Sfalse) {
         tc_mutex_release()
-        S_error2("fopen", "open of ~s failed: ~a", Sstring(outfn), msg);
+        S_error2("fopen", "open of ~s failed: ~a", Sstring_utf8(outfn, -1), msg);
       } else {
         tc_mutex_release()
-        S_error1("fopen", "open of ~s failed", Sstring(outfn));
+        S_error1("fopen", "open of ~s failed", Sstring_utf8(outfn, -1));
       }
     }
   }
@@ -601,7 +617,7 @@ static ptr s_system(const char *s) {
   if (DISABLECOUNT(tc) == FIX(0)) reactivate_thread(tc);
 #endif
 
-  if (status == -1) {
+  if ((status == -1) && (errno != 0)) {
     ptr msg = S_strerror(errno);
 
     if (msg != Sfalse)
@@ -624,12 +640,12 @@ static ptr s_process(s, stderrp) char *s; IBOOL stderrp; {
     INT ifd = -1, ofd = -1, efd = -1, child = -1;
 
 #ifdef WIN32
-/* WIN32 version courtesy of Bob Burger, burgerrg@sagian.com */
     HANDLE hToRead, hToWrite, hFromRead, hFromWrite, hFromReadErr, hFromWriteErr, hProcess;
-    STARTUPINFO si = {0};
+    STARTUPINFOW si = {0};
     PROCESS_INFORMATION pi;
     char *comspec;
     char *buffer;
+    wchar_t* bufferw;
 
     /* Create non-inheritable pipes, important to eliminate zombee children
      * when the parent sides are closed. */
@@ -640,15 +656,13 @@ static ptr s_process(s, stderrp) char *s; IBOOL stderrp; {
         CloseHandle(hToWrite);
         S_error("process", "cannot open pipes");
     }
-    if (stderrp) {
+    if (stderrp && !CreatePipe(&hFromReadErr, &hFromWriteErr, NULL, 0)) {
-      if (!CreatePipe(&hFromReadErr, &hFromWriteErr, NULL, 0)) {
         CloseHandle(hToRead);
         CloseHandle(hToWrite);
         CloseHandle(hFromRead);
         CloseHandle(hFromWrite);
         S_error("process", "cannot open pipes");
     }
-    }
 
     si.cb = sizeof(STARTUPINFO);
     si.dwFlags = STARTF_USESTDHANDLES;
@@ -701,13 +715,16 @@ static ptr s_process(s, stderrp) char *s; IBOOL stderrp; {
       si.hStdError = si.hStdOutput;
     }
 
-    if ((comspec = getenv("COMSPEC"))) {
+    if ((comspec = Sgetenv("COMSPEC"))) {
-        size_t n = strlen(comspec) + strlen(s) + 5;
+        size_t n = strlen(comspec) + strlen(s) + 7;
         buffer = (char *)_alloca(n);
-        snprintf(buffer, n, "%s /c %s", comspec, s);
+        snprintf(buffer, n, "\"%s\" /c %s", comspec, s);
+        free(comspec);
     } else
         buffer = s;
-    if (!CreateProcess(NULL, buffer, NULL, NULL, TRUE, 0, NULL, NULL, &si, &pi)) {
+    bufferw = Sutf8_to_wide(buffer);
+    if (!CreateProcessW(NULL, bufferw, NULL, NULL, TRUE, 0, NULL, NULL, &si, &pi)) {
+        free(bufferw);
         CloseHandle(si.hStdInput);
         CloseHandle(hToWrite);
         CloseHandle(hFromRead);
@@ -718,6 +735,7 @@ static ptr s_process(s, stderrp) char *s; IBOOL stderrp; {
         }
         S_error("process", "cannot spawn subprocess");
     }
+    free(bufferw);
     CloseHandle(si.hStdInput);
     CloseHandle(si.hStdOutput);
     if (stderrp) {
@@ -1331,46 +1349,40 @@ static ptr s_getenv PROTO((char *name));
 
 static ptr s_getenv(name) char *name; {
 #ifdef WIN32
-#define GETENVBUFSIZ 100
+  char *s = Sgetenv(name);
-  char buf[GETENVBUFSIZ];
-  size_t n;
-
-  n = GetEnvironmentVariable(name, buf, GETENVBUFSIZ);
-  if (n > GETENVBUFSIZ) {
-    ptr bv = S_bytevector(n);
-    n = GetEnvironmentVariable(name, &BVIT(bv,0), (DWORD)n);
-    if (n != 0) return S_string(&BVIT(bv,0), n);
-  } else if (n > 0) {
-    return S_string(buf, n);
-  }
-
-  if (getenv_s(&n, buf, GETENVBUFSIZ, name) == 0) {
-    if (n != 0) return S_string(buf, n-1);
-  } else {
-    ptr bv = S_bytevector(n);
-    if (getenv_s(&n, &BVIT(bv,0), n, name) == 0)
-      if (n != 0) return S_string(&BVIT(bv,0), n-1);
-  }
-
-  return Sfalse;
 #else /* WIN32 */
   char *s = getenv(name);
-  return s == (char *)0 ? Sfalse : S_string(s, -1);
 #endif /* WIN32 */
+  if (s == (char *)0)
+    return Sfalse;
+  else {
+    ptr r = Sstring_utf8(s, -1);
+#ifdef WIN32
+    free(s);
+#endif
+    return r;
+  }
 }
 
 static void s_putenv PROTO((char *name, char *value));
 static void s_putenv(name, value) char *name, *value; {
-  iptr n; char *s;
 #ifdef WIN32
-  if (SetEnvironmentVariable(name, value) == 0) {
+  wchar_t* namew;
+  wchar_t* valuew;
+  BOOL rc;
+  namew = Sutf8_to_wide(name);
+  valuew = Sutf8_to_wide(value);
+  rc = SetEnvironmentVariableW(namew, valuew);
+  free(namew);
+  free(valuew);
+  if (rc == 0)
     S_error1("putenv", "environment extension failed: ~a", S_LastErrorString());
-  }
+#else /* WIN32 */
-#endif /* WIN32 */
+  iptr n; char *s;
   n = strlen(name) + strlen(value) + 2;
   if ((s = malloc(n)) == (char *)NULL
        || snprintf(s, n, "%s=%s", name, value) < 0
-       || PUTENV(s) != 0) {
+       || putenv(s) != 0) {
     ptr msg = S_strerror(errno);
 
     if (msg != Sfalse)
@@ -1378,6 +1390,7 @@ static void s_putenv(name, value) char *name, *value; {
     else
       S_error("putenv", "environment extension failed");
   }
+#endif /* WIN32 */
 }
 
 #ifdef PTHREADS
@@ -1904,48 +1917,49 @@ static iconv_close_ft iconv_close_f = (iconv_close_ft)0;
 #define ICONV_CLOSE iconv_close
 #endif
 
+#ifdef WIN32
+static ptr s_iconv_trouble(HMODULE h, const char *what) {
+  wchar_t dllw[PATH_MAX];
+  char *dll;
+  size_t n;
+  char *msg;
+  ptr r;
+  if (0 != GetModuleFileNameW(h, dllw, PATH_MAX))
+    dll = Swide_to_utf8(dllw);
+  else
+    dll = NULL;
+  FreeLibrary(h);
+  n = strlen(what) + strlen(dll) + 17;
+  msg = (char *)malloc(n);
+  sprintf_s(msg, n, "cannot find %s in %s", what, dll);
+  free(dll);
+  r = Sstring_utf8(msg, -1);
+  free(msg);
+  return r;
+}
+#endif /* WIN32 */
+
 static ptr s_iconv_open(const char *tocode, const char *fromcode) {
   iconv_t cd;
 #ifdef WIN32
   static int iconv_is_loaded = 0;
   if (!iconv_is_loaded) {
-    HMODULE h = LoadLibrary("iconv.dll");
+    HMODULE h = LoadLibraryW(L"iconv.dll");
-    if (h == NULL) h = LoadLibrary("libiconv.dll");
+    if (h == NULL) h = LoadLibraryW(L"libiconv.dll");
-    if (h == NULL) h = LoadLibrary("libiconv-2.dll");
+    if (h == NULL) h = LoadLibraryW(L"libiconv-2.dll");
-    if (h == NULL) h = LoadLibrary(".\\iconv.dll");
+    if (h == NULL) h = LoadLibraryW(L".\\iconv.dll");
-    if (h == NULL) h = LoadLibrary(".\\libiconv.dll");
+    if (h == NULL) h = LoadLibraryW(L".\\libiconv.dll");
-    if (h == NULL) h = LoadLibrary(".\\libiconv-2.dll");
+    if (h == NULL) h = LoadLibraryW(L".\\libiconv-2.dll");
     if (h == NULL) return Sstring("cannot load iconv.dll, libiconv.dll, or libiconv-2.dll");
     if ((iconv_open_f = (iconv_open_ft)GetProcAddress(h, "iconv_open")) == NULL &&
-        (iconv_open_f = (iconv_open_ft)GetProcAddress(h, "libiconv_open")) == NULL) {
+        (iconv_open_f = (iconv_open_ft)GetProcAddress(h, "libiconv_open")) == NULL)
-      const char prefix[] = "cannot find iconv_open or libiconv_open in ";
+      return s_iconv_trouble(h, "iconv_open or libiconv_open");
-      char msg[sizeof(prefix) - 1 + PATH_MAX];
-      strncpy(msg, prefix, sizeof(prefix));
-      strcpy(msg + sizeof(prefix) - 1, "iconv dll");
-      GetModuleFileName(h, msg + sizeof(prefix) - 1, PATH_MAX);
-      FreeLibrary(h);
-      return Sstring(msg);
-    }
     if ((iconv_f = (iconv_ft)GetProcAddress(h, "iconv")) == NULL &&
-        (iconv_f = (iconv_ft)GetProcAddress(h, "libiconv")) == NULL) {
+        (iconv_f = (iconv_ft)GetProcAddress(h, "libiconv")) == NULL)
-      const char prefix[] = "cannot find iconv or libiconv in ";
+      return s_iconv_trouble(h, "iconv or libiconv");
-      char msg[sizeof(prefix) - 1 + PATH_MAX];
-      strncpy(msg, prefix, sizeof(prefix));
-      strcpy(msg + sizeof(prefix) - 1, "iconv dll");
-      GetModuleFileName(h, msg + sizeof(prefix) - 1, PATH_MAX);
-      FreeLibrary(h);
-      return Sstring(msg);
-    }
     if ((iconv_close_f = (iconv_close_ft)GetProcAddress(h, "iconv_close")) == NULL &&
-        (iconv_close_f = (iconv_close_ft)GetProcAddress(h, "libiconv_close")) == NULL) {
+        (iconv_close_f = (iconv_close_ft)GetProcAddress(h, "libiconv_close")) == NULL)
-      const char prefix[] = "cannot find iconv_close or libiconv_close in ";
+      return s_iconv_trouble(h, "iconv_close or libiconv_close");
-      char msg[sizeof(prefix) - 1 + PATH_MAX];
-      strncpy(msg, prefix, sizeof(prefix));
-      strcpy(msg + sizeof(prefix) - 1, "iconv dll");
-      GetModuleFileName(h, msg + sizeof(prefix) - 1, PATH_MAX);
-      FreeLibrary(h);
-      return Sstring(msg);
-    }
     iconv_is_loaded = 1;
   }
 #endif /* WIN32 */

c/scheme.c

@@ -422,7 +422,6 @@ static const char *path_last(p) const char *p; {
   return p;
 }
 
-#define SEARCHPATHMAXSIZE 8192
 #ifdef WIN32
 #ifndef DEFAULT_HEAP_PATH
 /* by default, look in executable directory or in parallel boot directory */
@@ -433,12 +432,14 @@ static const char *path_last(p) const char *p; {
 
 static char *get_defaultheapdirs() {
   char *result;
-  static char defaultheapdirs[SEARCHPATHMAXSIZE];
+  wchar_t buf[PATH_MAX];
-  char key[PATH_MAX];
+  DWORD len = sizeof(buf);
-  snprintf(key, PATH_MAX, "HKEY_LOCAL_MACHINE\\Software\\Chez Scheme\\csv%s\\HeapSearchPath", VERSION);
+  if (ERROR_SUCCESS != RegGetValueW(HKEY_LOCAL_MACHINE, L"Software\\Chez Scheme\\csv" VERSION, L"HeapSearchPath", RRF_RT_REG_SZ, NULL, buf, &len))
-  result = S_GetRegistry(defaultheapdirs, SEARCHPATHMAXSIZE, key);
+    return DEFAULT_HEAP_PATH;
-  if (result == NULL) result = DEFAULT_HEAP_PATH;
+  else if ((result = Swide_to_utf8(buf)))
     return result;
+  else
+    return DEFAULT_HEAP_PATH;
 }
 #else /* not WIN32: */
 #define SEARCHPATHSEP ':'
@@ -475,17 +476,20 @@ static IBOOL next_path(path, name, ext, sp, dsp) char *path; const char *name, *
           switch (*s) {
 #ifdef WIN32
             case 'x': {
-              char exepath[PATH_MAX]; DWORD n;
+              wchar_t exepath[PATH_MAX]; DWORD n;
               s += 1;
-              n = GetModuleFileName(NULL,exepath,PATH_MAX);
+              n = GetModuleFileNameW(NULL, exepath, PATH_MAX);
               if (n == 0 || (n == PATH_MAX && GetLastError() == ERROR_INSUFFICIENT_BUFFER)) {
                 fprintf(stderr, "warning: executable path is too long; ignoring %%x\n");
               } else {
+                char *tstart;
                 const char *tend;
-                t = exepath;
+                tstart = Swide_to_utf8(exepath);
+                t = tstart;
                 tend = path_last(t);
                 if (tend != t) tend -= 1; /* back up to directory separator */
                 while (t != tend) setp(*t++);
+                free(tstart);
               }
               break;
             }
@@ -561,7 +565,11 @@ static IBOOL find_boot(name, ext, errorp) const char *name, *ext; IBOOL errorp;
   char pathbuf[PATH_MAX], buf[PATH_MAX];
   uptr n; INT c;
   const char *path;
+#ifdef WIN32
+  wchar_t *expandedpath;
+#else
   char *expandedpath;
+#endif
   gzFile file;
 
   if (S_fixedpathp(name)) {
@@ -572,8 +580,13 @@ static IBOOL find_boot(name, ext, errorp) const char *name, *ext; IBOOL errorp;
 
     path = name;
 
+#ifdef WIN32
+    expandedpath = S_malloc_wide_pathname(path);
+    file = gzopen_w(expandedpath, "rb");
+#else
     expandedpath = S_malloc_pathname(path);
     file = gzopen(expandedpath, "rb");
+#endif
     /* assumption (seemingly true based on a glance at the source code):
        gzopen doesn't squirrel away a pointer to expandedpath. */
     free(expandedpath);
@@ -647,8 +660,13 @@ static IBOOL find_boot(name, ext, errorp) const char *name, *ext; IBOOL errorp;
         }
       }
 
+#ifdef WIN32
+      expandedpath = S_malloc_wide_pathname(path);
+      file = gzopen_w(expandedpath, "rb");
+#else
       expandedpath = S_malloc_pathname(path);
       file = gzopen(expandedpath, "rb");
+#endif
       /* assumption (seemingly true based on a glance at the source code):
          gzopen doesn't squirrel away a pointer to expandedpath. */
       free(expandedpath);
@@ -830,7 +848,7 @@ static int set_load_binary(iptr n) {
   if (SYMVAL(S_G.scheme_version_id) == sunbound) return 0; // set by back.ss
   ptr make_load_binary = SYMVAL(S_G.make_load_binary_id);
   if (Sprocedurep(make_load_binary)) {
-    S_G.load_binary = Scall3(make_load_binary, Sstring(bd[n].path), Sstring_to_symbol("load"), Sfalse);
+    S_G.load_binary = Scall3(make_load_binary, Sstring_utf8(bd[n].path, -1), Sstring_to_symbol("load"), Sfalse);
     return 1;
   }
   return 0;
@@ -975,7 +993,11 @@ extern void Sscheme_init(abnormal_exit) void (*abnormal_exit) PROTO((void)); {
 
   boot_count = 0;
 
+#ifdef WIN32
+  Sschemeheapdirs = Sgetenv("SCHEMEHEAPDIRS");
+#else
   Sschemeheapdirs = getenv("SCHEMEHEAPDIRS");
+#endif
   if (Sschemeheapdirs == (char *)0) {
     Sschemeheapdirs = "";
     if ((Sdefaultheapdirs = get_defaultheapdirs()) == (char *)0) Sdefaultheapdirs = "";
@@ -1125,7 +1147,7 @@ extern void Senable_expeditor(history_file) const char *history_file; {
   Scall1(S_symbol_value(Sstring_to_symbol("$enable-expeditor")), Strue);
   if (history_file != (const char *)0)
     Scall1(S_symbol_value(Sstring_to_symbol("$expeditor-history-file")),
-           Sstring(history_file));
+           Sstring_utf8(history_file, -1));
 }
 
 extern INT Sscheme_start(argc, argv) INT argc; const char *argv[]; {
@@ -1146,7 +1168,7 @@ extern INT Sscheme_start(argc, argv) INT argc; const char *argv[]; {
 
   arglist = Snil;
   for (i = argc - 1; i > 0; i -= 1)
-    arglist = Scons(Sstring(argv[i]), arglist);
+    arglist = Scons(Sstring_utf8(argv[i], -1), arglist);
 
   p = S_symbol_value(S_intern((const unsigned char *)"$scheme"));
   if (!Sprocedurep(p)) {
@@ -1180,7 +1202,7 @@ static INT run_script(const char *who, const char *scriptfile, INT argc, const c
 
   arglist = Snil;
   for (i = argc - 1; i > 0; i -= 1)
-    arglist = Scons(Sstring(argv[i]), arglist);
+    arglist = Scons(Sstring_utf8(argv[i], -1), arglist);
 
   p = S_symbol_value(S_intern((const unsigned char *)"$script"));
   if (!Sprocedurep(p)) {
@@ -1190,7 +1212,7 @@ static INT run_script(const char *who, const char *scriptfile, INT argc, const c
 
   S_initframe(tc, 3);
   S_put_arg(tc, 1, Sboolean(programp));
-  S_put_arg(tc, 2, Sstring(scriptfile));
+  S_put_arg(tc, 2, Sstring_utf8(scriptfile, -1));
   S_put_arg(tc, 3, arglist);
   p = boot_call(tc, p, 3);
 

c/schlib.c

@@ -105,6 +105,8 @@ ptr Sstring_of_length(s, n) const char *s; iptr n; {
     return S_string(s, n);
 }
 
+/* Sstring_utf8 is in alloc.c */
+
 /* Sbox is in alloc.c */
 
 /* Sinteger is in number.c */

c/schsig.c

@@ -384,8 +384,8 @@ static void do_error(type, who, s, args) iptr type; const char *who, *s; ptr arg
     }
 
     args = Scons(FIX(type),
-                 Scons((strlen(who) == 0 ? Sfalse : S_string(who,-1)),
+                 Scons((strlen(who) == 0 ? Sfalse : Sstring_utf8(who,-1)),
-                       Scons(S_string(s, -1), args)));
+                       Scons(Sstring_utf8(s, -1), args)));
 
 #ifdef PTHREADS
     while (S_tc_mutex_depth > 0) {

c/stats.c

@@ -421,8 +421,7 @@ static long adjust_time_zone(ptr dtvec, struct tm *tmxp, ptr given_tzoff) {
 #ifdef WIN32
   {
     TIME_ZONE_INFORMATION tz;
-    WCHAR *w_tzname;
+    wchar_t *w_tzname;
-    int len;
 
     /* The ...ForYear() function is available on Windows Vista and later: */
     GetTimeZoneInformationForYear(tmxp->tm_year, NULL, &tz);
@@ -436,10 +435,9 @@ static long adjust_time_zone(ptr dtvec, struct tm *tmxp, ptr given_tzoff) {
     }
 
     if (given_tzoff == Sfalse) {
-      len = (int)wcslen(w_tzname);
+      char *name = Swide_to_utf8(w_tzname);
-      tz_name = S_string(NULL, len);
+      tz_name = Sstring_utf8(name, -1);
-      while (len--)
+      free(name);
-        Sstring_set(tz_name, len, w_tzname[len]);
     }
   }
 #else
@@ -447,10 +445,10 @@ static long adjust_time_zone(ptr dtvec, struct tm *tmxp, ptr given_tzoff) {
   if (given_tzoff == Sfalse) {
 # if defined(__linux__) || defined(SOLARIS)
     /* Linux and Solaris set `tzname`: */
-    tz_name = S_string(tzname[tmxp->tm_isdst], -1);
+    tz_name = Sstring_utf8(tzname[tmxp->tm_isdst], -1);
 # else
     /* BSD variants add `tm_zone` in `struct tm`: */
-    tz_name = S_string(tmxp->tm_zone, -1);
+    tz_name = Sstring_utf8(tmxp->tm_zone, -1);
 # endif
   }
 #endif
@@ -498,7 +496,7 @@ ptr S_realtime(void) {
 void S_stats_init() {
 #ifdef WIN32
   /* Use GetSystemTimePreciseAsFileTime when available (Windows 8 and later). */
-  HMODULE h = LoadLibrary("kernel32.dll");
+  HMODULE h = LoadLibraryW(L"kernel32.dll");
   if (h != NULL) {
     GetSystemTimeAsFileTime_t proc = (GetSystemTimeAsFileTime_t)GetProcAddress(h, "GetSystemTimePreciseAsFileTime");
     if (proc != NULL)

c/system.h

@@ -17,6 +17,8 @@
 #include "scheme.h"
 #include "equates.h"
 #ifdef FEATURE_WINDOWS
+#define WINVER 0x0601 // Windows 7
+#define _WIN32_WINNT WINVER
 #include <windows.h>
 #endif
 

c/version.h

@@ -211,7 +211,6 @@ typedef char *memcpy_t;
 #define LSTAT S_windows_stat64
 #define OFF_T __int64
 #define OPEN S_windows_open
-#define PUTENV _putenv
 #define READ _read
 #define RENAME S_windows_rename
 #define RMDIR S_windows_rmdir
@@ -396,9 +395,6 @@ typedef char tputsputcchar;
 #ifndef OPEN
 # define OPEN open
 #endif
-#ifndef PUTENV
-# define PUTENV putenv
-#endif
 #ifndef READ
 # define READ read
 #endif

c/windows.c

@@ -23,9 +23,9 @@
 
 static ptr s_ErrorString(DWORD dwMessageId);
 static IUnknown *s_CreateInstance(CLSID *pCLSID, IID *iid);
-static ptr s_GetRegistry(char *s);
+static ptr s_GetRegistry(wchar_t *s);
-static void s_PutRegistry(char *s, char *val);
+static void s_PutRegistry(wchar_t *s, wchar_t *val);
-static void s_RemoveRegistry(char *s);
+static void s_RemoveRegistry(wchar_t *s);
 
 void S_machine_init() {
     Sregister_symbol("(com)CreateInstance", (void *)s_CreateInstance);
@@ -42,7 +42,10 @@ INT S_getpagesize() {
 }
 
 void *S_ntdlopen(const char *path) {
-    return (void *)LoadLibrary(path);
+  wchar_t *pathw = Sutf8_to_wide(path);
+  void *r = (void *)LoadLibraryW(pathw);
+  free(pathw);
+  return r;
 }
 
 void *S_ntdlsym(void *h, const char *s) {
@@ -66,85 +69,42 @@ char *S_ntdlerror(void) {
 oops, no S_flushcache_max_gap or S_doflush
 #endif /* FLUSHCACHE */
 
-static int strncasecmp(const char *s1, const char *s2, int n) {
+static void SplitRegistryKey(char *who, wchar_t *wholekey, HKEY *key, wchar_t **subkey, wchar_t **last) {
-  while (n > 0) {
+  wchar_t c, *s;
-    char c1 = *s1; char c2 = *s2;
-
-    if (c1 == 0) return c2 == 0 ? 0 : -1;
-    if (c2 == 0) return 1;
-
-    c1 = tolower(c1);
-    c2 = tolower(c2);
-
-    if (c1 != c2) return c1 < c2 ? -1 : 1;
-    n -= 1; s1 += 1; s2 += 1;
-  }
-  return 0;
-}
-
-static void SplitRegistryKey(char *who, char *wholekey, HKEY *key, char **subkey, char **last) {
-  char c, *s;
 
  /* Determine the base key */
-  if (strncasecmp(wholekey, "HKEY_CLASSES_ROOT\\", 18) == 0) {
+  if (_wcsnicmp(wholekey, L"HKEY_CLASSES_ROOT\\", 18) == 0) {
     *key = HKEY_CLASSES_ROOT;
     *subkey = wholekey+18;
-  } else if (strncasecmp(wholekey, "HKEY_CURRENT_USER\\", 18) == 0) {
+  } else if (_wcsnicmp(wholekey, L"HKEY_CURRENT_USER\\", 18) == 0) {
     *key = HKEY_CURRENT_USER;
     *subkey = wholekey+18;
-  } else if (strncasecmp(wholekey, "HKEY_LOCAL_MACHINE\\", 19) == 0) {
+  } else if (_wcsnicmp(wholekey, L"HKEY_LOCAL_MACHINE\\", 19) == 0) {
     *key = HKEY_LOCAL_MACHINE;
     *subkey = wholekey+19;
-  } else if (strncasecmp(wholekey, "HKEY_USERS\\", 11) == 0) {
+  } else if (_wcsnicmp(wholekey, L"HKEY_USERS\\", 11) == 0) {
     *key = HKEY_USERS;
     *subkey = wholekey+11;
-  } else if (strncasecmp(wholekey, "HKEY_CURRENT_CONFIG\\", 20) == 0) {
+  } else if (_wcsnicmp(wholekey, L"HKEY_CURRENT_CONFIG\\", 20) == 0) {
     *key = HKEY_CURRENT_CONFIG;
     *subkey = wholekey+20;
-  } else if (strncasecmp(wholekey, "HKEY_DYN_DATA\\", 14) == 0) {
+  } else if (_wcsnicmp(wholekey, L"HKEY_DYN_DATA\\", 14) == 0) {
     *key = HKEY_DYN_DATA;
     *subkey = wholekey+14;
-  } else
+  } else {
-    S_error1(who, "invalid registry key ~s", Sstring(wholekey));
+    char *wholekey_utf8 = Swide_to_utf8(wholekey);
+    ptr wholekey_scheme = Sstring_utf8(wholekey_utf8, -1);
+    free(wholekey_utf8);
+    S_error1(who, "invalid registry key ~s", wholekey_scheme);
+  }
 
   for (*last = s = *subkey, c = *s; c != '\0'; c = *++s)
     if (c == '\\') *last = s;
 }
 
-/* could commonize portions of next two routines, but they're short.
+static ptr s_GetRegistry(wchar_t *s) {
- * the first version takes a char * and returns the result in a buffer
- * of fixed size.  the second takes a char * and returns the result
- * in a scheme string of the necessary size.  the first returns
- * (char *)0 on failure; the second returns Sfalse. */
-extern char *S_GetRegistry(char *buf, int bufsize, char *s) {
   HKEY key, result;
-  char *subkey, *last;
+  wchar_t *subkey, *last;
-  DWORD rc, type, size;
-
-  SplitRegistryKey("get-registry", s, &key, &subkey, &last);
-
- /* open the key */
-  if (last == subkey) {
-    rc = RegOpenKeyEx(key, "", 0, KEY_QUERY_VALUE, &result);
-  } else {
-    *last = '\0'; /* Truncate subkey at backslash */
-    rc = RegOpenKeyEx(key, subkey, 0, KEY_QUERY_VALUE, &result);
-    *last++ = '\\'; /* Restore backslash */
-  }
-  if (rc != ERROR_SUCCESS) return (char *)0;
-
- /* grab the data */
-  size = bufsize - 1;  /* leave room for trailing nul */
-  rc = RegQueryValueEx(result, last, NULL, &type, buf, &size);
-  RegCloseKey(result);
-  buf[bufsize-1] = 0;  /* nul may be missing if buffer just large enough */
-
-  return rc != ERROR_SUCCESS ? (char *)0 : buf;
-}
-
-static ptr s_GetRegistry(char *s) {
-  HKEY key, result;
-  char *subkey, *last;
   DWORD rc, type, size;
   ptr ans;
 
@@ -152,16 +112,16 @@ static ptr s_GetRegistry(char *s) {
 
  /* open the key */
   if (last == subkey) {
-    rc = RegOpenKeyEx(key, "", 0, KEY_QUERY_VALUE, &result);
+    rc = RegOpenKeyExW(key, L"", 0, KEY_QUERY_VALUE, &result);
   } else {
     *last = '\0'; /* Truncate subkey at backslash */
-    rc = RegOpenKeyEx(key, subkey, 0, KEY_QUERY_VALUE, &result);
+    rc = RegOpenKeyExW(key, subkey, 0, KEY_QUERY_VALUE, &result);
     *last++ = '\\'; /* Restore backslash */
   }
   if (rc != ERROR_SUCCESS) return Sfalse;
 
  /* Get the size of the value */
-  rc = RegQueryValueEx(result, last, NULL, &type, NULL, &size);
+  rc = RegQueryValueExW(result, last, NULL, &type, NULL, &size);
   if (rc != ERROR_SUCCESS) {
     RegCloseKey(result);
     return Sfalse;
@@ -171,86 +131,97 @@ static ptr s_GetRegistry(char *s) {
   ans = S_bytevector(size);
 
  /* Load up the bytevector */
-  rc = RegQueryValueEx(result, last, NULL, &type, &BVIT(ans,0), &size);
+  rc = RegQueryValueExW(result, last, NULL, &type, &BVIT(ans,0), &size);
   RegCloseKey(result);
   if (rc != ERROR_SUCCESS) return Sfalse;
 
- /* discard unwanted terminating null byte, if present */
+ /* discard unwanted terminating null character, if present */
-  if ((type == REG_SZ) || (type == REG_EXPAND_SZ))
+  if (((type == REG_SZ) || (type == REG_EXPAND_SZ)) &&
-    BYTEVECTOR_TYPE(ans) = ((size-1) << bytevector_length_offset) | type_bytevector;
+      (size >= 2) &&
+      (*(wchar_t*)(&BVIT(ans, size-2)) == 0))
+    BYTEVECTOR_TYPE(ans) = ((size-2) << bytevector_length_offset) | type_bytevector;
 
   return ans;
 }
 
-static void s_PutRegistry(char *s, char *val) {
+static void s_PutRegistry(wchar_t *s, wchar_t *val) {
   HKEY key, result;
-  char *subkey, *last;
+  wchar_t *subkey, *last;
-  DWORD rc, qrc, type, size;
+  DWORD rc, type;
+  size_t n = (wcslen(val) + 1) * sizeof(wchar_t);
+#if (size_t_bits > 32)
+  if ((DWORD)n != n)  { 
+    char *s_utf8 = Swide_to_utf8(s);
+    ptr s_scheme = Sstring_utf8(s_utf8, -1);
+    free(s_utf8);
+    S_error2("put-registry!", "cannot set ~a (~a)", s_scheme, Sstring("too long"));
+  }
+#endif
 
   SplitRegistryKey("put-registry!", s, &key, &subkey, &last);
 
  /* create/open the key */
   if (last == subkey) {
-    rc = RegCreateKey(key, "", &result);
+    rc = RegCreateKeyExW(key, L"", 0, NULL, 0, KEY_SET_VALUE, NULL, &result, NULL);
   } else {
     *last = '\0'; /* Truncate subkey at backslash */
-    rc = RegCreateKey(key, subkey, &result);
+    rc = RegCreateKeyExW(key, subkey, 0, NULL, 0, KEY_SET_VALUE, NULL, &result, NULL);
     *last++ = '\\'; /* Restore backslash */
   }
 
+  if (rc == ERROR_SUCCESS) {
    /* lookup type for key (if it exists), if not assume REG_SZ */
-  if (rc == ERROR_SUCCESS) {
+    if (ERROR_SUCCESS != RegQueryValueExW(result, last, NULL, &type, NULL, NULL))
-    qrc = RegQueryValueEx(result, last, NULL, &type, NULL, &size);
+      type = REG_SZ;
-    if (qrc != ERROR_SUCCESS) type = REG_SZ;
-  }
 
-  if (rc == ERROR_SUCCESS) {
-    size_t n = strlen(val)+1;
-#if (size_t_bits > 32)
-    if ((DWORD)n != n)  {
-      RegCloseKey(result);
-      S_error2("put-registry!", "cannot set ~a (~a)", Sstring(s), Sstring("too long"));
-    }
-#endif
    /* set the value */
-    rc = RegSetValueEx(result, last, 0, type, val, (DWORD)n);
+    rc = RegSetValueExW(result, last, 0, type, (const BYTE*)val, (DWORD)n);
     RegCloseKey(result);
   }
 
-  if (rc != ERROR_SUCCESS)
+  if (rc != ERROR_SUCCESS) {
-    S_error2("put-registry!", "cannot set ~a (~a)", Sstring(s),
+    char *s_utf8 = Swide_to_utf8(s);
+    ptr s_scheme = Sstring_utf8(s_utf8, -1);
+    free(s_utf8);
+    S_error2("put-registry!", "cannot set ~a (~a)", s_scheme,
       rc == ERROR_FILE_NOT_FOUND ? Sstring("not found") : s_ErrorString(rc));
+  }
 }
 
-static void s_RemoveRegistry(char *s) {
+
+static void s_RemoveRegistry(wchar_t *s) {
   HKEY key, result;
-  char *subkey, *last;
+  wchar_t *subkey, *last;
   DWORD rc;
 
   SplitRegistryKey("remove-registry!", s, &key, &subkey, &last);
 
  /* open the key */
   if (last == subkey) {
-    rc = RegOpenKeyEx(key, "", 0, KEY_ALL_ACCESS, &result);
+    rc = RegOpenKeyExW(key, L"", 0, KEY_ALL_ACCESS, &result);
   } else {
     *last = '\0'; /* Truncate subkey at backslash */
-    rc = RegOpenKeyEx(key, subkey, 0, KEY_ALL_ACCESS, &result);
+    rc = RegOpenKeyExW(key, subkey, 0, KEY_ALL_ACCESS, &result);
     *last++ = '\\'; /* Restore backslash */
   }
   if (rc == ERROR_SUCCESS) {
    /* delete the value */
-    rc = RegDeleteValue(result, last);
+    rc = RegDeleteValueW(result, last);
     if (rc == ERROR_FILE_NOT_FOUND)
      /* value by given name not found; try deleting as key */
-      rc = RegDeleteKey(result, last);
+      rc = RegDeleteKeyW(result, last);
     RegCloseKey(result);
   }
 
-  if (rc != ERROR_SUCCESS)
+  if (rc != ERROR_SUCCESS) {
-    S_error2("remove-registry!", "cannot remove ~a (~a)", Sstring(s),
+    char *s_utf8 = Swide_to_utf8(s);
+    ptr s_scheme = Sstring_utf8(s_utf8, -1);
+    free(s_utf8);
+    S_error2("remove-registry!", "cannot remove ~a (~a)", s_scheme,
       rc == ERROR_FILE_NOT_FOUND ? Sstring("not found") :
       rc == ERROR_ACCESS_DENIED ? Sstring("insufficient permission or subkeys exist") :
       s_ErrorString(rc));
+  }
 }
 
 static IUnknown *s_CreateInstance(CLSID *pCLSID, IID *iid) {
@@ -474,3 +445,53 @@ char *S_windows_getcwd(char *buffer, int maxlen) {
   } else
     return buffer;
 }
+
+char *Swide_to_utf8(const wchar_t *arg) {
+  int len = WideCharToMultiByte(CP_UTF8, 0, arg, -1, NULL, 0, NULL, NULL);
+  if (0 == len) return NULL;
+  char* arg8 = (char*)malloc(len * sizeof(char));
+  if (0 == WideCharToMultiByte(CP_UTF8, 0, arg, -1, arg8, len, NULL, NULL)) {
+    free(arg8);
+    return NULL;
+  }
+  return arg8;
+}
+
+wchar_t *Sutf8_to_wide(const char *arg) {
+  int len = MultiByteToWideChar(CP_UTF8, 0, arg, -1, NULL, 0);
+  if (0 == len) return NULL;
+  wchar_t* argw = (wchar_t*)malloc(len * sizeof(wchar_t));
+  if (0 == MultiByteToWideChar(CP_UTF8, 0, arg, -1, argw, len)) {
+    free(argw);
+    return NULL;
+  }
+  return argw;
+}
+
+char *Sgetenv(const char *name) {
+  wchar_t* wname;
+  DWORD n;
+  wchar_t buffer[256];
+  wname = Sutf8_to_wide(name);
+  if (NULL == wname) return NULL;
+  n = GetEnvironmentVariableW(wname, buffer, 256);
+  if (n == 0) {
+    free(wname);
+    return NULL;
+  } else if (n <= 256) {
+    free(wname);
+    return Swide_to_utf8(buffer);
+  } else {
+    wchar_t* value = (wchar_t*)malloc(n * sizeof(wchar_t));
+    if (0 == GetEnvironmentVariableW(wname, value, n)) {
+      free(wname);
+      free(value);
+      return NULL;
+    } else {
+      char* result = Swide_to_utf8(value);
+      free(wname);
+      free(value);
+      return result;
+    }
+  }
+}

csug/foreign.stex

@@ -3091,6 +3091,7 @@ their C equivalents.
 \cfunction{ptr}{Sflonum}{double x}
 \cfunction{ptr}{Sstring}{const char *\var{s}}
 \cfunction{ptr}{Sstring_of_length}{const char *\var{s}, iptr \var{n}}
+\cfunction{ptr}{Sstring_utf8}{const char *\var{s}, iptr \var{n}};
 \end{flushleft}
 
 \noindent
@@ -3099,6 +3100,10 @@ their C equivalents.
 and copies the first \var{n} bytes from \var{s}
 into the new Scheme string.
 
+If the C string is encoded in UTF-8, use \scheme{Sstring_utf8}
+instead. Specify the number of bytes to convert as \var{n} or use $-1$
+to convert until the null terminator.
+
 It is possible to determine whether a C integer is within fixnum range
 by comparing the fixnum value of a fixnum created from a C integer with
 the C integer:
@@ -3202,6 +3207,27 @@ and \scheme{Smake_fxvector} are similar to their Scheme counterparts.
 \cfunction{ptr}{Smake_uninitialized_string}{iptr \var{n}}
 \end{flushleft}
 
+\parheader{Windows-specific helper functions}
+The following helper functions are provided on Windows only.
+
+\begin{flushleft}
+\cfunction{char *}{Sgetenv}{const char *\var{name}}
+\end{flushleft}
+
+\noindent
+\scheme{Sgetenv} returns the UTF-8-encoded value of UTF-8-encoded
+environment variable \var{name} if found and NULL otherwise. Call
+\scheme{free} on the returned value when it is no longer needed.
+
+\begin{flushleft}
+\cfunction{wchar_t *}{Sutf8_to_wide}{const char *\s}
+\cfunction{char *}{Swide_to_utf8}{const wchar_t *\s}
+\end{flushleft}
+
+\noindent
+\scheme{Sutf8_to_wide} and \scheme{Swide_to_utf8} convert between
+UTF-8-encoded and UTF-16LE-encoded null-terminated strings. Call
+\scheme{free} on the returned value when it is no longer needed.
 
 \parheader{Accessing top-level values}
 Top-level variable bindings may be accessed or assigned via

csug/system.stex

@@ -5036,7 +5036,7 @@ environment of the process,
 where it is available to the current process (e.g., via \var{getenv})
 and any spawned processes.
 The key and value are copied into storage allocated outside of
-the Scheme heap; this space is never reclaimed.
+the Scheme heap; this space is never reclaimed on non-Windows systems.
 
 \schemedisplay
 (putenv "SCHEME" "rocks!")

s/mkheader.ss

@@ -334,6 +334,7 @@
         (export "ptr" "Smake_uninitialized_string" "(iptr)")
         (export "ptr" "Sstring" "(const char *)")
         (export "ptr" "Sstring_of_length" "(const char *, iptr)")
+        (export "ptr" "Sstring_utf8" "(const char*, iptr)")
         (export "ptr" "Sbox" "(ptr)")
         (export "ptr" "Sinteger" "(iptr)")
         (export "ptr" "Sunsigned" "(uptr)")
@@ -388,6 +389,14 @@
           (export "int" "Sdestroy_thread" "(void)")
         )
 
+        (when-feature windows
+        (nl) (comment "Windows support.")
+          (pr "#include <wchar.h>~%")
+          (export "char *" "Sgetenv" "(const char *)")
+          (export "wchar_t *" "Sutf8_to_wide" "(const char *)")
+          (export "char *" "Swide_to_utf8" "(const wchar_t *)")
+        )
+
         (nl) (comment "Features.")
         (for-each
           (lambda (x) (pr "#define FEATURE_~@:(~a~)~%" (sanitize x)))

s/prims.ss

@@ -1755,16 +1755,16 @@
 (when-feature windows
 (define get-registry
   (let ([fp (foreign-procedure "(windows)GetRegistry"
-              (string)
+              (wstring)
               scheme-object)])
     (lambda (s)
       (unless (string? s) ($oops 'get-registry "~s is not a string" s))
       (let ([x (fp s)])
-        (and x (utf8->string x))))))
+        (and x (utf16->string x (constant native-endianness)))))))
 
 (define put-registry!
   (let ([fp (foreign-procedure "(windows)PutRegistry"
-              (string string)
+              (wstring wstring)
               void)])
     (lambda (s1 s2)
       (unless (string? s1) ($oops 'put-registry! "~s is not a string" s1))
@@ -1773,7 +1773,7 @@
 
 (define remove-registry!
   (let ([fp (foreign-procedure "(windows)RemoveRegistry"
-              (string)
+              (wstring)
               void)])
     (lambda (s)
       (unless (string? s) ($oops 'remove-registry! "~s is not a string" s))
@@ -1837,14 +1837,14 @@
                       [(fx<= b1 #x7f) ; one-byte encoding
                        (string-set! s j (integer->char b1))
                        (loop (fx+ i 1) (fx+ j 1))]
-                      [(fx<= #xc2 b1 #xdf) ; two-byte encoding
+                      [(fx<= #xc0 b1 #xdf) ; two-byte encoding
                        (if (fx< i (fx- n 1)) ; have at least two bytes?
                            (let ([b2 (bytevector-u8-ref bv (fx+ i 1))])
                              (if (fx= (fxsrl b2 6) #b10) ; second byte a continuation byte?
                                  (begin
                                    (string-set! s j
                                      (let ([x (fxlogor (fxsll (fxlogand b1 #b11111) 6) (fxlogand b2 #b111111))])
-                                       (if (fx<= x #x7f) #\x8ffd (integer->char x))))
+                                       (if (fx<= x #x7f) #\xfffd (integer->char x))))
                                    (loop (fx+ i 2) (fx+ j 1)))
                                 ; second byte is not a continuation byte
                                  (begin