diff --git a/LOG b/LOG index c211abd927..4d189a40db 100644 --- a/LOG +++ b/LOG @@ -945,4 +945,11 @@ patch-compile-0-f-t-f, patch-compile-0-t-f-f, patch-interpret-0-f-f-f, 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 \ No newline at end of file + 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 diff --git a/c/alloc.c b/c/alloc.c index f64505a3fb..84da3678ad 100644 --- a/c/alloc.c +++ b/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; diff --git a/c/externs.h b/c/externs.h index 78f0f2ab73..692712e357 100644 --- a/c/externs.h +++ b/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); diff --git a/c/fasl.c b/c/fasl.c index e24934d4d7..c659c69ec2 100644 --- a/c/fasl.c +++ b/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); diff --git a/c/foreign.c b/c/foreign.c index 7f9b669c6d..9b9f11f2e8 100644 --- a/c/foreign.c +++ b/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_string(dlerror(), -1)); + S_error2("", "(while loading ~a) ~a", Sstring_utf8(path, -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; } diff --git a/c/io.c b/c/io.c index 8765e6537a..34887a641e 100644 --- a/c/io.c +++ b/c/io.c @@ -20,6 +20,8 @@ #include #ifdef WIN32 #include +#include +#pragma comment(lib, "shell32.lib") #else /* WIN32 */ #include #include @@ -41,17 +43,23 @@ 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; - - if ((homedrive = getenv("HOMEDRIVE")) != NULL && (homepath = getenv("HOMEPATH")) != NULL) { - n1 = strlen(homedrive); - n2 = strlen(homepath); - n3 = strlen(ip) + 1; - if ((outpath = malloc(n1 + n2 + n3)) == NULL) S_error("expand_pathname", "malloc failed"); - memcpy(outpath, homedrive, n1); - memcpy(outpath + n1, homepath, n2); - memcpy(outpath + n1 + n2, ip, n3); - return outpath; + wchar_t* homew; + if (SUCCEEDED(SHGetKnownFolderPath(&FOLDERID_Profile, 0, NULL, &homew))) { + char *home = Swide_to_utf8(homew); + CoTaskMemFree(homew); + if (NULL != home) { + size_t n1, n2; + n1 = strlen(home); + n2 = strlen(ip) + 1; + if ((outpath = malloc(n1 + n2)) == NULL) { + free(home); + S_error("expand_pathname", "malloc failed"); + } + memcpy(outpath, home, n1); + memcpy(outpath + n1, ip, n2); + free(home); + return outpath; + } } } #else /* WIN32 */ @@ -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; - - 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; - } + char *path = S_malloc_pathname(inpath); + wchar_t *wpath = Sutf8_to_wide(path); free(path); return wpath; } diff --git a/c/main.c b/c/main.c index 8e697178bf..080cbb5cb6 100644 --- a/c/main.c +++ b/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 #include #include @@ -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) { - CALL1("library-directories", Sstring(libdirs)); + if (libdirs == 0) { + char *cslibdirs = GETENV("CHEZSCHEMELIBDIRS"); + if (cslibdirs != 0) { + CALL1("library-directories", Sstring_utf8(cslibdirs, -1)); + GETENV_FREE(cslibdirs); + } + } else { + CALL1("library-directories", Sstring_utf8(libdirs, -1)); } - if (libexts == 0) libexts = getenv("CHEZSCHEMELIBEXTS"); - if (libexts != 0) { - 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); diff --git a/c/prim5.c b/c/prim5.c index 69c6bfdfa6..bb40e6277b 100644 --- a/c/prim5.c +++ b/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,14 +656,12 @@ static ptr s_process(s, stderrp) char *s; IBOOL stderrp; { CloseHandle(hToWrite); S_error("process", "cannot open pipes"); } - if (stderrp) { - if (!CreatePipe(&hFromReadErr, &hFromWriteErr, NULL, 0)) { - CloseHandle(hToRead); - CloseHandle(hToWrite); - CloseHandle(hFromRead); - CloseHandle(hFromWrite); - S_error("process", "cannot open pipes"); - } + if (stderrp && !CreatePipe(&hFromReadErr, &hFromWriteErr, NULL, 0)) { + CloseHandle(hToRead); + CloseHandle(hToWrite); + CloseHandle(hFromRead); + CloseHandle(hFromWrite); + S_error("process", "cannot open pipes"); } si.cb = sizeof(STARTUPINFO); @@ -701,13 +715,16 @@ static ptr s_process(s, stderrp) char *s; IBOOL stderrp; { si.hStdError = si.hStdOutput; } - if ((comspec = getenv("COMSPEC"))) { - size_t n = strlen(comspec) + strlen(s) + 5; + if ((comspec = Sgetenv("COMSPEC"))) { + 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 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; + char *s = Sgetenv(name); #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()); - } -#endif /* WIN32 */ +#else /* 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"); - if (h == NULL) h = LoadLibrary("libiconv.dll"); - if (h == NULL) h = LoadLibrary("libiconv-2.dll"); - if (h == NULL) h = LoadLibrary(".\\iconv.dll"); - if (h == NULL) h = LoadLibrary(".\\libiconv.dll"); - if (h == NULL) h = LoadLibrary(".\\libiconv-2.dll"); + HMODULE h = LoadLibraryW(L"iconv.dll"); + if (h == NULL) h = LoadLibraryW(L"libiconv.dll"); + if (h == NULL) h = LoadLibraryW(L"libiconv-2.dll"); + if (h == NULL) h = LoadLibraryW(L".\\iconv.dll"); + if (h == NULL) h = LoadLibraryW(L".\\libiconv.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) { - const char prefix[] = "cannot find iconv_open or libiconv_open in "; - 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_open_f = (iconv_open_ft)GetProcAddress(h, "libiconv_open")) == NULL) + return s_iconv_trouble(h, "iconv_open or libiconv_open"); if ((iconv_f = (iconv_ft)GetProcAddress(h, "iconv")) == NULL && - (iconv_f = (iconv_ft)GetProcAddress(h, "libiconv")) == NULL) { - const char prefix[] = "cannot find iconv or libiconv in "; - 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_f = (iconv_ft)GetProcAddress(h, "libiconv")) == NULL) + return s_iconv_trouble(h, "iconv or libiconv"); if ((iconv_close_f = (iconv_close_ft)GetProcAddress(h, "iconv_close")) == NULL && - (iconv_close_f = (iconv_close_ft)GetProcAddress(h, "libiconv_close")) == NULL) { - const char prefix[] = "cannot find iconv_close or libiconv_close in "; - 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_close_f = (iconv_close_ft)GetProcAddress(h, "libiconv_close")) == NULL) + return s_iconv_trouble(h, "iconv_close or libiconv_close"); iconv_is_loaded = 1; } #endif /* WIN32 */ diff --git a/c/scheme.c b/c/scheme.c index e54bb64c03..15a10dfca4 100644 --- a/c/scheme.c +++ b/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]; - char key[PATH_MAX]; - snprintf(key, PATH_MAX, "HKEY_LOCAL_MACHINE\\Software\\Chez Scheme\\csv%s\\HeapSearchPath", VERSION); - result = S_GetRegistry(defaultheapdirs, SEARCHPATHMAXSIZE, key); - if (result == NULL) result = DEFAULT_HEAP_PATH; - return result; + wchar_t buf[PATH_MAX]; + DWORD len = sizeof(buf); + if (ERROR_SUCCESS != RegGetValueW(HKEY_LOCAL_MACHINE, L"Software\\Chez Scheme\\csv" VERSION, L"HeapSearchPath", RRF_RT_REG_SZ, NULL, buf, &len)) + return 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); diff --git a/c/schlib.c b/c/schlib.c index f9ea4b6ad4..23ea47dcbf 100644 --- a/c/schlib.c +++ b/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 */ diff --git a/c/schsig.c b/c/schsig.c index fd112eeb87..00d7cce4c1 100644 --- a/c/schsig.c +++ b/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(S_string(s, -1), args))); + Scons((strlen(who) == 0 ? Sfalse : Sstring_utf8(who,-1)), + Scons(Sstring_utf8(s, -1), args))); #ifdef PTHREADS while (S_tc_mutex_depth > 0) { diff --git a/c/stats.c b/c/stats.c index 0e0eb6c8af..4e3ee139b0 100644 --- a/c/stats.c +++ b/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; - int len; + wchar_t *w_tzname; /* 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); - tz_name = S_string(NULL, len); - while (len--) - Sstring_set(tz_name, len, w_tzname[len]); + char *name = Swide_to_utf8(w_tzname); + tz_name = Sstring_utf8(name, -1); + free(name); } } #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) diff --git a/c/system.h b/c/system.h index 57df4c91e6..565155aacf 100644 --- a/c/system.h +++ b/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 #endif diff --git a/c/version.h b/c/version.h index 7be60a1212..ad9ac5c4c7 100644 --- a/c/version.h +++ b/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 diff --git a/c/windows.c b/c/windows.c index f8e31e0286..53c4b2c9d8 100644 --- a/c/windows.c +++ b/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 void s_PutRegistry(char *s, char *val); -static void s_RemoveRegistry(char *s); +static ptr s_GetRegistry(wchar_t *s); +static void s_PutRegistry(wchar_t *s, wchar_t *val); +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) { - while (n > 0) { - 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; +static void SplitRegistryKey(char *who, wchar_t *wholekey, HKEY *key, wchar_t **subkey, wchar_t **last) { + wchar_t 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 - S_error1(who, "invalid registry key ~s", Sstring(wholekey)); + } else { + 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. - * 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) { +static ptr s_GetRegistry(wchar_t *s) { HKEY key, result; - char *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; + wchar_t *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 */ - if ((type == REG_SZ) || (type == REG_EXPAND_SZ)) - BYTEVECTOR_TYPE(ans) = ((size-1) << bytevector_length_offset) | type_bytevector; + /* discard unwanted terminating null character, if present */ + if (((type == REG_SZ) || (type == REG_EXPAND_SZ)) && + (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; - DWORD rc, qrc, type, size; + wchar_t *subkey, *last; + 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 */ } - /* lookup type for key (if it exists), if not assume REG_SZ */ if (rc == ERROR_SUCCESS) { - qrc = RegQueryValueEx(result, last, NULL, &type, NULL, &size); - if (qrc != ERROR_SUCCESS) type = REG_SZ; - } + /* lookup type for key (if it exists), if not assume REG_SZ */ + if (ERROR_SUCCESS != RegQueryValueExW(result, last, NULL, &type, NULL, NULL)) + 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) - S_error2("put-registry!", "cannot set ~a (~a)", Sstring(s), + if (rc != ERROR_SUCCESS) { + 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) - S_error2("remove-registry!", "cannot remove ~a (~a)", Sstring(s), + if (rc != ERROR_SUCCESS) { + 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; + } + } +} diff --git a/csug/foreign.stex b/csug/foreign.stex index 2f6b088784..62d95e8004 100644 --- a/csug/foreign.stex +++ b/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 diff --git a/csug/system.stex b/csug/system.stex index 38595dd7e5..05dd601523 100644 --- a/csug/system.stex +++ b/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!") diff --git a/s/mkheader.ss b/s/mkheader.ss index 30f96ed9e0..7da1e17211 100644 --- a/s/mkheader.ss +++ b/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 ~%") + (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))) diff --git a/s/prims.ss b/s/prims.ss index 9728743ef6..0eecffa15e 100644 --- a/s/prims.ss +++ b/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