suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
original commit: aa1c2c4ec95c286a12730ea75588a18dd9fb9d59
This commit is contained in:
Bob Burger 2018-06-14 12:07:37 -04:00
parent 5501a81a31
commit 8885445d6d
19 changed files with 490 additions and 263 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
LOG
View File

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

119
c/alloc.c
View File

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

1
c/externs.h
View File

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

2
c/fasl.c
View File

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

8
c/foreign.c
View File

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

50
c/io.c
View File

@ -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,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;
}

46
c/main.c
View File

@ -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) {
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);

172
c/prim5.c
View File

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

52
c/scheme.c
View File

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

2
c/schlib.c
View File

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

4
c/schsig.c
View File

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

16
c/stats.c
View File

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

2
c/system.h
View File

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

4
c/version.h
View File

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

217
c/windows.c
View File

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

26
csug/foreign.stex
View File

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

2
csug/system.stex
View File

@ -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!")

9
s/mkheader.ss
View File

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

12
s/prims.ss
View File

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