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

- eliminated a couple of thread-safety issues and limitations on the

Browse Source 
sizes of pathnames produced by expansion of tilde (home-directory)
  prefixes by replacing S_pathname, S_pathname_impl, and S_homedir
  with S_malloc_pathname, which always mallocs space for the result.
  one thread-safety issue involved the use of static strings for expanded
  pathnames and affected various file-system operations.  the other
  affected the file open routines and involved use of the incoming
  pathname while deactivated.  the incoming pathname is sometimes if not
  always a pointer into a Scheme bytevector, which can be overwritten if a
  collection occurs while the thread is deactivated.  the size limitation
  corresponded to the use of the static strings, which were limited to
  PATH_MAX bytes.  (PATH_MAX typically isn't actually the maximum path
  length in contemporary operating systems.)  eliminated similar issues
  for wide pathnames under Windows by adding S_malloc_wide_pathname.
  consumers of the old routines have been modified to use the new
  routines and to free the result strings.  the various file operations
  now consistently treat a pathname with an unresolvable home directory
  as a pathname that happens to start with a tilde.  eliminated unused
  foreign-symbol binding of "(cs)pathname" to S_pathname.
    io.c, externs.h, new_io.c, prim5.c, scheme.c, prim.c
- various places where a call to close or gzclose was retried when
  the close operation was interrupted no longer do so, since this can
  cause problems when another thread has reallocated the same file
  descriptor.
    new_io.c
- now using vcvarsall type x86_amd64 rather than amd64 when the
  former appears to supported and the latter does not, as is the
  case with VS Express 2015.
    c/Mf-a6nt, c/Mf-ta6nt
- commented out one of the thread mats that consistently causes
  indefinite delays under Windows and OpenBSD due to starvation.
    thread.ms
- increased wait time for a couple of subprocess responses
    6.ms
- added call to collector to close files opened during iconv mats
  specifically for when mats are run under Windows with no iconv dll.
    io.ms

original commit: ad44924307c576eb2fc92e7958afe8b615a7f48b
This commit is contained in:
dybvig 2016-06-16 23:04:32 -04:00
parent 8d28c6afb9
commit b4d452cc71
12 changed files with 455 additions and 289 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
LOG
View File

@ -209,3 +209,40 @@
c/Mf.*nt c/Mf.*nt
- fixed unnessesary blocking in expeditor on Windows. - fixed unnessesary blocking in expeditor on Windows.
c/expeditor.c c/expeditor.c
- eliminated a couple of thread-safety issues and limitations on the
sizes of pathnames produced by expansion of tilde (home-directory)
prefixes by replacing S_pathname, S_pathname_impl, and S_homedir
with S_malloc_pathname, which always mallocs space for the result.
one thread-safety issue involved the use of static strings for expanded
pathnames and affected various file-system operations. the other
affected the file open routines and involved use of the incoming
pathname while deactivated. the incoming pathname is sometimes if not
always a pointer into a Scheme bytevector, which can be overwritten if a
collection occurs while the thread is deactivated. the size limitation
corresponded to the use of the static strings, which were limited to
PATH_MAX bytes. (PATH_MAX typically isn't actually the maximum path
length in contemporary operating systems.) eliminated similar issues
for wide pathnames under Windows by adding S_malloc_wide_pathname.
consumers of the old routines have been modified to use the new
routines and to free the result strings. the various file operations
now consistently treat a pathname with an unresolvable home directory
as a pathname that happens to start with a tilde. eliminated unused
foreign-symbol binding of "(cs)pathname" to S_pathname.
io.c, externs.h, new_io.c, prim5.c, scheme.c, prim.c
- various places where a call to close or gzclose was retried when
the close operation was interrupted no longer do so, since this can
cause problems when another thread has reallocated the same file
descriptor.
new_io.c
- now using vcvarsall type x86_amd64 rather than amd64 when the
former appears to supported and the latter does not, as is the
case with VS Express 2015.
c/Mf-a6nt, c/Mf-ta6nt
- commented out one of the thread mats that consistently causes
indefinite delays under Windows and OpenBSD due to starvation.
thread.ms
- increased wait time for a couple of subprocess responses
6.ms
- added call to collector to close files opened during iconv mats
specifically for when mats are run under Windows with no iconv dll.
io.ms

5
c/Mf-a6nt
View File

@ -37,7 +37,10 @@ vs.bat:
echo 'set INCLUDE=' >> $@ echo 'set INCLUDE=' >> $@
echo 'set LIB=' >> $@ echo 'set LIB=' >> $@
echo 'set LIBPATH=' >> $@ echo 'set LIBPATH=' >> $@
echo 'call "%VS140COMNTOOLS%..\..\VC\vcvarsall.bat" amd64' >> $@ echo 'set MACHINETYPE=amd64' >> $@
echo 'if exist "%VS140COMNTOOLS%..\..\VC\bin\x86_amd64\vcvarsx86_amd64.bat" set MACHINETYPE=x86_amd64' >> $@
echo 'if exist "%VS140COMNTOOLS%..\..\VC\bin\vcvars64.bat" set MACHINETYPE=amd64' >> $@
echo 'call "%VS140COMNTOOLS%..\..\VC\vcvarsall.bat" %MACHINETYPE%' >> $@
echo '%*' >> $@ echo '%*' >> $@
chmod +x $@ chmod +x $@

5
c/Mf-ta6nt
View File

@ -37,7 +37,10 @@ vs.bat:
echo 'set INCLUDE=' >> $@ echo 'set INCLUDE=' >> $@
echo 'set LIB=' >> $@ echo 'set LIB=' >> $@
echo 'set LIBPATH=' >> $@ echo 'set LIBPATH=' >> $@
echo 'call "%VS140COMNTOOLS%..\..\VC\vcvarsall.bat" amd64' >> $@ echo 'set MACHINETYPE=amd64' >> $@
echo 'if exist "%VS140COMNTOOLS%..\..\VC\bin\x86_amd64\vcvarsx86_amd64.bat" set MACHINETYPE=x86_amd64' >> $@
echo 'if exist "%VS140COMNTOOLS%..\..\VC\bin\vcvars64.bat" set MACHINETYPE=amd64' >> $@
echo 'call "%VS140COMNTOOLS%..\..\VC\vcvarsall.bat" %MACHINETYPE%' >> $@
echo '%*' >> $@ echo '%*' >> $@
chmod +x $@ chmod +x $@

20
c/externs.h
View File

@ -149,20 +149,20 @@ extern void S_intern_gensym PROTO((ptr g));
extern void S_retrofit_nonprocedure_code PROTO((void)); extern void S_retrofit_nonprocedure_code PROTO((void));
/* io.c */ /* io.c */
extern IBOOL S_file_existsp PROTO((const char *path, IBOOL followp)); extern IBOOL S_file_existsp PROTO((const char *inpath, IBOOL followp));
extern IBOOL S_file_regularp PROTO((const char *path, IBOOL followp)); extern IBOOL S_file_regularp PROTO((const char *inpath, IBOOL followp));
extern IBOOL S_file_directoryp PROTO((const char *path, IBOOL followp)); extern IBOOL S_file_directoryp PROTO((const char *inpath, IBOOL followp));
extern IBOOL S_file_symbolic_linkp PROTO((const char *path)); extern IBOOL S_file_symbolic_linkp PROTO((const char *inpath));
extern const char *S_pathname_impl PROTO((const char *inpath, char *buffer));
#ifdef WIN32 #ifdef WIN32
extern ptr S_find_files PROTO((const char *wildpath)); extern ptr S_find_files PROTO((const char *wildpath));
#else #else
extern ptr S_directory_list PROTO((const char *path)); extern ptr S_directory_list PROTO((const char *inpath));
#endif #endif
extern const char *S_homedir PROTO((void)); extern char *S_malloc_pathname PROTO((const char *inpath));
extern const char *S_pathname PROTO((const char *who, const char *inpath, IBOOL errorp, char *buf)); #ifdef WIN32
extern IBOOL S_fixedpathp PROTO((const char *p)); extern wchar_t *S_malloc_wide_pathname PROTO((const char *inpath));
#endif
extern IBOOL S_fixedpathp PROTO((const char *inpath));
/* new-io.c */ /* new-io.c */
extern INT S_gzxfile_fd PROTO((ptr x)); extern INT S_gzxfile_fd PROTO((ptr x));

301
c/io.c
View File

@ -33,172 +33,195 @@ static ptr s_wstring_to_bytevector PROTO((const wchar_t *s));
static ptr s_string_to_bytevector PROTO((const char *s)); static ptr s_string_to_bytevector PROTO((const char *s));
#endif #endif
/* raises an exception if insufficient space cannot be malloc'd.
otherwise returns a freshly allocated version of inpath with ~ (home directory)
prefix expanded, if possible */
char *S_malloc_pathname(const char *inpath) {
char *outpath; const char *ip;
#ifdef WIN32 #ifdef WIN32
/* Warning: returns pointer to static string */ if (*inpath == '~' && (*(ip = inpath + 1) == 0 || DIRMARKERP(*ip))) {
const char *S_homedir() { const char *homedrive, *homepath; size_t n1, n2, n3;
static char home[PATH_MAX];
const char *homedrive = getenv("HOMEDRIVE");
const char *homepath = getenv("HOMEPATH");
if (snprintf(home, PATH_MAX, "%s%s", homedrive, homepath) < PATH_MAX) return home; if ((homedrive = getenv("HOMEDRIVE")) != NULL && (homepath = getenv("HOMEPATH")) != NULL) {
return NULL; n1 = strlen(homedrive);
} n2 = strlen(homepath);
#else n3 = strlen(ip) + 1;
/* Warning: returns pointer to static string */ if ((outpath = malloc(n1 + n2 + n3)) == NULL) S_error("expand_pathname", "malloc failed");
const char *S_homedir() { memcpy(outpath, homedrive, n1);
const char *home; memcpy(outpath + n1, homepath, n2);
static struct passwd *pwent; memcpy(outpath + n1 + n2, ip, n3);
return outpath;
if ((home = getenv("HOME"))) return home;
if ((pwent = getpwuid(getuid()))) return pwent->pw_dir;
return NULL;
}
#endif
const char *S_pathname_impl(const char *inpath, char *buffer) {
if (*inpath != '~') { return inpath; }
else {
#define setp(c) if (p > buffer + PATH_MAX) return NULL; else *p++ = (c)
static char path[PATH_MAX];
char *p;
const char *ip, *dir;
if (buffer == NULL) buffer = path;
ip = inpath + 1;
if (*ip == 0 || DIRMARKERP(*ip)) {
if (!(dir = S_homedir())) return NULL;
} else {
#ifdef WIN32
return inpath;
#else
struct passwd *pwent;
p = buffer;
while (*ip != 0 && !DIRMARKERP(*ip)) setp(*ip++);
setp(0);
if (!(pwent = getpwnam(buffer)) || !(dir = pwent->pw_dir))
return NULL;
#endif /* WIN32 */
} }
}
#else /* WIN32 */
if (*inpath == '~') {
const char *dir; size_t n1, n2; struct passwd *pwent;
if (*(ip = inpath + 1) == 0 || DIRMARKERP(*ip)) {
if ((dir = getenv("HOME")) == NULL)
if ((pwent = getpwuid(getuid())) != NULL)
dir = pwent->pw_dir;
} else {
char *userbuf; const char *user_start = ip;
do { ip += 1; } while (*ip != 0 && !DIRMARKERP(*ip));
if ((userbuf = malloc(ip - user_start + 1)) == NULL) S_error("expand_pathname", "malloc failed");
memcpy(userbuf, user_start, ip - user_start);
userbuf[ip - user_start] = 0;
dir = (pwent = getpwnam(userbuf)) != NULL ? pwent->pw_dir : NULL;
free(userbuf);
}
if (dir != NULL) {
n1 = strlen(dir);
n2 = strlen(ip) + 1;
if ((outpath = malloc(n1 + n2)) == NULL) S_error("expand_pathname", "malloc failed");
memcpy(outpath, dir, n1);
memcpy(outpath + n1, ip, n2);
return outpath;
}
}
#endif /* WIN32 */
p = buffer; /* if no ~ or tilde dir can't be found, copy inpath */
while (*dir != 0) setp(*dir++); {
while (*ip != 0) setp(*ip++); size_t n = strlen(inpath) + 1;
setp(0); outpath = (char *)malloc(n);
return buffer; memcpy(outpath, inpath, n);
#undef setp return outpath;
} }
} }
/* Warning: may return pointer to static string */
const char *S_pathname(const char *who, const char *inpath,
IBOOL errorp, char *buffer) {
const char *path = S_pathname_impl(inpath, buffer);
if (path != NULL) return path;
if (errorp) S_error1(who, "unable to expand path name ~s", Sstring(inpath));
return inpath;
}
IBOOL S_fixedpathp(p) const char *p; {
char c;
p = S_pathname("", p, 0, (char *)0);
if ((c = *p) == 0 || DIRMARKERP(c)) return 1;
if (c == '.')
return (c = *++p) == 0
|| DIRMARKERP(c)
|| (c == '.' && ((c = *++p) == 0 || DIRMARKERP(c)));
#ifdef WIN32 #ifdef WIN32
if (*++p == ':') return c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z'; /* 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;
}
free(path);
return wpath;
}
#endif #endif
return 0;
IBOOL S_fixedpathp(inpath) const char *inpath; {
char c; IBOOL res; char *path;
path = S_malloc_pathname(inpath);
res = (c = *path) == 0
|| DIRMARKERP(c)
#ifdef WIN32
|| ((*(path + 1) == ':') && (c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z'))
#endif
|| ((c == '.')
&& ((c = *(path + 1)) == 0
|| DIRMARKERP(c)
|| (c == '.' && ((c = *(path + 2)) == 0 || DIRMARKERP(c)))));
free(path);
return res;
} }
IBOOL S_file_existsp(path, followp) const char *path; IBOOL followp; { IBOOL S_file_existsp(inpath, followp) const char *inpath; IBOOL followp; {
#ifdef WIN32 #ifdef WIN32
wchar_t wpath[PATH_MAX]; wchar_t *wpath; IBOOL res;
WIN32_FILE_ATTRIBUTE_DATA filedata; WIN32_FILE_ATTRIBUTE_DATA filedata;
path = S_pathname("file-exists?", path, 1, (char *)0); if ((wpath = S_malloc_wide_pathname(inpath)) == NULL) {
if (MultiByteToWideChar(CP_UTF8,0,path,-1,wpath,PATH_MAX) == 0)
return 0; return 0;
} else {
return GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata); res = GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata);
free(wpath);
return res;
}
#else /* WIN32 */ #else /* WIN32 */
struct STATBUF statbuf; struct STATBUF statbuf; char *path; IBOOL res;
const char *expandedpath = S_pathname("file-exists?", path, 0, (char *)0);
return (followp ? path = S_malloc_pathname(inpath);
STAT(expandedpath, &statbuf) : res = (followp ? STAT(path, &statbuf) : LSTAT(path, &statbuf)) == 0;
LSTAT(expandedpath, &statbuf)) == 0; free(path);
return res;
#endif /* WIN32 */ #endif /* WIN32 */
} }
IBOOL S_file_regularp(path, followp) const char *path; IBOOL followp; { IBOOL S_file_regularp(inpath, followp) const char *inpath; IBOOL followp; {
#ifdef WIN32 #ifdef WIN32
wchar_t wpath[PATH_MAX]; wchar_t *wpath; IBOOL res;
WIN32_FILE_ATTRIBUTE_DATA filedata; WIN32_FILE_ATTRIBUTE_DATA filedata;
path = S_pathname("file-regular?", path, 1, (char *)0); if ((wpath = S_malloc_wide_pathname(inpath)) == NULL) {
if (MultiByteToWideChar(CP_UTF8,0,path,-1,wpath,PATH_MAX) == 0)
return 0; return 0;
if (!GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata)) } else {
return 0; res = GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata)
&& (filedata.dwFileAttributes & (FILE_ATTRIBUTE_DEVICE | FILE_ATTRIBUTE_DIRECTORY | FILE_ATTRIBUTE_REPARSE_POINT)) == 0;
return (filedata.dwFileAttributes & (FILE_ATTRIBUTE_DEVICE | FILE_ATTRIBUTE_DIRECTORY | FILE_ATTRIBUTE_REPARSE_POINT)) == 0; free(wpath);
return res;
}
#else /* WIN32 */ #else /* WIN32 */
struct STATBUF statbuf; struct STATBUF statbuf; char *path; IBOOL res;
const char *expandedpath = S_pathname("file-regular?", path, 0, (char *)0);
return (followp ? path = S_malloc_pathname(inpath);
STAT(expandedpath, &statbuf) : res = (followp ? STAT(path, &statbuf) : LSTAT(path, &statbuf)) == 0
LSTAT(expandedpath, &statbuf)) == 0 && (statbuf.st_mode & S_IFMT) == S_IFREG;
&& (statbuf.st_mode & S_IFMT) == S_IFREG; free(path);
return res;
#endif /* WIN32 */ #endif /* WIN32 */
} }
IBOOL S_file_directoryp(path, followp) const char *path; IBOOL followp; { IBOOL S_file_directoryp(inpath, followp) const char *inpath; IBOOL followp; {
#ifdef WIN32 #ifdef WIN32
wchar_t wpath[PATH_MAX]; wchar_t *wpath; IBOOL res;
WIN32_FILE_ATTRIBUTE_DATA filedata; WIN32_FILE_ATTRIBUTE_DATA filedata;
path = S_pathname("file-directory?", path, 1, (char *)0); if ((wpath = S_malloc_wide_pathname(inpath)) == NULL) {
if (MultiByteToWideChar(CP_UTF8,0,path,-1,wpath,PATH_MAX) == 0)
return 0; return 0;
if (!GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata)) } else {
return 0; res = GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata)
&& filedata.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY;
return filedata.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY; free(wpath);
return res;
}
#else /* WIN32 */ #else /* WIN32 */
struct STATBUF statbuf; struct STATBUF statbuf; char *path; IBOOL res;
const char *expandedpath = S_pathname("file-directory?", path, 0, (char *)0);
return (followp ? path = S_malloc_pathname(inpath);
STAT(expandedpath, &statbuf) : res = (followp ? STAT(path, &statbuf) : LSTAT(path, &statbuf)) == 0
LSTAT(expandedpath, &statbuf)) == 0 && (statbuf.st_mode & S_IFMT) == S_IFDIR;
&& (statbuf.st_mode & S_IFMT) == S_IFDIR; free(path);
return res;
#endif /* WIN32 */ #endif /* WIN32 */
} }
IBOOL S_file_symbolic_linkp(const char *path) { IBOOL S_file_symbolic_linkp(const char *inpath) {
#ifdef WIN32 #ifdef WIN32
wchar_t wpath[PATH_MAX]; wchar_t *wpath; IBOOL res;
WIN32_FILE_ATTRIBUTE_DATA filedata; WIN32_FILE_ATTRIBUTE_DATA filedata;
path = S_pathname("file-symbolic-link?", path, 1, (char *)0); if ((wpath = S_malloc_wide_pathname(inpath)) == NULL) {
if (MultiByteToWideChar(CP_UTF8,0,path,-1,wpath,PATH_MAX) == 0)
return 0; return 0;
if (!GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata)) } else {
return 0; res = GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata)
&& filedata.dwFileAttributes & FILE_ATTRIBUTE_REPARSE_POINT;
return filedata.dwFileAttributes & FILE_ATTRIBUTE_REPARSE_POINT; free(wpath);
return res;
}
#else /* WIN32 */ #else /* WIN32 */
struct STATBUF statbuf; struct STATBUF statbuf; char *path; IBOOL res;
const char *expandedpath = S_pathname("file-symbolic-link?", path, 0, (char *)0);
return (LSTAT(expandedpath, &statbuf) == 0) path = S_malloc_pathname(inpath);
&& (statbuf.st_mode & S_IFMT) == S_IFLNK; res = LSTAT(path, &statbuf) == 0 && (statbuf.st_mode & S_IFMT) == S_IFLNK;
free(path);
return res;
#endif /* WIN32 */ #endif /* WIN32 */
} }
@ -213,22 +236,23 @@ static ptr s_wstring_to_bytevector(const wchar_t *s) {
} }
ptr S_find_files(const char *wildpath) { ptr S_find_files(const char *wildpath) {
wchar_t wwildpath[PATH_MAX]; wchar_t *wwildpath;
intptr_t handle; intptr_t handle;
struct _wfinddata_t fileinfo; struct _wfinddata_t fileinfo;
wildpath = S_pathname("directory-list", wildpath, 1, (char *)0); if ((wwildpath = S_malloc_wide_pathname(wildpath)) == NULL)
if (MultiByteToWideChar(CP_UTF8,0,wildpath,-1,wwildpath,PATH_MAX) == 0)
return S_LastErrorString(); return S_LastErrorString();
if ((handle = _wfindfirst(wwildpath, &fileinfo)) == (intptr_t)-1) if ((handle = _wfindfirst(wwildpath, &fileinfo)) == (intptr_t)-1) {
free(wwildpath);
return S_strerror(errno); return S_strerror(errno);
else { } else {
ptr ls = Snil; ptr ls = Snil;
do { do {
ls = Scons(s_wstring_to_bytevector(fileinfo.name), ls); ls = Scons(s_wstring_to_bytevector(fileinfo.name), ls);
} while (_wfindnext(handle, &fileinfo) == 0); } while (_wfindnext(handle, &fileinfo) == 0);
_findclose(handle); _findclose(handle);
free(wwildpath);
return ls; return ls;
} }
} }
@ -241,18 +265,21 @@ static ptr s_string_to_bytevector(const char *s) {
return bv; return bv;
} }
ptr S_directory_list(const char *path) { ptr S_directory_list(const char *inpath) {
DIR *dirp; struct dirent *dep; ptr ls = Snil; char *path; DIR *dirp;
path = S_pathname("directory-list", path, 1, (char *)0); path = S_malloc_pathname(inpath);
if ((dirp = opendir(path)) == (DIR *)0) {
if ((dirp = opendir(path)) == (DIR *)0) free(path);
return S_strerror(errno); return S_strerror(errno);
} else {
struct dirent *dep; ptr ls = Snil;
while ((dep = readdir(dirp)) != (struct dirent *)0) while ((dep = readdir(dirp)) != (struct dirent *)0)
ls = Scons(s_string_to_bytevector(dep->d_name), ls); ls = Scons(s_string_to_bytevector(dep->d_name), ls);
closedir(dirp);
closedir(dirp); free(path);
return ls; return ls;
}
} }
#endif /* WIN32 */ #endif /* WIN32 */

80
c/new-io.c
View File

@ -56,14 +56,36 @@ static INT lockfile PROTO((INT fd));
static ptr make_gzxfile PROTO((int fd, gzFile file)); static ptr make_gzxfile PROTO((int fd, gzFile file));
/* /*
check: whether you want gzerror to be called on fd not_ok_is_fatal: !ok definitely implies error, so ignore gzerror
(i.e. whether to double check if errors reported by 'ok' are real)
ok: whether the result of body seems to be ok ok: whether the result of body seems to be ok
flag: will be set when an error is detected and cleared if no error flag: will be set when an error is detected and cleared if no error
fd: the gzFile object to call gzerror on fd: the gzFile object to call gzerror on
body: the operation we are checking the error on body: the operation we are checking the error on
*/ */
#ifdef EINTR #ifdef EINTR
/* like FD_EINTR_GUARD and GZ_EINTR_GUARD but ignores EINTR.
used for calls to close so we don't close a file descriptor that
might already have been reallocated by a different thread */
#define FD_GUARD(ok,flag,body) \
do { body; \
flag = !(ok) && errno != EINTR; \
} while (0)
#define GZ_GUARD(not_ok_is_fatal,ok,flag,fd,body) \
do { body; \
if (ok) { flag = 0; } \
else { \
INT errnum; \
gzerror((fd),&errnum); \
gzclearerr((fd)); \
if (errnum == Z_ERRNO) { \
flag = errno != EINTR; \
} else { \
flag = not_ok_is_fatal || errnum != Z_OK; \
errno = 0; \
} \
} \
} while (0)
/* like FD_GUARD and GZ_GUARD but spins on EINTR */
#define FD_EINTR_GUARD(ok,flag,body) \ #define FD_EINTR_GUARD(ok,flag,body) \
do { body; \ do { body; \
if (ok) { flag = 0; break; } \ if (ok) { flag = 0; break; } \
@ -86,8 +108,8 @@ static ptr make_gzxfile PROTO((int fd, gzFile file));
} \ } \
} while (1) } while (1)
#else /* EINTR */ #else /* EINTR */
#define FD_EINTR_GUARD(ok,flag,body) do { body; flag = !(ok); } while (0) #define FD_GUARD(ok,flag,body) do { body; flag = !(ok); } while (0)
#define GZ_EINTR_GUARD(not_ok_is_fatal,ok,flag,fd,body) \ #define GZ_GUARD(not_ok_is_fatal,ok,flag,fd,body) \
do { body; \ do { body; \
if (ok) { flag = 0; } \ if (ok) { flag = 0; } \
else { \ else { \
@ -101,6 +123,8 @@ static ptr make_gzxfile PROTO((int fd, gzFile file));
} \ } \
} \ } \
} while (0) } while (0)
#define FD_EINTR_GUARD FD_GUARD
#define GZ_EINTR_GUARD GZ_GUARD
#endif /* EINTR */ #endif /* EINTR */
#ifndef O_BINARY #ifndef O_BINARY
@ -140,7 +164,8 @@ gzFile S_gzxfile_gzfile(ptr x) {
return gzxfile_gzfile(x); return gzxfile_gzfile(x);
} }
ptr S_new_open_input_fd(const char *filename, IBOOL compressed) { ptr S_new_open_input_fd(const char *infilename, IBOOL compressed) {
char *filename;
INT saved_errno = 0; INT saved_errno = 0;
INT fd, dupfd, error, result, ok, flag; INT fd, dupfd, error, result, ok, flag;
gzFile file; gzFile file;
@ -148,15 +173,17 @@ ptr S_new_open_input_fd(const char *filename, IBOOL compressed) {
ptr tc = get_thread_context(); ptr tc = get_thread_context();
#endif #endif
if ((filename = S_pathname_impl(filename, NULL)) == NULL) { filename = S_malloc_pathname(infilename);
return Scons(FIX(OPEN_ERROR_OTHER), Sstring("failed to expand path name"));
}
/* NB: don't use infilename, which might point into a Scheme string, after this point */
DEACTIVATE(tc) DEACTIVATE(tc)
FD_EINTR_GUARD(fd>=0, error, fd=OPEN(filename,O_BINARY|O_RDONLY,0)); FD_EINTR_GUARD(fd>=0, error, fd=OPEN(filename,O_BINARY|O_RDONLY,0));
saved_errno = errno; saved_errno = errno;
REACTIVATE(tc) REACTIVATE(tc)
/* NB: don't use free'd filename after this point */
free(filename);
if (error) { if (error) {
ptr str = S_strerror(saved_errno); ptr str = S_strerror(saved_errno);
switch (saved_errno) { switch (saved_errno) {
@ -175,13 +202,13 @@ ptr S_new_open_input_fd(const char *filename, IBOOL compressed) {
if ((dupfd = DUP(fd)) == -1) { if ((dupfd = DUP(fd)) == -1) {
ptr str = S_strerror(errno); ptr str = S_strerror(errno);
FD_EINTR_GUARD(result == 0, error, result = CLOSE(fd)); FD_GUARD(result == 0, error, result = CLOSE(fd));
return Scons(FIX(OPEN_ERROR_OTHER), str); return Scons(FIX(OPEN_ERROR_OTHER), str);
} }
if ((file = gzdopen(dupfd, "rb")) == Z_NULL) { if ((file = gzdopen(dupfd, "rb")) == Z_NULL) {
FD_EINTR_GUARD(result == 0, error, result = CLOSE(fd)); FD_GUARD(result == 0, error, result = CLOSE(fd));
FD_EINTR_GUARD(result == 0, error, result = CLOSE(dupfd)); FD_GUARD(result == 0, error, result = CLOSE(dupfd));
return Scons(FIX(OPEN_ERROR_OTHER), Sstring("unable to allocate compression state (too many open files?)")); return Scons(FIX(OPEN_ERROR_OTHER), Sstring("unable to allocate compression state (too many open files?)"));
} }
@ -190,15 +217,15 @@ ptr S_new_open_input_fd(const char *filename, IBOOL compressed) {
REACTIVATE(tc) REACTIVATE(tc)
if (compressed) { if (compressed) {
FD_EINTR_GUARD(result == 0, error, result = CLOSE(fd)); FD_GUARD(result == 0, error, result = CLOSE(fd));
/* box indicates gzip'd */ /* box indicates gzip'd */
return Sbox(make_gzxfile(dupfd, file)); return Sbox(make_gzxfile(dupfd, file));
} }
GZ_EINTR_GUARD(1, ok == 0 || ok == Z_BUF_ERROR, flag, file, ok = gzclose(file)); GZ_GUARD(1, ok == 0 || ok == Z_BUF_ERROR, flag, file, ok = gzclose(file));
if (flag) {} /* make the compiler happy */ if (flag) {} /* make the compiler happy */
if (LSEEK(fd, 0, SEEK_SET) != 0) { /* gzdirect does not leave fd at position 0 */ if (LSEEK(fd, 0, SEEK_SET) != 0) { /* gzdirect does not leave fd at position 0 */
FD_EINTR_GUARD(result == 0, error, result = CLOSE(fd)); FD_GUARD(result == 0, error, result = CLOSE(fd));
return Scons(FIX(OPEN_ERROR_OTHER),Sstring("unable to reset after reading header bytes")); return Scons(FIX(OPEN_ERROR_OTHER),Sstring("unable to reset after reading header bytes"));
} }
return MAKE_FD(fd); return MAKE_FD(fd);
@ -216,7 +243,7 @@ ptr S_compress_input_fd(INT fd, I64 pos) {
} }
if ((file = gzdopen(dupfd, "rb")) == Z_NULL) { if ((file = gzdopen(dupfd, "rb")) == Z_NULL) {
FD_EINTR_GUARD(result == 0, error, result = CLOSE(dupfd)); FD_GUARD(result == 0, error, result = CLOSE(dupfd));
return Sstring("unable to allocate compression state (too many open files?)"); return Sstring("unable to allocate compression state (too many open files?)");
} }
@ -225,12 +252,12 @@ ptr S_compress_input_fd(INT fd, I64 pos) {
REACTIVATE(tc) REACTIVATE(tc)
if (compressed) { if (compressed) {
FD_EINTR_GUARD(result == 0, error, result = CLOSE(fd)); FD_GUARD(result == 0, error, result = CLOSE(fd));
if (error) {} /* make the compiler happy */ if (error) {} /* make the compiler happy */
return Sbox(make_gzxfile(dupfd, file)); return Sbox(make_gzxfile(dupfd, file));
} }
GZ_EINTR_GUARD(1, ok == 0 || ok == Z_BUF_ERROR, flag, file, ok = gzclose(file)); GZ_GUARD(1, ok == 0 || ok == Z_BUF_ERROR, flag, file, ok = gzclose(file));
if (flag) {} /* make the compiler happy */ if (flag) {} /* make the compiler happy */
if (LSEEK(fd, pos, SEEK_SET) != pos) { /* gzdirect does not leave fd at same position */ if (LSEEK(fd, pos, SEEK_SET) != pos) { /* gzdirect does not leave fd at same position */
return Sstring("unable to reset after reading header bytes"); return Sstring("unable to reset after reading header bytes");
@ -253,9 +280,10 @@ ptr S_compress_output_fd(INT fd) {
} }
static ptr new_open_output_fd_helper( static ptr new_open_output_fd_helper(
const char *filename, INT mode, INT flags, const char *infilename, INT mode, INT flags,
IBOOL no_create, IBOOL no_fail, IBOOL no_truncate, IBOOL no_create, IBOOL no_fail, IBOOL no_truncate,
IBOOL append, IBOOL lock, IBOOL replace, IBOOL compressed) { IBOOL append, IBOOL lock, IBOOL replace, IBOOL compressed) {
char *filename;
INT saved_errno = 0; INT saved_errno = 0;
iptr error; iptr error;
INT fd, result; INT fd, result;
@ -269,9 +297,7 @@ static ptr new_open_output_fd_helper(
(no_truncate ? 0 : O_TRUNC) | (no_truncate ? 0 : O_TRUNC) |
((!append) ? 0 : O_APPEND); ((!append) ? 0 : O_APPEND);
if ((filename = S_pathname_impl(filename, NULL)) == NULL) { filename = S_malloc_pathname(infilename);
return Scons(FIX(OPEN_ERROR_OTHER), Sstring("failed to expand path name"));
}
if (replace && UNLINK(filename) != 0 && errno != ENOENT) { if (replace && UNLINK(filename) != 0 && errno != ENOENT) {
ptr str = S_strerror(errno); ptr str = S_strerror(errno);
@ -283,11 +309,15 @@ static ptr new_open_output_fd_helper(
} }
} }
/* NB: don't use infilename, which might point into a Scheme string, after this point */
DEACTIVATE(tc) DEACTIVATE(tc)
FD_EINTR_GUARD(fd >= 0, error, fd = OPEN(filename, flags, mode)); FD_EINTR_GUARD(fd >= 0, error, fd = OPEN(filename, flags, mode));
saved_errno = errno; saved_errno = errno;
REACTIVATE(tc) REACTIVATE(tc)
/* NB: don't use free'd filename after this point */
free(filename);
if (error) { if (error) {
ptr str = S_strerror(saved_errno); ptr str = S_strerror(saved_errno);
switch (saved_errno) { switch (saved_errno) {
@ -308,7 +338,7 @@ static ptr new_open_output_fd_helper(
saved_errno = errno; saved_errno = errno;
REACTIVATE(tc) REACTIVATE(tc)
if (error) { if (error) {
FD_EINTR_GUARD(result == 0, error, result = CLOSE(fd)); FD_GUARD(result == 0, error, result = CLOSE(fd));
return Scons(FIX(OPEN_ERROR_OTHER), S_strerror(saved_errno)); return Scons(FIX(OPEN_ERROR_OTHER), S_strerror(saved_errno));
} }
} }
@ -319,7 +349,7 @@ static ptr new_open_output_fd_helper(
gzFile file = gzdopen(fd, append ? "ab" : "wb"); gzFile file = gzdopen(fd, append ? "ab" : "wb");
if (file == Z_NULL) { if (file == Z_NULL) {
FD_EINTR_GUARD(result == 0, error, result = CLOSE(fd)); FD_GUARD(result == 0, error, result = CLOSE(fd));
return Scons(FIX(OPEN_ERROR_OTHER), Sstring("unable to allocate compression state")); return Scons(FIX(OPEN_ERROR_OTHER), Sstring("unable to allocate compression state"));
} }
@ -367,10 +397,10 @@ ptr S_close_fd(ptr file, IBOOL gzflag) {
/* NOTE: close automatically releases locks so we don't to call unlock*/ /* NOTE: close automatically releases locks so we don't to call unlock*/
DEACTIVATE(tc) DEACTIVATE(tc)
if (!gzflag) { if (!gzflag) {
FD_EINTR_GUARD(ok == 0, flag, ok = CLOSE(fd)); FD_GUARD(ok == 0, flag, ok = CLOSE(fd));
} else { } else {
/* zlib 1.2.1 returns Z_BUF_ERROR when closing an empty file opened for reading */ /* zlib 1.2.1 returns Z_BUF_ERROR when closing an empty file opened for reading */
GZ_EINTR_GUARD(1, ok == 0 || ok == Z_BUF_ERROR, flag, gzfile, ok = gzclose(gzfile)); GZ_GUARD(1, ok == 0 || ok == Z_BUF_ERROR, flag, gzfile, ok = gzclose(gzfile));
} }
saved_errno = errno; saved_errno = errno;
REACTIVATE(tc) REACTIVATE(tc)

1
c/prim.c
View File

@ -164,7 +164,6 @@ void S_prim_init() {
create_c_entry_vector(); create_c_entry_vector();
Sforeign_symbol("(cs)fixedpathp", (void *)S_fixedpathp); Sforeign_symbol("(cs)fixedpathp", (void *)S_fixedpathp);
Sforeign_symbol("(cs)pathname", (void *)S_pathname);
Sforeign_symbol("(cs)bytes_allocated", (void *)S_compute_bytes_allocated); Sforeign_symbol("(cs)bytes_allocated", (void *)S_compute_bytes_allocated);
Sforeign_symbol("(cs)curmembytes", (void *)S_curmembytes); Sforeign_symbol("(cs)curmembytes", (void *)S_curmembytes);
Sforeign_symbol("(cs)maxmembytes", (void *)S_maxmembytes); Sforeign_symbol("(cs)maxmembytes", (void *)S_maxmembytes);

261
c/prim5.c
View File

@ -48,7 +48,7 @@ static ptr sorted_chunk_list PROTO((void));
static void s_showalloc PROTO((IBOOL show_dump, const char *outfn)); static void s_showalloc PROTO((IBOOL show_dump, const char *outfn));
static ptr s_system PROTO((const char *s)); static ptr s_system PROTO((const char *s));
static ptr s_process PROTO((char *s, IBOOL stderrp)); static ptr s_process PROTO((char *s, IBOOL stderrp));
static I32 s_chdir PROTO((const char *s)); static I32 s_chdir PROTO((const char *inpath));
static char *s_getwd PROTO((void)); static char *s_getwd PROTO((void));
static ptr s_set_code_byte PROTO((ptr p, ptr n, ptr x)); static ptr s_set_code_byte PROTO((ptr p, ptr n, ptr x));
static ptr s_set_code_word PROTO((ptr p, ptr n, ptr x)); static ptr s_set_code_word PROTO((ptr p, ptr n, ptr x));
@ -68,15 +68,15 @@ static ptr s_intern PROTO((ptr x));
static ptr s_intern2 PROTO((ptr x, ptr n)); static ptr s_intern2 PROTO((ptr x, ptr n));
static ptr s_strings_to_gensym PROTO((ptr pname_str, ptr uname_str)); static ptr s_strings_to_gensym PROTO((ptr pname_str, ptr uname_str));
static ptr s_intern3 PROTO((ptr x, ptr n, ptr m)); static ptr s_intern3 PROTO((ptr x, ptr n, ptr m));
static ptr s_delete_file PROTO((const char *path)); static ptr s_delete_file PROTO((const char *inpath));
static ptr s_delete_directory PROTO((const char *path)); static ptr s_delete_directory PROTO((const char *inpath));
static ptr s_rename_file PROTO((const char *path1, const char *path2)); static ptr s_rename_file PROTO((const char *inpath1, const char *inpath2));
static ptr s_mkdir PROTO((const char *path, INT mode)); static ptr s_mkdir PROTO((const char *inpath, INT mode));
static ptr s_chmod PROTO((const char *path, INT mode)); static ptr s_chmod PROTO((const char *inpath, INT mode));
static ptr s_getmod PROTO((const char *path, IBOOL followp)); static ptr s_getmod PROTO((const char *inpath, IBOOL followp));
static ptr s_path_atime PROTO((const char *path, IBOOL followp)); static ptr s_path_atime PROTO((const char *inpath, IBOOL followp));
static ptr s_path_ctime PROTO((const char *path, IBOOL followp)); static ptr s_path_ctime PROTO((const char *inpath, IBOOL followp));
static ptr s_path_mtime PROTO((const char *path, IBOOL followp)); static ptr s_path_mtime PROTO((const char *inpath, IBOOL followp));
static ptr s_fd_atime PROTO((INT fd)); static ptr s_fd_atime PROTO((INT fd));
static ptr s_fd_ctime PROTO((INT fd)); static ptr s_fd_ctime PROTO((INT fd));
static ptr s_fd_mtime PROTO((INT fd)); static ptr s_fd_mtime PROTO((INT fd));
@ -773,16 +773,18 @@ static ptr s_process(s, stderrp) char *s; IBOOL stderrp; {
return LIST3(FIX(ifd), FIX(ofd), FIX(child)); return LIST3(FIX(ifd), FIX(ofd), FIX(child));
} }
static I32 s_chdir(const char *s) { static I32 s_chdir(const char *inpath) {
char *path;
#ifdef EINTR
I32 status; I32 status;
while ((status = CHDIR(S_pathname("current-directory", s, 1, (char *)0))) != 0 && errno == EINTR) ; path = S_malloc_pathname(inpath);
return status; #ifdef EINTR
while ((status = CHDIR(path)) != 0 && errno == EINTR) ;
#else /* EINTR */ #else /* EINTR */
return CHDIR(S_pathname("current-directory", s, 1, (char *)0)); status = CHDIR(path);
#endif /* EINTR */ #endif /* EINTR */
free(path);
return status;
} }
#ifdef GETWD #ifdef GETWD
@ -931,162 +933,203 @@ static ptr s_strings_to_gensym(ptr pname_str, ptr uname_str) {
pname_str, uname_str); pname_str, uname_str);
} }
static ptr s_mkdir(const char *path, INT mode) { static ptr s_mkdir(const char *inpath, INT mode) {
INT status; INT status; ptr res; char *path;
const char *expandedpath = S_pathname("mkdir", path, 1, (char *)0);
path = S_malloc_pathname(inpath);
#ifdef WIN32 #ifdef WIN32
status = S_windows_mkdir(expandedpath); status = S_windows_mkdir(path);
#else /* WIN32 */ #else /* WIN32 */
status = mkdir(expandedpath, mode); status = mkdir(path, mode);
#endif /* WIN32 */ #endif /* WIN32 */
return status == 0 ? Strue : S_strerror(errno); res = status == 0 ? Strue : S_strerror(errno);
free(path);
return res;
} }
static ptr s_delete_file(const char *path) { static ptr s_delete_file(const char *inpath) {
const char *extendedpath = S_pathname("delete-file", path, 1, (char *)0); ptr res; char *path;
return UNLINK(extendedpath) == 0 ? Strue : S_strerror(errno);
path = S_malloc_pathname(inpath);
res = UNLINK(path) == 0 ? Strue : S_strerror(errno);
free(path);
return res;
} }
static ptr s_delete_directory(const char *path) { static ptr s_delete_directory(const char *inpath) {
const char *extendedpath = S_pathname("delete-directory", path, 1, (char *)0); ptr res; char *path;
return RMDIR(extendedpath) == 0 ? Strue : S_strerror(errno);
path = S_malloc_pathname(inpath);
res = RMDIR(path) == 0 ? Strue : S_strerror(errno);
free(path);
return res;
} }
static ptr s_rename_file(const char *path1, const char *path2) { static ptr s_rename_file(const char *inpath1, const char *inpath2) {
static char buf[PATH_MAX]; ptr res; char *path1, *path2;
const char *extendedpath1 = S_pathname("rename-file", path1, 1, buf);
const char *extendedpath2 = S_pathname("rename-file", path2, 1, (char *)0); path1 = S_malloc_pathname(inpath1);
return RENAME(extendedpath1, extendedpath2) == 0 ? Strue : S_strerror(errno); path2 = S_malloc_pathname(inpath2);
res = RENAME(path1, path2) == 0 ? Strue : S_strerror(errno);
free(path1);
free(path2);
return res;
} }
static ptr s_chmod(const char *path, INT mode) { static ptr s_chmod(const char *inpath, INT mode) {
INT status; ptr res; INT status; char *path;
const char *extendedpath = S_pathname("chmod", path, 1, (char *)0);
path = S_malloc_pathname(inpath);
#ifdef WIN32 #ifdef WIN32
/* pathetic approximation: (a) only handles user permissions, (b) doesn't /* pathetic approximation: (a) only handles user permissions, (b) doesn't
handle execute permissions, (c) windows won't make file not readable */ handle execute permissions, (c) windows won't make file not readable */
status = CHMOD(extendedpath, status = CHMOD(path,
(mode & 0400 ? S_IREAD : 0) | (mode & 0400 ? S_IREAD : 0) |
(mode & 0200 ? S_IWRITE : 0)); (mode & 0200 ? S_IWRITE : 0));
#else /* WIN32 */ #else /* WIN32 */
status = CHMOD(extendedpath, mode); status = CHMOD(path, mode);
#endif /* WIN32 */ #endif /* WIN32 */
return status == 0 ? Strue : S_strerror(errno); res = status == 0 ? Strue : S_strerror(errno);
free(path);
return res;
} }
static ptr s_getmod(const char *path, IBOOL followp) { static ptr s_getmod(const char *inpath, IBOOL followp) {
struct STATBUF statbuf; ptr res; char *path; struct STATBUF statbuf;
const char *extendedpath = S_pathname("get-mode", path, 1, (char *)0);
path = S_malloc_pathname(inpath);
/* according to msdn, user read/write bits are set according to the file's /* according to msdn, user read/write bits are set according to the file's
permission mode, and user execute bits are set according to the permission mode, and user execute bits are set according to the
filename extension. it says nothing about group and other execute bits. */ filename extension. it says nothing about group and other execute bits. */
if ((followp ? STAT(extendedpath, &statbuf) : LSTAT(extendedpath, &statbuf)) != 0) if ((followp ? STAT(path, &statbuf) : LSTAT(path, &statbuf)) != 0) {
return S_strerror(errno); res = S_strerror(errno);
} else {
return FIX(statbuf.st_mode & 07777); res = FIX(statbuf.st_mode & 07777);
}
free(path);
return res;
} }
static ptr s_path_atime(const char *path, IBOOL followp) { static ptr s_path_atime(const char *inpath, IBOOL followp) {
#ifdef WIN32 #ifdef WIN32
wchar_t wpath[PATH_MAX]; ptr res;
wchar_t *wpath;
WIN32_FILE_ATTRIBUTE_DATA filedata; WIN32_FILE_ATTRIBUTE_DATA filedata;
__int64 total, sec; int nsec; __int64 total, sec; int nsec;
path = S_pathname("file-access-time", path, 1, (char *)0); if ((wpath = S_malloc_wide_pathname(inpath)) == NULL) {
if (MultiByteToWideChar(CP_UTF8,0,path,-1,wpath,PATH_MAX) == 0) res = S_LastErrorString();
return S_LastErrorString(); } else if (!GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata)) {
if (!GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata)) {
DWORD err = GetLastError(); DWORD err = GetLastError();
return err == ERROR_FILE_NOT_FOUND || err == ERROR_PATH_NOT_FOUND ? res = err == ERROR_FILE_NOT_FOUND || err == ERROR_PATH_NOT_FOUND ?
Sstring("no such file or directory") : Sstring("no such file or directory") :
S_LastErrorString(); S_LastErrorString();
} else {
total = filedata.ftLastAccessTime.dwHighDateTime;
total <<= 32;
total |= filedata.ftLastAccessTime.dwLowDateTime;
sec = total / 10000000 - 11644473600L;
nsec = (total % 10000000) * 100;
res = Scons(Sinteger64(sec), Sinteger32(nsec));
} }
free(wpath);
total = filedata.ftLastAccessTime.dwHighDateTime; return res;
total <<= 32;
total |= filedata.ftLastAccessTime.dwLowDateTime;
sec = total / 10000000 - 11644473600L;
nsec = (total % 10000000) * 100;
return Scons(Sinteger64(sec), Sinteger32(nsec));
#else /* WIN32 */ #else /* WIN32 */
ptr res;
char *path;
struct STATBUF statbuf; struct STATBUF statbuf;
const char *extendedpath = S_pathname("file-access-time", path, 1, (char *)0);
if ((followp ? STAT(extendedpath, &statbuf) : LSTAT(extendedpath, &statbuf)) != 0) path = S_malloc_pathname(inpath);
return S_strerror(errno); if ((followp ? STAT(path, &statbuf) : LSTAT(path, &statbuf)) != 0) {
res = S_strerror(errno);
return Scons(Sinteger64(SECATIME(statbuf)), Sinteger32(NSECATIME(statbuf))); } else {
res = Scons(Sinteger64(SECATIME(statbuf)), Sinteger32(NSECATIME(statbuf)));
}
free(path);
return res;
#endif /* WIN32 */ #endif /* WIN32 */
} }
static ptr s_path_ctime(const char *path, IBOOL followp) { static ptr s_path_ctime(const char *inpath, IBOOL followp) {
#ifdef WIN32 #ifdef WIN32
wchar_t wpath[PATH_MAX]; ptr res;
wchar_t *wpath;
WIN32_FILE_ATTRIBUTE_DATA filedata; WIN32_FILE_ATTRIBUTE_DATA filedata;
__int64 total, sec; int nsec; __int64 total, sec; int nsec;
path = S_pathname("file-change-time", path, 1, (char *)0); if ((wpath = S_malloc_wide_pathname(inpath)) == NULL) {
if (MultiByteToWideChar(CP_UTF8,0,path,-1,wpath,PATH_MAX) == 0) res = S_LastErrorString();
return S_LastErrorString(); } else if (!GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata)) {
if (!GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata)) {
DWORD err = GetLastError(); DWORD err = GetLastError();
return err == ERROR_FILE_NOT_FOUND || err == ERROR_PATH_NOT_FOUND ? res = err == ERROR_FILE_NOT_FOUND || err == ERROR_PATH_NOT_FOUND ?
Sstring("no such file or directory") : Sstring("no such file or directory") :
S_LastErrorString(); S_LastErrorString();
} else {
total = filedata.ftLastWriteTime.dwHighDateTime;
total <<= 32;
total |= filedata.ftLastWriteTime.dwLowDateTime;
sec = total / 10000000 - 11644473600L;
nsec = (total % 10000000) * 100;
res = Scons(Sinteger64(sec), Sinteger32(nsec));
} }
free(wpath);
total = filedata.ftLastWriteTime.dwHighDateTime; return res;
total <<= 32;
total |= filedata.ftLastWriteTime.dwLowDateTime;
sec = total / 10000000 - 11644473600L;
nsec = (total % 10000000) * 100;
return Scons(Sinteger64(sec), Sinteger32(nsec));
#else /* WIN32 */ #else /* WIN32 */
ptr res;
char *path;
struct STATBUF statbuf; struct STATBUF statbuf;
const char *extendedpath = S_pathname("file-change-time", path, 1, (char *)0);
if ((followp ? STAT(extendedpath, &statbuf) : LSTAT(extendedpath, &statbuf)) != 0) path = S_malloc_pathname(inpath);
return S_strerror(errno); if ((followp ? STAT(path, &statbuf) : LSTAT(path, &statbuf)) != 0) {
res = S_strerror(errno);
return Scons(Sinteger64(SECCTIME(statbuf)), Sinteger32(NSECCTIME(statbuf))); } else {
res = Scons(Sinteger64(SECCTIME(statbuf)), Sinteger32(NSECCTIME(statbuf)));
}
free(path);
return res;
#endif /* WIN32 */ #endif /* WIN32 */
} }
static ptr s_path_mtime(const char *path, IBOOL followp) { static ptr s_path_mtime(const char *inpath, IBOOL followp) {
#ifdef WIN32 #ifdef WIN32
wchar_t wpath[PATH_MAX]; ptr res;
wchar_t *wpath;
WIN32_FILE_ATTRIBUTE_DATA filedata; WIN32_FILE_ATTRIBUTE_DATA filedata;
__int64 total, sec; int nsec; __int64 total, sec; int nsec;
path = S_pathname("file-modification-time", path, 1, (char *)0); if ((wpath = S_malloc_wide_pathname(inpath)) == NULL) {
if (MultiByteToWideChar(CP_UTF8,0,path,-1,wpath,PATH_MAX) == 0) res = S_LastErrorString();
return S_LastErrorString(); } else if (!GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata)) {
if (!GetFileAttributesExW(wpath, GetFileExInfoStandard, &filedata)) {
DWORD err = GetLastError(); DWORD err = GetLastError();
return err == ERROR_FILE_NOT_FOUND || err == ERROR_PATH_NOT_FOUND ? res = err == ERROR_FILE_NOT_FOUND || err == ERROR_PATH_NOT_FOUND ?
Sstring("no such file or directory") : Sstring("no such file or directory") :
S_LastErrorString(); S_LastErrorString();
} else {
total = filedata.ftLastWriteTime.dwHighDateTime;
total <<= 32;
total |= filedata.ftLastWriteTime.dwLowDateTime;
sec = total / 10000000 - 11644473600L;
nsec = (total % 10000000) * 100;
res = Scons(Sinteger64(sec), Sinteger32(nsec));
} }
free(wpath);
total = filedata.ftLastWriteTime.dwHighDateTime; return res;
total <<= 32;
total |= filedata.ftLastWriteTime.dwLowDateTime;
sec = total / 10000000 - 11644473600L;
nsec = (total % 10000000) * 100;
return Scons(Sinteger64(sec), Sinteger32(nsec));
#else /* WIN32 */ #else /* WIN32 */
ptr res;
char *path;
struct STATBUF statbuf; struct STATBUF statbuf;
const char *extendedpath = S_pathname("file-modification-time", path, 1, (char *)0);
if ((followp ? STAT(extendedpath, &statbuf) : LSTAT(extendedpath, &statbuf)) != 0) path = S_malloc_pathname(inpath);
return S_strerror(errno); if ((followp ? STAT(path, &statbuf) : LSTAT(path, &statbuf)) != 0) {
res = S_strerror(errno);
return Scons(Sinteger64(SECMTIME(statbuf)), Sinteger32(NSECMTIME(statbuf))); } else {
res = Scons(Sinteger64(SECMTIME(statbuf)), Sinteger32(NSECMTIME(statbuf)));
}
free(path);
return res;
#endif /* WIN32 */ #endif /* WIN32 */
} }

15
c/scheme.c
View File

@ -541,6 +541,7 @@ static IBOOL find_boot(name, ext, errorp) const char *name, *ext; IBOOL errorp;
char pathbuf[PATH_MAX], buf[PATH_MAX]; char pathbuf[PATH_MAX], buf[PATH_MAX];
uptr n; INT c; uptr n; INT c;
const char *path; const char *path;
char *expandedpath;
gzFile file; gzFile file;
if (S_fixedpathp(name)) { if (S_fixedpathp(name)) {
@ -551,7 +552,12 @@ static IBOOL find_boot(name, ext, errorp) const char *name, *ext; IBOOL errorp;
path = name; path = name;
if (!(file = gzopen(S_pathname("", path, 0, (char *)0), "rb"))) { expandedpath = S_malloc_pathname(path);
file = gzopen(expandedpath, "rb");
/* assumption (seemingly true based on a glance at the source code):
gzopen doesn't squirrel away a pointer to expandedpath. */
free(expandedpath);
if (!file) {
if (errorp) { if (errorp) {
fprintf(stderr, "cannot open boot file %s\n", path); fprintf(stderr, "cannot open boot file %s\n", path);
S_abnormal_exit(); S_abnormal_exit();
@ -621,7 +627,12 @@ static IBOOL find_boot(name, ext, errorp) const char *name, *ext; IBOOL errorp;
} }
} }
if (!(file = gzopen(S_pathname("", path, 0, (char *)0), "rb"))) { expandedpath = S_malloc_pathname(path);
file = gzopen(expandedpath, "rb");
/* assumption (seemingly true based on a glance at the source code):
gzopen doesn't squirrel away a pointer to expandedpath. */
free(expandedpath);
if (!file) {
if (verbose) fprintf(stderr, "trying %s...cannot open\n", path); if (verbose) fprintf(stderr, "trying %s...cannot open\n", path);
continue; continue;
} }

4
mats/6.ms
View File

@ -3457,14 +3457,14 @@
(begin (display "hello " (cadr p)) (begin (display "hello " (cadr p))
(flush-output-port (cadr p)) (flush-output-port (cadr p))
#t) #t)
(begin (sleep (make-time 'time-duration 0 (if (embedded?) 3 1))) #t) ; wait for subprocess to catch up (begin (sleep (make-time 'time-duration 0 3)) #t) ; wait for subprocess to catch up
(char-ready? (car p)) (char-ready? (car p))
(eq? (read (car p)) 'hello) (eq? (read (car p)) 'hello)
(char-ready? (car p)) (char-ready? (car p))
(char=? (read-char (car p)) #\space) (char=? (read-char (car p)) #\space)
(not (char-ready? (car p))) (not (char-ready? (car p)))
(begin (close-output-port (cadr p)) #t) (begin (close-output-port (cadr p)) #t)
(begin (sleep (make-time 'time-duration 0 (if (embedded?) 3 1))) #t) ; wait for subprocess to catch up (begin (sleep (make-time 'time-duration 0 3)) #t) ; wait for subprocess to catch up
(sanitized-error? (write-char #\a (cadr p))) (sanitized-error? (write-char #\a (cadr p)))
(sanitized-error? (write-char #\newline (cadr p))) (sanitized-error? (write-char #\newline (cadr p)))
(sanitized-error? (flush-output-port (cadr p))) (sanitized-error? (flush-output-port (cadr p)))

5
mats/io.ms
View File

@ -1040,6 +1040,11 @@
(define op (transcoded-port bp transcoder)) (define op (transcoded-port bp transcoder))
(newline op) (newline op)
(close-port op))) (close-port op)))
; NB: keep this last among the iconv-codec mats
; close any files left open by failing iconv tests. this is particulary
; important on windows when the iconv dll isn't available and where keeping
; file open can prevent it from being reopened.
(begin (collect (collect-maximum-generation)) #t)
)) ))
(mat port-operations4 (mat port-operations4

10
mats/thread.ms
View File

@ -1026,7 +1026,15 @@
(f (+ i 1)) (f (+ i 1))
(cons (+ (* i thread-count) j) (g (+ j 1)))))))))) (cons (+ (* i thread-count) j) (g (+ j 1))))))))))
($thread-check) ($thread-check)
(eqv? ; this mat has some inherent starvation issues, with the main thread
; looping rather than waiting on a condition at initialization time and
; other threads looping rather than waiting on a condition when looking
; for work to steal. these looping threads can hog the cpu without
; doing anything useful, causing progress to stall or halt. this
; manifests as occasional indefinite delays under Windows and OpenBSD,
; and it has the potential to cause the same on other operating systems.
; it's not clear how to fix the mat without changing it fundamentally.
#;(eqv?
(let () ; from Ryan Newton (let () ; from Ryan Newton
(define-syntax ASSERT (define-syntax ASSERT