source: project/chicken/branches/inlining/posixwin.scm @ 15323

Last change on this file since 15323 was 15323, checked in by felix winkelmann, 11 years ago

more intelligent inlining; standard-extension procedure in setup-api

File size: 67.9 KB
Line 
1;;;; posixwin.scm - Miscellaneous file- and process-handling routines, available on Windows
2;
3; By Sergey Khorev
4;
5; Copyright (c) 2000-2007, Felix L. Winkelmann
6; Copyright (c) 2008-2009, The Chicken Team
7; All rights reserved.
8;
9; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
10; conditions are met:
11;
12;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
13;     disclaimer.
14;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
15;     disclaimer in the documentation and/or other materials provided with the distribution.
16;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
17;     products derived from this software without specific prior written permission.
18;
19; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
20; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
21; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
22; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
23; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
24; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
25; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
26; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
27; POSSIBILITY OF SUCH DAMAGE.
28
29
30; Not implemented:
31;
32; open/noctty  open/nonblock  open/fsync  open/sync
33; perm/isvtx  perm/isuid  perm/isgid
34; file-select
35; symbolic-link?
36; set-signal-mask!  signal-mask  signal-masked?  signal-mask!  signal-unmask!
37; user-information group-information  get-groups  set-groups!  initialize-groups
38; errno/wouldblock
39; change-file-owner
40; current-user-id  current-group-id  current-effective-user-id  current-effective-group-id
41; current-effective-user-name
42; set-user-id!  set-group-id!
43; create-session
44; process-group-id  set-process-group-id!
45; create-symbolic-link  read-symbolic-link
46; file-truncate
47; file-lock  file-lock/blocking  file-unlock  file-test-lock
48; create-fifo  fifo?
49; prot/...
50; map/...
51; map-file-to-memory  unmap-file-from-memory  memory-mapped-file-pointer  memory-mapped-file?
52; set-alarm!
53; terminal-port?  terminal-name
54; process-fork  process-wait
55; parent-process-id
56; process-signal
57
58
59; Issues
60;
61; - Use of a UTF8 encoded string will not work properly. Windows uses a
62; 16-bit UNICODE character string encoding and specialized system calls
63; and/or structure settings for the use of such strings.
64
65
66(declare
67  (unit posix)
68  (uses scheduler regex extras utils files ports)
69  (disable-interrupts)
70  (usual-integrations)
71  (hide ##sys#stat posix-error
72        $quote-args-list $exec-setup $exec-teardown
73        check-time-vector)
74  (not inline ##sys#interrupt-hook ##sys#user-interrupt-hook)
75  (foreign-declare #<<EOF
76#ifndef WIN32_LEAN_AND_MEAN
77# define WIN32_LEAN_AND_MEAN
78#endif
79
80/*
81MinGW should have winsock2.h and ws2tcpip.h as well.
82The CMake build will set HAVE_WINSOCK2_H and HAVE_WS2TCPIP_H.
83However, the _MSC_VER test is still needed for vcbuild.bat.
84./configure doesn't test for these.  It should, for MinGW.
85*/
86#if (_MSC_VER > 1300) || (defined(HAVE_WINSOCK2_H) && defined(HAVE_WS2TCPIP_H))
87# include <winsock2.h>
88# include <ws2tcpip.h>
89#else
90# include <winsock.h>
91#endif
92
93#include <signal.h>
94#include <errno.h>
95#include <io.h>
96#include <stdio.h>
97#include <process.h>
98
99static int C_not_implemented(void);
100int C_not_implemented() { return -1; }
101
102#include <sys/types.h>
103#include <sys/stat.h>
104#include <fcntl.h>
105#include <direct.h>
106
107#include <time.h>
108
109#define ARG_MAX         256
110#define PIPE_BUF        512
111#ifndef ENV_MAX
112# define ENV_MAX        1024
113#endif
114
115static C_TLS char *C_exec_args[ ARG_MAX ];
116static C_TLS char *C_exec_env[ ENV_MAX ];
117static C_TLS struct group *C_group;
118static C_TLS int C_pipefds[ 2 ];
119static C_TLS time_t C_secs;
120static C_TLS struct tm C_tm;
121static C_TLS struct stat C_statbuf;
122
123/* pipe handles */
124static C_TLS HANDLE C_rd0, C_wr0, C_wr0_, C_rd1, C_wr1, C_rd1_;
125static C_TLS HANDLE C_save0, C_save1; /* saved I/O handles */
126static C_TLS char C_rdbuf; /* one-char buffer for read */
127static C_TLS int C_exstatus;
128
129/* platform information; initialized for cached testing */
130static C_TLS char C_hostname[256] = "";
131static C_TLS char C_osver[16] = "";
132static C_TLS char C_osrel[16] = "";
133static C_TLS char C_processor[16] = "";
134static C_TLS char C_shlcmd[256] = "";
135
136/* Windows NT or better */
137static int C_isNT = 0;
138
139/* Current user name */
140static C_TLS TCHAR C_username[255 + 1] = "";
141
142/* Directory Operations */
143
144#define C_mkdir(str)        C_fix(mkdir(C_c_string(str)))
145#define C_chdir(str)        C_fix(chdir(C_c_string(str)))
146#define C_rmdir(str)        C_fix(rmdir(C_c_string(str)))
147
148#ifndef __WATCOMC__
149/* DIRENT stuff */
150struct dirent
151{
152    char *              d_name;
153};
154
155typedef struct
156{
157    struct _finddata_t  fdata;
158    int                 handle;
159    struct dirent       current;
160} DIR;
161
162static DIR * C_fcall
163opendir(const char *name)
164{
165    int name_len = strlen(name);
166    DIR *dir = (DIR *)malloc(sizeof(DIR));
167    char *what;
168    if (!dir)
169    {
170        errno = ENOMEM;
171        return NULL;
172    }
173    what = (char *)malloc(name_len + 3);
174    if (!what)
175    {
176        free(dir);
177        errno = ENOMEM;
178        return NULL;
179    }
180    strcpy(what, name);
181    if (strchr("\\/", name[name_len - 1]))
182        strcat(what, "*");
183    else
184        strcat(what, "\\*");
185
186    dir->handle = _findfirst(what, &dir->fdata);
187    if (dir->handle == -1)
188    {
189        free(what);
190        free(dir);
191        return NULL;
192    }
193    dir->current.d_name = NULL; /* as the first-time indicator */
194    free(what);
195    return dir;
196}
197
198static int C_fcall
199closedir(DIR * dir)
200{
201    if (dir)
202    {
203        int res = _findclose(dir->handle);
204        free(dir);
205        return res;
206    }
207    return -1;
208}
209
210static struct dirent * C_fcall
211readdir(DIR * dir)
212{
213    if (dir)
214    {
215        if (!dir->current.d_name /* first time after opendir */
216             || _findnext(dir->handle, &dir->fdata) != -1)
217        {
218            dir->current.d_name = dir->fdata.name;
219            return &dir->current;
220        }
221    }
222    return NULL;
223}
224#endif /* ifndef __WATCOMC__ */
225
226#ifdef __WATCOMC__
227# define mktemp _mktemp
228/* there is no P_DETACH in Watcom CRTL */
229# define P_DETACH P_NOWAIT
230#endif
231
232#define C_opendir(x,h)          C_set_block_item(h, 0, (C_word) opendir(C_c_string(x)))
233#define C_closedir(h)           (closedir((DIR *)C_block_item(h, 0)), C_SCHEME_UNDEFINED)
234#define C_readdir(h,e)          C_set_block_item(e, 0, (C_word) readdir((DIR *)C_block_item(h, 0)))
235#define C_foundfile(e,b)        (strcpy(C_c_string(b), ((struct dirent *) C_block_item(e, 0))->d_name), C_fix(strlen(((struct dirent *) C_block_item(e, 0))->d_name)))
236
237#define C_curdir(buf)       (getcwd(C_c_string(buf), 256) ? C_fix(strlen(C_c_string(buf))) : C_SCHEME_FALSE)
238
239#define open_binary_input_pipe(a, n, name)   C_mpointer(a, _popen(C_c_string(name), "r"))
240#define open_text_input_pipe(a, n, name)     open_binary_input_pipe(a, n, name)
241#define open_binary_output_pipe(a, n, name)  C_mpointer(a, _popen(C_c_string(name), "w"))
242#define open_text_output_pipe(a, n, name)    open_binary_output_pipe(a, n, name)
243#define close_pipe(p)                        C_fix(_pclose(C_port_file(p)))
244
245#define C_set_file_ptr(port, ptr)  (C_set_block_item(port, 0, (C_block_item(ptr, 0))), C_SCHEME_UNDEFINED)
246
247#define C_getpid            getpid
248#define C_chmod(fn, m)      C_fix(chmod(C_data_pointer(fn), C_unfix(m)))
249#define C_fdopen(a, n, fd, m) C_mpointer(a, fdopen(C_unfix(fd), C_c_string(m)))
250#define C_C_fileno(p)       C_fix(fileno(C_port_file(p)))
251#define C_dup(x)            C_fix(dup(C_unfix(x)))
252#define C_dup2(x, y)        C_fix(dup2(C_unfix(x), C_unfix(y)))
253#define C_setvbuf(p, m, s)  C_fix(setvbuf(C_port_file(p), NULL, C_unfix(m), C_unfix(s)))
254#define C_access(fn, m)     C_fix(access((char *)C_data_pointer(fn), C_unfix(m)))
255#define C_pipe(d, m)        C_fix(_pipe(C_pipefds, PIPE_BUF, C_unfix(m)))
256#define C_close(fd)         C_fix(close(C_unfix(fd)))
257
258#define C_getenventry(i)   environ[ i ]
259
260#define C_putenv(s)         C_fix(putenv((char *)C_data_pointer(s)))
261#define C_stat(fn)          C_fix(stat((char *)C_data_pointer(fn), &C_statbuf))
262#define C_fstat(f)          C_fix(fstat(C_unfix(f), &C_statbuf))
263
264static C_word C_fcall
265C_setenv(C_word x, C_word y)
266{
267    char *sx = C_data_pointer(x),
268         *sy = C_data_pointer(y);
269    int n1 = C_strlen(sx),
270        n2 = C_strlen(sy);
271    char *buf = (char *)C_malloc(n1 + n2 + 2);
272    if (buf == NULL)
273        return(C_fix(0));
274    else
275    {
276        C_strcpy(buf, sx);
277        buf[ n1 ] = '=';
278        C_strcpy(buf + n1 + 1, sy);
279        return(C_fix(putenv(buf)));
280    }
281}
282
283static void C_fcall
284C_set_arg_string(char **where, int i, char *dat, int len)
285{
286    char *ptr;
287    if (dat)
288    {
289        ptr = (char *)C_malloc(len + 1);
290        C_memcpy(ptr, dat, len);
291        ptr[ len ] = '\0';
292    }
293    else
294        ptr = NULL;
295    where[ i ] = ptr;
296}
297
298static void C_fcall
299C_free_arg_string(char **where) {
300  while (*where) C_free(*(where++));
301}
302
303#define C_set_exec_arg(i, a, len)       C_set_arg_string(C_exec_args, i, a, len)
304#define C_set_exec_env(i, a, len)       C_set_arg_string(C_exec_env, i, a, len)
305
306#define C_free_exec_args()              (C_free_arg_string(C_exec_args), C_SCHEME_TRUE)
307#define C_free_exec_env()               (C_free_arg_string(C_exec_env), C_SCHEME_TRUE)
308
309#define C_execvp(f)         C_fix(execvp(C_data_pointer(f), (const char *const *)C_exec_args))
310#define C_execve(f)         C_fix(execve(C_data_pointer(f), (const char *const *)C_exec_args, (const char *const *)C_exec_env))
311
312/* MS replacement for the fork-exec pair */
313#define C_spawnvp(m, f)     C_fix(spawnvp(C_unfix(m), C_data_pointer(f), (const char *const *)C_exec_args))
314#define C_spawnvpe(m, f)    C_fix(spawnvpe(C_unfix(m), C_data_pointer(f), (const char *const *)C_exec_args, (const char *const *)C_exec_env))
315
316#define C_open(fn, fl, m)   C_fix(open(C_c_string(fn), C_unfix(fl), C_unfix(m)))
317#define C_read(fd, b, n)    C_fix(read(C_unfix(fd), C_data_pointer(b), C_unfix(n)))
318#define C_write(fd, b, n)   C_fix(write(C_unfix(fd), C_data_pointer(b), C_unfix(n)))
319#define C_mkstemp(t)        C_fix(mktemp(C_c_string(t)))
320
321#define C_ftell(p)          C_fix(ftell(C_port_file(p)))
322#define C_fseek(p, n, w)    C_mk_nbool(fseek(C_port_file(p), C_unfix(n), C_unfix(w)))
323#define C_lseek(fd, o, w)   C_fix(lseek(C_unfix(fd), C_unfix(o), C_unfix(w)))
324
325#define C_flushall()        C_fix(_flushall())
326
327#define C_ctime(n)          (C_secs = (n), ctime(&C_secs))
328
329#define C_tm_set_08(v) \
330        (memset(&C_tm, 0, sizeof(struct tm)), \
331        C_tm.tm_sec = C_unfix(C_block_item(v, 0)), \
332        C_tm.tm_min = C_unfix(C_block_item(v, 1)), \
333        C_tm.tm_hour = C_unfix(C_block_item(v, 2)), \
334        C_tm.tm_mday = C_unfix(C_block_item(v, 3)), \
335        C_tm.tm_mon = C_unfix(C_block_item(v, 4)), \
336        C_tm.tm_year = C_unfix(C_block_item(v, 5)), \
337        C_tm.tm_wday = C_unfix(C_block_item(v, 6)), \
338        C_tm.tm_yday = C_unfix(C_block_item(v, 7)), \
339        C_tm.tm_isdst = (C_block_item(v, 8) != C_SCHEME_FALSE))
340
341#define C_tm_set(v) (C_tm_set_08(v), &C_tm)
342
343#define C_asctime(v)    (asctime(C_tm_set(v)))
344#define C_mktime(v)     ((C_temporary_flonum = mktime(C_tm_set(v))) != -1)
345
346#define TIME_STRING_MAXLENGTH 255
347static char C_time_string [TIME_STRING_MAXLENGTH + 1];
348#undef TIME_STRING_MAXLENGTH
349
350#define C_strftime(v, f) \
351        (strftime(C_time_string, sizeof(C_time_string), C_c_string(f), C_tm_set(v)) ? C_time_string : NULL)
352
353/*
354  mapping from Win32 error codes to errno
355*/
356
357typedef struct
358{
359    DWORD   win32;
360    int     libc;
361} errmap_t;
362
363static errmap_t errmap[] =
364{
365    {ERROR_INVALID_FUNCTION,      EINVAL},
366    {ERROR_FILE_NOT_FOUND,        ENOENT},
367    {ERROR_PATH_NOT_FOUND,        ENOENT},
368    {ERROR_TOO_MANY_OPEN_FILES,   EMFILE},
369    {ERROR_ACCESS_DENIED,         EACCES},
370    {ERROR_INVALID_HANDLE,        EBADF},
371    {ERROR_ARENA_TRASHED,         ENOMEM},
372    {ERROR_NOT_ENOUGH_MEMORY,     ENOMEM},
373    {ERROR_INVALID_BLOCK,         ENOMEM},
374    {ERROR_BAD_ENVIRONMENT,       E2BIG},
375    {ERROR_BAD_FORMAT,            ENOEXEC},
376    {ERROR_INVALID_ACCESS,        EINVAL},
377    {ERROR_INVALID_DATA,          EINVAL},
378    {ERROR_INVALID_DRIVE,         ENOENT},
379    {ERROR_CURRENT_DIRECTORY,     EACCES},
380    {ERROR_NOT_SAME_DEVICE,       EXDEV},
381    {ERROR_NO_MORE_FILES,         ENOENT},
382    {ERROR_LOCK_VIOLATION,        EACCES},
383    {ERROR_BAD_NETPATH,           ENOENT},
384    {ERROR_NETWORK_ACCESS_DENIED, EACCES},
385    {ERROR_BAD_NET_NAME,          ENOENT},
386    {ERROR_FILE_EXISTS,           EEXIST},
387    {ERROR_CANNOT_MAKE,           EACCES},
388    {ERROR_FAIL_I24,              EACCES},
389    {ERROR_INVALID_PARAMETER,     EINVAL},
390    {ERROR_NO_PROC_SLOTS,         EAGAIN},
391    {ERROR_DRIVE_LOCKED,          EACCES},
392    {ERROR_BROKEN_PIPE,           EPIPE},
393    {ERROR_DISK_FULL,             ENOSPC},
394    {ERROR_INVALID_TARGET_HANDLE, EBADF},
395    {ERROR_INVALID_HANDLE,        EINVAL},
396    {ERROR_WAIT_NO_CHILDREN,      ECHILD},
397    {ERROR_CHILD_NOT_COMPLETE,    ECHILD},
398    {ERROR_DIRECT_ACCESS_HANDLE,  EBADF},
399    {ERROR_NEGATIVE_SEEK,         EINVAL},
400    {ERROR_SEEK_ON_DEVICE,        EACCES},
401    {ERROR_DIR_NOT_EMPTY,         ENOTEMPTY},
402    {ERROR_NOT_LOCKED,            EACCES},
403    {ERROR_BAD_PATHNAME,          ENOENT},
404    {ERROR_MAX_THRDS_REACHED,     EAGAIN},
405    {ERROR_LOCK_FAILED,           EACCES},
406    {ERROR_ALREADY_EXISTS,        EEXIST},
407    {ERROR_FILENAME_EXCED_RANGE,  ENOENT},
408    {ERROR_NESTING_NOT_ALLOWED,   EAGAIN},
409    {ERROR_NOT_ENOUGH_QUOTA,      ENOMEM},
410    {0, 0}
411};
412
413static void C_fcall
414set_errno(DWORD w32err)
415{
416    errmap_t *map = errmap;
417    for (; errmap->win32; ++map)
418    {
419        if (errmap->win32 == w32err)
420        {
421            errno = errmap->libc;
422            return;
423        }
424    }
425}
426
427static int C_fcall
428set_last_errno()
429{
430    set_errno(GetLastError());
431    return 0;
432}
433
434/* Functions for creating process with redirected I/O */
435
436static int C_fcall
437zero_handles()
438{
439    C_rd0 = C_wr0 = C_wr0_ = INVALID_HANDLE_VALUE;
440    C_rd1 = C_wr1 = C_rd1_ = INVALID_HANDLE_VALUE;
441    C_save0 = C_save1 = INVALID_HANDLE_VALUE;
442    return 1;
443}
444
445static int C_fcall
446close_handles()
447{
448    if (C_rd0 != INVALID_HANDLE_VALUE)
449        CloseHandle(C_rd0);
450    if (C_rd1 != INVALID_HANDLE_VALUE)
451        CloseHandle(C_rd1);
452    if (C_wr0 != INVALID_HANDLE_VALUE)
453        CloseHandle(C_wr0);
454    if (C_wr1 != INVALID_HANDLE_VALUE)
455        CloseHandle(C_wr1);
456    if (C_rd1_ != INVALID_HANDLE_VALUE)
457        CloseHandle(C_rd1_);
458    if (C_wr0_ != INVALID_HANDLE_VALUE)
459        CloseHandle(C_wr0_);
460    if (C_save0 != INVALID_HANDLE_VALUE)
461    {
462        SetStdHandle(STD_INPUT_HANDLE, C_save0);
463        CloseHandle(C_save0);
464    }
465    if (C_save1 != INVALID_HANDLE_VALUE)
466    {
467        SetStdHandle(STD_OUTPUT_HANDLE, C_save1);
468        CloseHandle(C_save1);
469    }
470    return zero_handles();
471}
472
473static int C_fcall
474redir_io()
475{
476    SECURITY_ATTRIBUTES sa;
477    sa.nLength = sizeof(SECURITY_ATTRIBUTES);
478    sa.bInheritHandle = TRUE;
479    sa.lpSecurityDescriptor = NULL;
480
481    zero_handles();
482
483    C_save0 = GetStdHandle(STD_INPUT_HANDLE);
484    C_save1 = GetStdHandle(STD_OUTPUT_HANDLE);
485    if (!CreatePipe(&C_rd0, &C_wr0, &sa, 0)
486            || !SetStdHandle(STD_INPUT_HANDLE, C_rd0)
487            || !DuplicateHandle(GetCurrentProcess(), C_wr0, GetCurrentProcess(),
488                &C_wr0_, 0, FALSE, DUPLICATE_SAME_ACCESS)
489            || !CreatePipe(&C_rd1, &C_wr1, &sa, 0)
490            || !SetStdHandle(STD_OUTPUT_HANDLE, C_wr1)
491            || !DuplicateHandle(GetCurrentProcess(), C_rd1, GetCurrentProcess(),
492                &C_rd1_, 0, FALSE, DUPLICATE_SAME_ACCESS))
493    {
494        set_last_errno();
495        close_handles();
496        return 0;
497    }
498
499    CloseHandle(C_wr0);
500    C_wr0 = INVALID_HANDLE_VALUE;
501    CloseHandle(C_rd1);
502    C_rd1 = INVALID_HANDLE_VALUE;
503    return 1;
504}
505
506static int C_fcall
507run_process(char *cmdline)
508{
509    PROCESS_INFORMATION pi;
510    STARTUPINFO si;
511
512    ZeroMemory(&pi, sizeof(PROCESS_INFORMATION));
513    ZeroMemory(&si, sizeof(STARTUPINFO));
514    si.cb = sizeof(STARTUPINFO);
515
516    C_wr0_ = C_rd1_ = INVALID_HANDLE_VALUE; /* these handles are saved */
517
518    if (CreateProcess(NULL, cmdline, NULL, NULL, TRUE, 0, NULL,
519                      NULL, &si, &pi))
520    {
521        CloseHandle(pi.hThread);
522
523        SetStdHandle(STD_INPUT_HANDLE, C_save0);
524        SetStdHandle(STD_OUTPUT_HANDLE, C_save1);
525        C_save0 = C_save1 = INVALID_HANDLE_VALUE;
526
527        CloseHandle(C_rd0);
528        CloseHandle(C_wr1);
529        C_rd0 = C_wr1 = INVALID_HANDLE_VALUE;
530        return (int)pi.hProcess;
531    }
532    else
533        return set_last_errno();
534}
535
536static int C_fcall
537pipe_write(int hpipe, void* buf, int count)
538{
539    DWORD done = 0;
540    if (WriteFile((HANDLE)hpipe, buf, count, &done, NULL))
541        return 1;
542    else
543        return set_last_errno();
544}
545
546static int C_fcall
547pipe_read(int hpipe)
548{
549    DWORD done = 0;
550    /* TODO:
551    if (!pipe_ready(hpipe))
552        go_to_sleep;
553    */
554    if (ReadFile((HANDLE)hpipe, &C_rdbuf, 1, &done, NULL))
555    {
556        if (done > 0) /* not EOF yet */
557            return 1;
558        else
559            return -1;
560    }
561    return set_last_errno();
562}
563
564static int C_fcall
565pipe_ready(int hpipe)
566{
567    DWORD avail = 0;
568    if (PeekNamedPipe((HANDLE)hpipe, NULL, 0, NULL, &avail, NULL) && avail)
569        return 1;
570    else
571    {
572        Sleep(0); /* give pipe a chance */
573        if (PeekNamedPipe((HANDLE)hpipe, NULL, 0, NULL, &avail, NULL))
574            return (avail > 0);
575        else
576            return 0;
577    }
578}
579
580#define C_zero_handles() C_fix(zero_handles())
581#define C_close_handles() C_fix(close_handles())
582#define C_redir_io() (redir_io() ? C_SCHEME_TRUE : C_SCHEME_FALSE)
583#define C_run_process(cmdline) C_fix(run_process(C_c_string(cmdline)))
584#define C_pipe_write(h, b, n) (pipe_write(C_unfix(h), C_c_string(b), C_unfix(n)) ? C_SCHEME_TRUE : C_SCHEME_FALSE)
585#define C_pipe_read(h) C_fix(pipe_read(C_unfix(h)))
586#define C_pipe_ready(h) (pipe_ready(C_unfix(h)) ? C_SCHEME_TRUE : C_SCHEME_FALSE)
587#define close_handle(h) CloseHandle((HANDLE)h)
588
589static int C_fcall
590process_wait(int h, int t)
591{
592    if (WaitForSingleObject((HANDLE)h, (t ? 0 : INFINITE)) == WAIT_OBJECT_0)
593    {
594        DWORD ret;
595        if (GetExitCodeProcess((HANDLE)h, &ret))
596        {
597            CloseHandle((HANDLE)h);
598            C_exstatus = ret;
599            return 1;
600        }
601    }
602    return set_last_errno();
603}
604
605#define C_process_wait(p, t) (process_wait(C_unfix(p), C_truep(t)) ? C_SCHEME_TRUE : C_SCHEME_FALSE)
606#define C_sleep(t) (Sleep(C_unfix(t) * 1000), C_SCHEME_UNDEFINED)
607
608static int C_fcall
609get_hostname()
610{
611    /* Do we already have hostname? */
612    if (strlen(C_hostname))
613    {
614        return 1;
615    }
616    else
617    {
618        WSADATA wsa;
619        if (WSAStartup(MAKEWORD(1, 1), &wsa) == 0)
620        {
621            int nok = gethostname(C_hostname, sizeof(C_hostname));
622            WSACleanup();
623            return !nok;
624        }
625        return 0;
626    }
627}
628
629static int C_fcall
630sysinfo()
631{
632    /* Do we need to build the sysinfo? */
633    if (!strlen(C_osrel))
634    {
635        OSVERSIONINFO ovf;
636        ZeroMemory(&ovf, sizeof(ovf));
637        ovf.dwOSVersionInfoSize = sizeof(ovf);
638        if (get_hostname() && GetVersionEx(&ovf))
639        {
640            SYSTEM_INFO si;
641            _snprintf(C_osver, sizeof(C_osver) - 1, "%d.%d.%d",
642                        ovf.dwMajorVersion, ovf.dwMinorVersion, ovf.dwBuildNumber);
643            strncpy(C_osrel, "Win", sizeof(C_osrel) - 1);
644            switch (ovf.dwPlatformId)
645            {
646            case VER_PLATFORM_WIN32s:
647                strncpy(C_osrel, "Win32s", sizeof(C_osrel) - 1);
648                break;
649            case VER_PLATFORM_WIN32_WINDOWS:
650                if (ovf.dwMajorVersion == 4)
651                {
652                    if (ovf.dwMinorVersion == 0)
653                        strncpy(C_osrel, "Win95", sizeof(C_osrel) - 1);
654                    else if (ovf.dwMinorVersion == 10)
655                        strncpy(C_osrel, "Win98", sizeof(C_osrel) - 1);
656                    else if (ovf.dwMinorVersion == 90)
657                        strncpy(C_osrel, "WinMe", sizeof(C_osrel) - 1);
658                }
659                break;
660            case VER_PLATFORM_WIN32_NT:
661                C_isNT = 1;
662                if (ovf.dwMajorVersion == 6)
663                    strncpy(C_osrel, "WinVista", sizeof(C_osrel) - 1);
664                else if (ovf.dwMajorVersion == 5)
665                {
666                    if (ovf.dwMinorVersion == 2)
667                        strncpy(C_osrel, "WinServer2003", sizeof(C_osrel) - 1);
668                    else if (ovf.dwMinorVersion == 1)
669                        strncpy(C_osrel, "WinXP", sizeof(C_osrel) - 1);
670                    else if ( ovf.dwMinorVersion == 0)
671                        strncpy(C_osrel, "Win2000", sizeof(C_osrel) - 1);
672                }
673                else if (ovf.dwMajorVersion <= 4)
674                   strncpy(C_osrel, "WinNT", sizeof(C_osrel) - 1);
675                break;
676            }
677            GetSystemInfo(&si);
678            strncpy(C_processor, "Unknown", sizeof(C_processor) - 1);
679            switch (si.wProcessorArchitecture)
680            {
681            case PROCESSOR_ARCHITECTURE_INTEL:
682                strncpy(C_processor, "x86", sizeof(C_processor) - 1);
683                break;
684#           ifdef PROCESSOR_ARCHITECTURE_IA64
685            case PROCESSOR_ARCHITECTURE_IA64:
686                strncpy(C_processor, "IA64", sizeof(C_processor) - 1);
687                break;
688#           endif
689#           ifdef PROCESSOR_ARCHITECTURE_AMD64
690            case PROCESSOR_ARCHITECTURE_AMD64:
691                strncpy(C_processor, "x64", sizeof(C_processor) - 1);
692                break;
693#           endif
694#           ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
695            case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64:
696                strncpy(C_processor, "WOW64", sizeof(C_processor) - 1);
697                break;
698#           endif
699            }
700        }
701        else
702            return set_last_errno();
703    }
704    return 1;
705}
706
707static int C_fcall
708get_shlcmd()
709{
710    /* Do we need to build the shell command pathname? */
711    if (!strlen(C_shlcmd))
712    {
713        if (sysinfo())
714        {
715            char *cmdnam = C_isNT ? "\\cmd.exe" : "\\command.com";
716            UINT len = GetSystemDirectory(C_shlcmd, sizeof(C_shlcmd) - strlen(cmdnam));
717            if (len)
718                strcpy(C_shlcmd + len, cmdnam);
719            else
720                return set_last_errno();
721        }
722        else
723            return 0;
724    }
725    return 1;
726}
727
728#define C_get_hostname() (get_hostname() ? C_SCHEME_TRUE : C_SCHEME_FALSE)
729#define C_sysinfo() (sysinfo() ? C_SCHEME_TRUE : C_SCHEME_FALSE)
730#define C_get_shlcmd() (get_shlcmd() ? C_SCHEME_TRUE : C_SCHEME_FALSE)
731
732/* GetUserName */
733
734static int C_fcall
735get_user_name()
736{
737    if (!strlen(C_username))
738    {
739        DWORD bufCharCount = sizeof(C_username) / sizeof(C_username[0]);
740        if (!GetUserName(C_username, &bufCharCount))
741            return set_last_errno();
742    }
743    return 1;
744}
745
746#define C_get_user_name() (get_user_name() ? C_SCHEME_TRUE : C_SCHEME_FALSE)
747
748/* User Information */
749
750#if 0
751static int C_fcall
752get_netinfo()
753{
754    HINSTANCE hNet = 0,
755              hLoc = 0;
756
757    if (isNT)
758        hNet = LoadLibrary("netapi32.dll");
759    else
760    {
761        hLoc = LoadLibrary("rlocal32.dll");
762        hNet = LoadLibrary("radmin32.dll");
763        //hNet = LoadLibrary("netapi.dll");
764    }
765
766    if (!hNet)
767        return 0;
768
769   
770}
771#endif
772
773/*
774    Spawn a process directly.
775    Params:
776    app         Command to execute.
777    cmdlin      Command line (arguments).
778    env         Environment for the new process (may be NULL).
779    handle, stdin, stdout, stderr
780                Spawned process info are returned in integers.
781                When spawned process shares standard io stream with the parent
782                process the respective value in handle, stdin, stdout, stderr
783                is -1.
784    params      A bitmask controling operation.
785                Bit 1: Child & parent share standard input if this bit is set.
786                Bit 2: Share standard output if bit is set.
787                Bit 3: Share standard error if bit is set.
788
789    Returns: zero return value indicates failure.
790*/
791static int C_fcall
792C_process(const char * app, const char * cmdlin, const char ** env,
793          int * phandle,
794          int * pstdin_fd, int * pstdout_fd, int * pstderr_fd,
795          int params)
796{
797    int i;
798    int success = TRUE;
799    const int f_share_io[3] = { params & 1, params & 2, params & 4};
800    int io_fds[3] = { -1, -1, -1 };
801    HANDLE
802        child_io_handles[3] = { NULL, NULL, NULL },
803        standard_io_handles[3] = {
804            GetStdHandle(STD_INPUT_HANDLE),
805            GetStdHandle(STD_OUTPUT_HANDLE),
806            GetStdHandle(STD_ERROR_HANDLE)};
807    const char modes[3] = "rww";
808    HANDLE cur_process = GetCurrentProcess(), child_process = NULL;
809    void* envblk = NULL;
810
811    /****** create io handles & fds ***/
812
813    for (i=0; i<3 && success; ++i)
814    {
815        if (f_share_io[i])
816        {
817            success = DuplicateHandle(
818                cur_process, standard_io_handles[i],
819                cur_process, &child_io_handles[i],
820                0, FALSE, DUPLICATE_SAME_ACCESS);
821        }
822        else
823        {
824            HANDLE a, b;
825            success = CreatePipe(&a,&b,NULL,0);
826            if(success)
827            {
828                HANDLE parent_end;
829                if (modes[i]=='r') { child_io_handles[i]=a; parent_end=b; }
830                else               { parent_end=a; child_io_handles[i]=b; }
831                success = (io_fds[i] = _open_osfhandle((long)parent_end,0)) >= 0;
832            }
833        }
834    }
835
836    /****** make handles inheritable */
837
838    for (i=0; i<3 && success; ++i)
839        success = SetHandleInformation(child_io_handles[i], HANDLE_FLAG_INHERIT, -1);
840
841#if 0 /* Requires a sorted list by key! */
842    /****** create environment block if necessary ****/
843
844    if (env && success)
845    {
846        char** p;
847        int len = 0;
848
849        for (p = env; *p; ++p) len += strlen(*p) + 1;
850
851        if (envblk = C_malloc(len + 1))
852        {
853            char* pb = (char*)envblk;
854            for (p = env; *p; ++p)
855            {
856                strcpy(pb, *p);
857                pb += strlen(*p) + 1;
858            }
859            *pb = '\0';
860        }
861        else
862            success = FALSE;
863    }
864#endif
865
866    /****** finally spawn process ****/
867
868    if (success)
869    {
870        PROCESS_INFORMATION pi;
871        STARTUPINFO si;
872
873        ZeroMemory(&pi,sizeof pi);
874        ZeroMemory(&si,sizeof si);
875        si.cb = sizeof si;
876        si.dwFlags = STARTF_USESTDHANDLES;
877        si.hStdInput = child_io_handles[0];
878        si.hStdOutput = child_io_handles[1];
879        si.hStdError = child_io_handles[2];
880
881        /* FIXME passing 'app' param causes failure & possible stack corruption */
882        success = CreateProcess(
883            NULL, (char*)cmdlin, NULL, NULL, TRUE, 0, envblk, NULL, &si, &pi);
884
885        if (success)
886        {
887            child_process=pi.hProcess;
888            CloseHandle(pi.hThread);
889        }
890        else
891            set_last_errno();
892    }
893    else
894        set_last_errno();
895
896    /****** cleanup & return *********/
897
898    /* parent must close child end */
899    for (i=0; i<3; ++i) CloseHandle(child_io_handles[i]);
900
901    if (success)
902    {
903        *phandle = (int)child_process;
904        *pstdin_fd = io_fds[0];
905        *pstdout_fd = io_fds[1];
906        *pstderr_fd = io_fds[2];
907    }
908    else
909    {
910        for (i=0; i<3; ++i) _close(io_fds[i]);
911    }
912
913    return success;
914}
915EOF
916) )
917
918(cond-expand
919 [paranoia]
920 [else
921  (declare
922    (no-bound-checks)
923    (no-procedure-checks-for-usual-bindings)
924    (bound-to-procedure
925     ##sys#make-port ##sys#file-info ##sys#update-errno ##sys#fudge ##sys#make-c-string ##sys#check-port
926     ##sys#error ##sys#signal-hook ##sys#peek-unsigned-integer ##sys#process
927     ##sys#peek-fixnum ##sys#make-structure ##sys#check-structure ##sys#enable-interrupts) ) ] )
928
929(include "unsafe-declarations.scm")
930
931(register-feature! 'posix)
932
933(define posix-error
934  (let ([strerror (foreign-lambda c-string "strerror" int)]
935        [string-append string-append] )
936    (lambda (type loc msg . args)
937      (let ([rn (##sys#update-errno)])
938        (apply ##sys#signal-hook type loc (string-append msg " - " (strerror rn)) args) ) ) ) )
939
940(define ##sys#posix-error posix-error)
941
942
943;;; Lo-level I/O:
944
945(define-foreign-variable _pipe_buf int "PIPE_BUF")
946
947(define pipe/buf _pipe_buf)
948
949(define-foreign-variable _o_rdonly int "O_RDONLY")
950(define-foreign-variable _o_wronly int "O_WRONLY")
951(define-foreign-variable _o_rdwr int "O_RDWR")
952(define-foreign-variable _o_creat int "O_CREAT")
953(define-foreign-variable _o_append int "O_APPEND")
954(define-foreign-variable _o_excl int "O_EXCL")
955(define-foreign-variable _o_trunc int "O_TRUNC")
956(define-foreign-variable _o_binary int "O_BINARY")
957(define-foreign-variable _o_text int "O_TEXT")
958(define-foreign-variable _o_noinherit int "O_NOINHERIT")
959
960(define open/rdonly _o_rdonly)
961(define open/wronly _o_wronly)
962(define open/rdwr _o_rdwr)
963(define open/read _o_rdwr)
964(define open/write _o_wronly)
965(define open/creat _o_creat)
966(define open/append _o_append)
967(define open/excl _o_excl)
968(define open/trunc _o_trunc)
969(define open/binary _o_binary)
970(define open/text _o_text)
971(define open/noinherit _o_noinherit)
972
973(define-foreign-variable _s_irusr int "S_IREAD")
974(define-foreign-variable _s_iwusr int "S_IWRITE")
975(define-foreign-variable _s_ixusr int "S_IEXEC")
976(define-foreign-variable _s_irgrp int "S_IREAD")
977(define-foreign-variable _s_iwgrp int "S_IWRITE")
978(define-foreign-variable _s_ixgrp int "S_IEXEC")
979(define-foreign-variable _s_iroth int "S_IREAD")
980(define-foreign-variable _s_iwoth int "S_IWRITE")
981(define-foreign-variable _s_ixoth int "S_IEXEC")
982(define-foreign-variable _s_irwxu int "S_IREAD | S_IWRITE | S_IEXEC")
983(define-foreign-variable _s_irwxg int "S_IREAD | S_IWRITE | S_IEXEC")
984(define-foreign-variable _s_irwxo int "S_IREAD | S_IWRITE | S_IEXEC")
985
986(define perm/irusr _s_irusr)
987(define perm/iwusr _s_iwusr)
988(define perm/ixusr _s_ixusr)
989(define perm/irgrp _s_irgrp)
990(define perm/iwgrp _s_iwgrp)
991(define perm/ixgrp _s_ixgrp)
992(define perm/iroth _s_iroth)
993(define perm/iwoth _s_iwoth)
994(define perm/ixoth _s_ixoth)
995(define perm/irwxu _s_irwxu)
996(define perm/irwxg _s_irwxg)
997(define perm/irwxo _s_irwxo)
998
999(define file-open
1000  (let ([defmode (bitwise-ior _s_irwxu (fxior _s_irgrp _s_iroth))] )
1001    (lambda (filename flags . mode)
1002      (let ([mode (if (pair? mode) (car mode) defmode)])
1003        (##sys#check-string filename 'file-open)
1004        (##sys#check-exact flags 'file-open)
1005        (##sys#check-exact mode 'file-open)
1006        (let ([fd (##core#inline "C_open" (##sys#make-c-string (##sys#expand-home-path filename)) flags mode)])
1007          (when (eq? -1 fd)
1008            (##sys#update-errno)
1009            (##sys#signal-hook #:file-error 'file-open "cannot open file" filename flags mode) )
1010          fd) ) ) ) )
1011
1012(define file-close
1013  (lambda (fd)
1014    (##sys#check-exact fd 'file-close)
1015    (when (fx< (##core#inline "C_close" fd) 0)
1016      (##sys#update-errno)
1017      (##sys#signal-hook #:file-error 'file-close "cannot close file" fd) ) ) )
1018
1019(define file-read
1020  (let ([make-string make-string] )
1021    (lambda (fd size . buffer)
1022      (##sys#check-exact fd 'file-read)
1023      (##sys#check-exact size 'file-read)
1024      (let ([buf (if (pair? buffer) (car buffer) (make-string size))])
1025        (unless (and (##core#inline "C_blockp" buf) (##core#inline "C_byteblockp" buf))
1026          (##sys#signal-hook #:type-error 'file-read "bad argument type - not a string or blob" buf) )
1027        (let ([n (##core#inline "C_read" fd buf size)])
1028          (when (eq? -1 n)
1029            (##sys#update-errno)
1030            (##sys#signal-hook #:file-error 'file-read "cannot read from file" fd size) )
1031          (list buf n) ) ) ) ) )
1032
1033(define file-write
1034  (lambda (fd buffer . size)
1035    (##sys#check-exact fd 'file-write)
1036    (unless (and (##core#inline "C_blockp" buffer) (##core#inline "C_byteblockp" buffer))
1037      (##sys#signal-hook #:type-error 'file-write "bad argument type - not a string or blob" buffer) )
1038    (let ([size (if (pair? size) (car size) (##sys#size buffer))])
1039      (##sys#check-exact size 'file-write)
1040      (let ([n (##core#inline "C_write" fd buffer size)])
1041        (when (eq? -1 n)
1042          (##sys#update-errno)
1043          (##sys#signal-hook #:file-error 'file-write "cannot write to file" fd size) )
1044        n) ) ) )
1045
1046(define file-mkstemp
1047  (let ([string-length string-length])
1048    (lambda (template)
1049      (##sys#check-string template 'file-mkstemp)
1050      (let* ([buf (##sys#make-c-string template)]
1051             [fd (##core#inline "C_mkstemp" buf)]
1052             [path-length (string-length buf)])
1053        (when (eq? -1 fd)
1054          (##sys#update-errno)
1055          (##sys#signal-hook #:file-error 'file-mkstemp "cannot create temporary file" template) )
1056        (values fd (##sys#substring buf 0 (fx- path-length 1) ) ) ) ) ) )
1057
1058
1059;;; File attribute access:
1060
1061(define-foreign-variable _seek_set int "SEEK_SET")
1062(define-foreign-variable _seek_cur int "SEEK_CUR")
1063(define-foreign-variable _seek_end int "SEEK_END")
1064
1065(define seek/set _seek_set)
1066(define seek/end _seek_end)
1067(define seek/cur _seek_cur)
1068
1069(define-foreign-variable _stat_st_ino unsigned-int "C_statbuf.st_ino")
1070(define-foreign-variable _stat_st_nlink unsigned-int "C_statbuf.st_nlink")
1071(define-foreign-variable _stat_st_gid unsigned-int "C_statbuf.st_gid")
1072(define-foreign-variable _stat_st_size unsigned-int "C_statbuf.st_size")
1073(define-foreign-variable _stat_st_mtime double "C_statbuf.st_mtime")
1074(define-foreign-variable _stat_st_atime double "C_statbuf.st_atime")
1075(define-foreign-variable _stat_st_ctime double "C_statbuf.st_ctime")
1076(define-foreign-variable _stat_st_uid unsigned-int "C_statbuf.st_uid")
1077(define-foreign-variable _stat_st_mode unsigned-int "C_statbuf.st_mode")
1078
1079(define (##sys#stat file)
1080  (let ([r (cond [(fixnum? file) (##core#inline "C_fstat" file)]
1081                 [(string? file) (##core#inline "C_stat" (##sys#make-c-string (##sys#expand-home-path file)))]
1082                 [else (##sys#signal-hook #:type-error "bad argument type - not a fixnum or string" file)] ) ] )
1083    (when (fx< r 0)
1084      (##sys#update-errno)
1085      (##sys#signal-hook #:file-error "cannot access file" file) ) ) )
1086
1087(define (file-stat f #!optional link)
1088  (##sys#stat f)
1089  (vector _stat_st_ino _stat_st_mode _stat_st_nlink
1090          _stat_st_uid _stat_st_gid _stat_st_size
1091          _stat_st_atime _stat_st_ctime _stat_st_mtime
1092          0 0 0 0) )
1093
1094(define (file-size f) (##sys#stat f) _stat_st_size)
1095(define (file-modification-time f) (##sys#stat f) _stat_st_mtime)
1096(define (file-access-time f) (##sys#stat f) _stat_st_atime)
1097(define (file-change-time f) (##sys#stat f) _stat_st_ctime)
1098(define (file-owner f) (##sys#stat f) _stat_st_uid)
1099(define (file-permissions f) (##sys#stat f) _stat_st_mode)
1100
1101(define (regular-file? fname)
1102  (##sys#check-string fname 'regular-file?)
1103  (let ((info (##sys#file-info (##sys#expand-home-path fname))))
1104    (and info (fx= 0 (##sys#slot info 4))) ) )
1105
1106(define (symbolic-link? fname)
1107  (##sys#check-string fname 'symbolic-link?)
1108  #f)
1109
1110(let ((stat-type
1111         (lambda (name)
1112             (lambda (fname)
1113                 (##sys#check-string fname name)
1114                 #f))))
1115    (set! stat-regular? regular-file?)  ; DEPRECATED
1116    (set! stat-directory? (stat-type 'stat-directory?)) ; DEPRECATED
1117    (set! stat-device? (stat-type 'stat-char-device?))  ; DEPRECATED
1118    (set! character-device? (stat-type 'character-device?))
1119    (set! block-device? (stat-type 'block-device?))
1120    (set! stat-block-device? (stat-type 'stat-block-device?)) ; DEPRECATED
1121    (set! stat-fifo? (stat-type 'stat-fifo?))                 ; DEPRECATED
1122    (set! fifo? (stat-type 'fifo?))
1123    (set! stat-symlink? (stat-type 'stat-symlink?)) ; DEPRECATED
1124    (set! socket? (stat-type 'socket?))
1125    (set! stat-socket? (stat-type 'stat-socket?))) ; DEPRECATED
1126
1127(define set-file-position!
1128  (lambda (port pos . whence)
1129    (let ([whence (if (pair? whence) (car whence) _seek_set)])
1130      (##sys#check-exact pos 'set-file-position!)
1131      (##sys#check-exact whence 'set-file-position!)
1132      (when (fx< pos 0) (##sys#signal-hook #:bounds-error 'set-file-position! "invalid negative port position" pos port))
1133      (unless (cond [(port? port)
1134                     (and (eq? (##sys#slot port 7) 'stream)
1135                          (##core#inline "C_fseek" port pos whence) ) ]
1136                    [(fixnum? port) (##core#inline "C_lseek" port pos whence)]
1137                    [else (##sys#signal-hook #:type-error 'set-file-position! "invalid file" port)] )
1138        (##sys#update-errno)
1139        (##sys#signal-hook #:file-error 'set-file-position! "cannot set file position" port pos) ) ) ) )
1140
1141(define file-position
1142  (getter-with-setter
1143   (lambda (port)
1144     (let ([pos (cond [(port? port)
1145                       (if (eq? (##sys#slot port 7) 'stream)
1146                           (##core#inline "C_ftell" port)
1147                           -1) ]
1148                      [(fixnum? port) (##core#inline "C_lseek" port 0 _seek_cur)]
1149                      [else (##sys#signal-hook #:type-error 'file-position "invalid file" port)] ) ] )
1150       (when (fx< pos 0)
1151         (##sys#update-errno)
1152         (##sys#signal-hook #:file-error 'file-position "cannot retrieve file position of port" port) )
1153       pos) )
1154   set-file-position!) )                ; doesn't accept WHENCE argument
1155
1156
1157;;; Directory stuff:
1158
1159(define-inline (create-directory-helper name)
1160    (unless (zero? (##core#inline "C_mkdir" (##sys#make-c-string name)))
1161            (##sys#update-errno)
1162            (##sys#signal-hook #:file-error 'create-directory
1163                               "cannot create directory" name)))
1164
1165(define-inline (create-directory-check name)
1166    (if (file-exists? name)
1167        (let ((i   (##sys#file-info name)))
1168            (and i
1169                 (fx= 1 (##sys#slot i 4))))
1170        #f))
1171
1172(define-inline (create-directory-helper-silent name)
1173    (unless (create-directory-check name)
1174            (create-directory-helper name)))
1175
1176(define-inline (create-directory-helper-parents name)
1177    (let* ((l   (string-split name "\\"))
1178           (c   (car l)))
1179        (for-each
1180             (lambda (x)
1181                 (set! c (string-append c "\\" x))
1182                 (create-directory-helper-silent c))
1183             (cdr l))))
1184
1185(define create-directory
1186  (lambda (name #!optional parents?)
1187    (##sys#check-string name 'create-directory)
1188    (if parents?
1189        (create-directory-helper-parents (canonical-path name))
1190        (create-directory-helper (canonical-path name)))))
1191;(define create-directory
1192;  (lambda (name)
1193;    (##sys#check-string name 'create-directory)
1194;    (unless (zero? (##core#inline "C_mkdir" (##sys#make-c-string (##sys#expand-home-path name))))
1195;      (##sys#update-errno)
1196;      (##sys#signal-hook #:file-error 'create-directory "cannot create directory" name) ) ) )
1197
1198(define change-directory
1199  (lambda (name)
1200    (##sys#check-string name 'change-directory)
1201    (unless (zero? (##core#inline "C_chdir" (##sys#make-c-string (##sys#expand-home-path name))))
1202      (##sys#update-errno)
1203      (##sys#signal-hook #:file-error 'change-directory "cannot change current directory" name) ) ) )
1204
1205(define delete-directory
1206  (lambda (name)
1207    (##sys#check-string name 'delete-directory)
1208    (unless (zero? (##core#inline "C_rmdir" (##sys#make-c-string (##sys#expand-home-path name))))
1209      (##sys#update-errno)
1210      (##sys#signal-hook #:file-error 'delete-directory "cannot delete directory" name) ) ) )
1211
1212(define directory
1213  (let ([string-append string-append]
1214        [make-string make-string]
1215        [string string])
1216    (lambda (#!optional (spec (current-directory)) show-dotfiles?)
1217      (##sys#check-string spec 'directory)
1218      (let ([buffer (make-string 256)]
1219            [handle (##sys#make-pointer)]
1220            [entry (##sys#make-pointer)] )
1221        (##core#inline "C_opendir" (##sys#make-c-string (##sys#expand-home-path spec)) handle)
1222        (if (##sys#null-pointer? handle)
1223            (begin
1224              (##sys#update-errno)
1225              (##sys#signal-hook #:file-error 'directory "cannot open directory" spec) )
1226            (let loop ()
1227              (##core#inline "C_readdir" handle entry)
1228              (if (##sys#null-pointer? entry)
1229                  (begin
1230                    (##core#inline "C_closedir" handle)
1231                    '() )
1232                  (let* ([flen (##core#inline "C_foundfile" entry buffer)]
1233                         [file (##sys#substring buffer 0 flen)]
1234                         [char1 (string-ref file 0)]
1235                         [char2 (and (> flen 1) (string-ref file 1))] )
1236                    (if (and (eq? char1 #\.)
1237                             (or (not char2)
1238                                 (and (eq? char2 #\.) (eq? flen 2))
1239                                 (not show-dotfiles?) ) )
1240                        (loop)
1241                        (cons file (loop)) ) ) ) ) ) ) ) ) )
1242
1243(define (directory? fname)
1244  (##sys#check-string fname 'directory?)
1245  (let ((info (##sys#file-info
1246                (##sys#platform-fixup-pathname (##sys#expand-home-path fname)))))
1247    (and info (fx= 1 (##sys#slot info 4))) ) )
1248
1249(define current-directory
1250  (let ([make-string make-string])
1251    (lambda (#!optional dir)
1252      (if dir
1253          (change-directory dir)
1254          (let* ([buffer (make-string 256)]
1255                 [len (##core#inline "C_curdir" buffer)] )
1256            (##sys#update-errno)
1257            (if len
1258                (##sys#substring buffer 0 len)
1259                (##sys#signal-hook #:file-error 'current-directory "cannot retrieve current directory") ) ) ) ) ) )
1260
1261
1262(define canonical-path
1263    (let ((null?      null?)
1264          (char=?     char=?)
1265          (string=?   string=?)
1266          (alpha?     char-alphabetic?)
1267          (sref       string-ref)
1268          (ssplit     (cut string-split <> "/\\"))
1269          (sappend    string-append)
1270          (isperse    (cut string-intersperse <> "\\"))
1271          (sep?       (lambda (c) (or (char=? #\/ c) (char=? #\\ c))))
1272          (user       current-user-name)
1273          (cwd        (let ((cw   current-directory))
1274                          (lambda ()
1275                              (condition-case (cw)
1276                                  (var ()    "c:\\"))))))
1277        (lambda (path)
1278            (##sys#check-string path 'canonical-path)
1279            (let ((p   (cond ((fx= 0 (##sys#size path))
1280                                 (sappend (cwd) "\\"))
1281                             ((and (fx< (##sys#size path) 3)
1282                                   (sep? (sref path 0)))
1283                                 (sappend
1284                                     (##sys#substring (cwd) 0 2)
1285                                     path))
1286                             ((fx= 1 (##sys#size path))
1287                                 (sappend (cwd) "\\" path))
1288                             ((and (char=? #\~ (sref path 0))
1289                                   (sep? (sref path 1)))
1290                                 (sappend
1291                                     (##sys#substring (cwd) 0 3)
1292                                     "Documents and Settings\\"
1293                                     (user)
1294                                     (##sys#substring path 1
1295                                         (##sys#size path))))
1296                             ((fx= 2 (##sys#size path))
1297                                 (sappend (cwd) "\\" path))
1298                             ((and (alpha? (sref path 0))
1299                                   (char=? #\: (sref path 1))
1300                                   (sep? (sref path 2)))
1301                                 path)
1302                             ((and (char=? #\/ (sref path 0))
1303                                   (alpha? (sref path 1))
1304                                   (char=? #\: (sref path 2)))
1305                                 (sappend
1306                                     (##sys#substring path 1 3)
1307                                     "\\"
1308                                     (##sys#substring path 3
1309                                         (##sys#size path))))
1310                             ((sep? (sref path 0))
1311                                 (sappend
1312                                     (##sys#substring (cwd) 0 2)
1313                                     path))
1314                             (else
1315                                 (sappend (cwd) "\\" path)))))
1316                (let loop ((l   (ssplit (##sys#substring p 3 (##sys#size p))))
1317                           (r   '()))
1318                    (if (null? l)
1319                        (if (null? r)
1320                            (##sys#substring p 0 3)
1321                            (if (sep? (sref p (- (##sys#size p) 1)))
1322                                (sappend
1323                                    (##sys#substring p 0 3)
1324                                    (isperse (reverse (cons "" r))))
1325                                (sappend
1326                                    (##sys#substring p 0 3)
1327                                    (isperse (reverse r)))))
1328                        (loop
1329                            (cdr l)
1330                            (if (string=? ".." (car l))
1331                                (cdr r)
1332                                (if (string=? "." (car l))
1333                                    r
1334                                    (cons (car l) r))))))))))
1335                           
1336
1337;;; Pipes:
1338
1339(let ()
1340  (define (mode arg) (if (pair? arg) (##sys#slot arg 0) '###text))
1341  (define (badmode m) (##sys#error "illegal input/output mode specifier" m))
1342  (define (check cmd inp r)
1343    (##sys#update-errno)
1344    (if (##sys#null-pointer? r)
1345        (##sys#signal-hook #:file-error "cannot open pipe" cmd)
1346        (let ([port (##sys#make-port inp ##sys#stream-port-class "(pipe)" 'stream)])
1347          (##core#inline "C_set_file_ptr" port r)
1348          port) ) )
1349  (set! open-input-pipe
1350    (lambda (cmd . m)
1351      (##sys#check-string cmd 'open-input-pipe)
1352      (let ([m (mode m)])
1353        (check
1354         cmd #t
1355         (case m
1356           ((###text) (##core#inline_allocate ("open_text_input_pipe" 2) (##sys#make-c-string cmd)))
1357           ((###binary) (##core#inline_allocate ("open_binary_input_pipe" 2) (##sys#make-c-string cmd)))
1358           (else (badmode m)) ) ) ) ) )
1359  (set! open-output-pipe
1360    (lambda (cmd . m)
1361      (##sys#check-string cmd 'open-output-pipe)
1362      (let ((m (mode m)))
1363        (check
1364         cmd #f
1365         (case m
1366           ((###text) (##core#inline_allocate ("open_text_output_pipe" 2) (##sys#make-c-string cmd)))
1367           ((###binary) (##core#inline_allocate ("open_binary_output_pipe" 2) (##sys#make-c-string cmd)))
1368           (else (badmode m)) ) ) ) ) )
1369  (set! close-input-pipe
1370    (lambda (port)
1371      (##sys#check-port port 'close-input-pipe)
1372      (let ((r (##core#inline "close_pipe" port)))
1373        (##sys#update-errno)
1374        (when (eq? -1 r) (##sys#signal-hook #:file-error 'close-input-pipe "error while closing pipe" port)) ) ) )
1375  (set! close-output-pipe close-input-pipe) )
1376
1377(let ([open-input-pipe open-input-pipe]
1378      [open-output-pipe open-output-pipe]
1379      [close-input-pipe close-input-pipe]
1380      [close-output-pipe close-output-pipe] )
1381  (set! call-with-input-pipe
1382    (lambda (cmd proc . mode)
1383      (let ([p (apply open-input-pipe cmd mode)])
1384        (##sys#call-with-values
1385         (lambda () (proc p))
1386         (lambda results
1387           (close-input-pipe p)
1388           (apply values results) ) ) ) ) )
1389  (set! call-with-output-pipe
1390    (lambda (cmd proc . mode)
1391      (let ([p (apply open-output-pipe cmd mode)])
1392        (##sys#call-with-values
1393         (lambda () (proc p))
1394         (lambda results
1395           (close-output-pipe p)
1396           (apply values results) ) ) ) ) )
1397  (set! with-input-from-pipe
1398    (lambda (cmd thunk . mode)
1399      (let ([old ##sys#standard-input]
1400            [p (apply open-input-pipe cmd mode)] )
1401        (set! ##sys#standard-input p)
1402        (##sys#call-with-values thunk
1403          (lambda results
1404            (close-input-pipe p)
1405            (set! ##sys#standard-input old)
1406            (apply values results) ) ) ) ) )
1407  (set! with-output-to-pipe
1408    (lambda (cmd thunk . mode)
1409      (let ([old ##sys#standard-output]
1410            [p (apply open-output-pipe cmd mode)] )
1411        (set! ##sys#standard-output p)
1412        (##sys#call-with-values thunk
1413          (lambda results
1414            (close-output-pipe p)
1415            (set! ##sys#standard-output old)
1416            (apply values results) ) ) ) ) ) )
1417
1418
1419;;; Pipe primitive:
1420
1421(define-foreign-variable _pipefd0 int "C_pipefds[ 0 ]")
1422(define-foreign-variable _pipefd1 int "C_pipefds[ 1 ]")
1423
1424(define create-pipe
1425    (lambda (#!optional (mode (fxior open/binary open/noinherit)))
1426      (when (fx< (##core#inline "C_pipe" #f mode) 0)
1427        (##sys#update-errno)
1428        (##sys#signal-hook #:file-error 'create-pipe "cannot create pipe") )
1429      (values _pipefd0 _pipefd1) ) )
1430
1431;;; Signal processing:
1432
1433(define-foreign-variable _nsig int "NSIG")
1434(define-foreign-variable _sigterm int "SIGTERM")
1435(define-foreign-variable _sigint int "SIGINT")
1436(define-foreign-variable _sigfpe int "SIGFPE")
1437(define-foreign-variable _sigill int "SIGILL")
1438(define-foreign-variable _sigsegv int "SIGSEGV")
1439(define-foreign-variable _sigabrt int "SIGABRT")
1440(define-foreign-variable _sigbreak int "SIGBREAK")
1441
1442(define signal/term _sigterm)
1443(define signal/int _sigint)
1444(define signal/fpe _sigfpe)
1445(define signal/ill _sigill)
1446(define signal/segv _sigsegv)
1447(define signal/abrt _sigabrt)
1448(define signal/break _sigbreak)
1449(define signal/alrm 0)
1450(define signal/chld 0)
1451(define signal/cont 0)
1452(define signal/hup 0)
1453(define signal/io 0)
1454(define signal/kill 0)
1455(define signal/pipe 0)
1456(define signal/prof 0)
1457(define signal/quit 0)
1458(define signal/stop 0)
1459(define signal/trap 0)
1460(define signal/tstp 0)
1461(define signal/urg 0)
1462(define signal/usr1 0)
1463(define signal/usr2 0)
1464(define signal/vtalrm 0)
1465(define signal/winch 0)
1466(define signal/xcpu 0)
1467(define signal/xfsz 0)
1468
1469(define signals-list
1470  (list
1471    signal/term signal/int signal/fpe signal/ill
1472    signal/segv signal/abrt signal/break))
1473
1474(let ([oldhook ##sys#interrupt-hook]
1475      [sigvector (make-vector 256 #f)] )
1476  (set! signal-handler
1477    (lambda (sig)
1478      (##sys#check-exact sig 'signal-handler)
1479      (##sys#slot sigvector sig) ) )
1480  (set! set-signal-handler!
1481    (lambda (sig proc)
1482      (##sys#check-exact sig 'set-signal-handler!)
1483      (##core#inline "C_establish_signal_handler" sig (and proc sig))
1484      (vector-set! sigvector sig proc) ) )
1485  (set! ##sys#interrupt-hook
1486    (lambda (reason state)
1487      (let ([h (##sys#slot sigvector reason)])
1488        (if h
1489            (begin
1490              (h reason)
1491              (##sys#context-switch state) )
1492            (oldhook reason state) ) ) ) ) )
1493
1494;;; More errno codes:
1495
1496(define-foreign-variable _errno int "errno")
1497
1498(define-foreign-variable _eperm int "EPERM")
1499(define-foreign-variable _enoent int "ENOENT")
1500(define-foreign-variable _esrch int "ESRCH")
1501(define-foreign-variable _eintr int "EINTR")
1502(define-foreign-variable _eio int "EIO")
1503(define-foreign-variable _enoexec int "ENOEXEC")
1504(define-foreign-variable _ebadf int "EBADF")
1505(define-foreign-variable _echild int "ECHILD")
1506(define-foreign-variable _enomem int "ENOMEM")
1507(define-foreign-variable _eacces int "EACCES")
1508(define-foreign-variable _efault int "EFAULT")
1509(define-foreign-variable _ebusy int "EBUSY")
1510(define-foreign-variable _eexist int "EEXIST")
1511(define-foreign-variable _enotdir int "ENOTDIR")
1512(define-foreign-variable _eisdir int "EISDIR")
1513(define-foreign-variable _einval int "EINVAL")
1514(define-foreign-variable _emfile int "EMFILE")
1515(define-foreign-variable _enospc int "ENOSPC")
1516(define-foreign-variable _espipe int "ESPIPE")
1517(define-foreign-variable _epipe int "EPIPE")
1518(define-foreign-variable _eagain int "EAGAIN")
1519(define-foreign-variable _erofs int "EROFS")
1520(define-foreign-variable _enxio int "ENXIO")
1521(define-foreign-variable _e2big int "E2BIG")
1522(define-foreign-variable _exdev int "EXDEV")
1523(define-foreign-variable _enodev int "ENODEV")
1524(define-foreign-variable _enfile int "ENFILE")
1525(define-foreign-variable _enotty int "ENOTTY")
1526(define-foreign-variable _efbig int "EFBIG")
1527(define-foreign-variable _emlink int "EMLINK")
1528(define-foreign-variable _edom int "EDOM")
1529(define-foreign-variable _erange int "ERANGE")
1530(define-foreign-variable _edeadlk int "EDEADLK")
1531(define-foreign-variable _enametoolong int "ENAMETOOLONG")
1532(define-foreign-variable _enolck int "ENOLCK")
1533(define-foreign-variable _enosys int "ENOSYS")
1534(define-foreign-variable _enotempty int "ENOTEMPTY")
1535(define-foreign-variable _eilseq int "EILSEQ")
1536
1537(define errno/perm _eperm)
1538(define errno/noent _enoent)
1539(define errno/srch _esrch)
1540(define errno/intr _eintr)
1541(define errno/io _eio)
1542(define errno/noexec _enoexec)
1543(define errno/badf _ebadf)
1544(define errno/child _echild)
1545(define errno/nomem _enomem)
1546(define errno/acces _eacces)
1547(define errno/fault _efault)
1548(define errno/busy _ebusy)
1549(define errno/exist _eexist)
1550(define errno/notdir _enotdir)
1551(define errno/isdir _eisdir)
1552(define errno/inval _einval)
1553(define errno/mfile _emfile)
1554(define errno/nospc _enospc)
1555(define errno/spipe _espipe)
1556(define errno/pipe _epipe)
1557(define errno/again _eagain)
1558(define errno/rofs _erofs)
1559(define errno/nxio _enxio)
1560(define errno/2big _e2big)
1561(define errno/xdev _exdev)
1562(define errno/nodev _enodev)
1563(define errno/nfile _enfile)
1564(define errno/notty _enotty)
1565(define errno/fbig _efbig)
1566(define errno/mlink _emlink)
1567(define errno/dom _edom)
1568(define errno/range _erange)
1569(define errno/deadlk _edeadlk)
1570(define errno/nametoolong _enametoolong)
1571(define errno/nolck _enolck)
1572(define errno/nosys _enosys)
1573(define errno/notempty _enotempty)
1574(define errno/ilseq _eilseq)
1575
1576;;; Permissions and owners:
1577
1578(define change-file-mode
1579  (lambda (fname m)
1580    (##sys#check-string fname 'change-file-mode)
1581    (##sys#check-exact m 'change-file-mode)
1582    (when (fx< (##core#inline "C_chmod" (##sys#make-c-string (##sys#expand-home-path fname)) m) 0)
1583      (##sys#update-errno)
1584      (##sys#signal-hook #:file-error 'change-file-mode "cannot change file mode" fname m) ) ) )
1585
1586(define-foreign-variable _r_ok int "2")
1587(define-foreign-variable _w_ok int "4")
1588(define-foreign-variable _x_ok int "2")
1589
1590(let ()
1591  (define (check filename acc loc)
1592    (##sys#check-string filename loc)
1593    (let ([r (fx= 0 (##core#inline "C_access" (##sys#make-c-string (##sys#expand-home-path filename)) acc))])
1594      (unless r (##sys#update-errno))
1595      r) )
1596  (set! file-read-access? (lambda (filename) (check filename _r_ok 'file-read-access?)))
1597  (set! file-write-access? (lambda (filename) (check filename _w_ok 'file-write-access?)))
1598  (set! file-execute-access? (lambda (filename) (check filename _x_ok 'file-execute-access?))) )
1599
1600(define-foreign-variable _filename_max int "FILENAME_MAX")
1601
1602;;; Using file-descriptors:
1603
1604(define-foreign-variable _stdin_fileno int "0")
1605(define-foreign-variable _stdout_fileno int "1")
1606(define-foreign-variable _stderr_fileno int "2")
1607
1608(define fileno/stdin _stdin_fileno)
1609(define fileno/stdout _stdout_fileno)
1610(define fileno/stderr _stderr_fileno)
1611
1612(let ()
1613  (define (mode inp m)
1614    (##sys#make-c-string
1615     (cond [(pair? m)
1616            (let ([m (car m)])
1617              (case m
1618                [(###append) (if (not inp) "a" (##sys#error "invalid mode for input file" m))]
1619                [else (##sys#error "invalid mode argument" m)] ) ) ]
1620           [inp "r"]
1621           [else "w"] ) ) )
1622  (define (check fd inp r)
1623    (##sys#update-errno)
1624    (if (##sys#null-pointer? r)
1625        (##sys#signal-hook #:file-error "cannot open file" fd)
1626        (let ([port (##sys#make-port inp ##sys#stream-port-class "(fdport)" 'stream)])
1627          (##core#inline "C_set_file_ptr" port r)
1628          port) ) )
1629  (set! open-input-file*
1630    (lambda (fd . m)
1631      (##sys#check-exact fd 'open-input-file*)
1632      (check fd #t (##core#inline_allocate ("C_fdopen" 2) fd (mode #t m))) ) )
1633  (set! open-output-file*
1634    (lambda (fd . m)
1635      (##sys#check-exact fd 'open-output-file*)
1636      (check fd #f (##core#inline_allocate ("C_fdopen" 2) fd (mode #f m)) ) ) ) )
1637
1638(define port->fileno
1639  (lambda (port)
1640    (##sys#check-port port 'port->fileno)
1641    (if (not (zero? (##sys#peek-unsigned-integer port 0)))
1642        (let ([fd (##core#inline "C_C_fileno" port)])
1643          (when (fx< fd 0)
1644            (##sys#update-errno)
1645            (##sys#signal-hook #:file-error 'port->fileno "cannot access file-descriptor of port" port) )
1646          fd)
1647        (##sys#signal-hook #:type-error 'port->fileno "port has no attached file" port) ) ) )
1648
1649(define duplicate-fileno
1650  (lambda (old . new)
1651    (##sys#check-exact old duplicate-fileno)
1652    (let ([fd (if (null? new)
1653                  (##core#inline "C_dup" old)
1654                  (let ([n (car new)])
1655                    (##sys#check-exact n 'duplicate-fileno)
1656                    (##core#inline "C_dup2" old n) ) ) ] )
1657      (when (fx< fd 0)
1658        (##sys#update-errno)
1659        (##sys#signal-hook #:file-error 'duplicate-fileno "cannot duplicate file descriptor" old) )
1660      fd) ) )
1661
1662
1663;;; Environment access:
1664
1665(define setenv
1666  (lambda (var val)
1667    (##sys#check-string var 'setenv)
1668    (##sys#check-string val 'setenv)
1669    (##core#inline "C_setenv" (##sys#make-c-string var) (##sys#make-c-string val))
1670    (##core#undefined) ) )
1671
1672(define (unsetenv var)
1673  (##sys#check-string var 'unsetenv)
1674  (##core#inline "C_putenv" (##sys#make-c-string var))
1675  (##core#undefined) )
1676
1677(define get-environment-variables
1678  (let ([get (foreign-lambda c-string "C_getenventry" int)]
1679        [substring substring] )
1680    (lambda ()
1681      (let loop ([i 0])
1682        (let ([entry (get i)])
1683          (if entry
1684              (let scan ([j 0])
1685                (if (char=? #\= (##core#inline "C_subchar" entry j))
1686                    (cons (cons (substring entry 0 j) (substring entry (fx+ j 1) (##sys#size entry))) (loop (fx+ i 1)))
1687                    (scan (fx+ j 1)) ) )
1688              '() ) ) ) ) ) )
1689
1690(define current-environment get-environment-variables) ; DEPRECATED
1691
1692;;; Time related things:
1693
1694(define (check-time-vector loc tm)
1695  (##sys#check-vector tm loc)
1696  (when (fx< (##sys#size tm) 10)
1697    (##sys#error loc "time vector too short" tm) ) )
1698
1699(define (seconds->local-time secs)
1700  (##sys#check-number secs 'seconds->local-time)
1701  (##sys#decode-seconds secs #f) )
1702
1703(define (seconds->utc-time secs)
1704  (##sys#check-number secs 'seconds->utc-time)
1705  (##sys#decode-seconds secs #t) )
1706
1707(define seconds->string
1708  (let ([ctime (foreign-lambda c-string "C_ctime" integer)])
1709    (lambda (secs)
1710      (let ([str (ctime secs)])
1711        (if str
1712            (##sys#substring str 0 (fx- (##sys#size str) 1))
1713            (##sys#error 'seconds->string "cannot convert seconds to string" secs) ) ) ) ) )
1714
1715(define time->string
1716  (let ([asctime (foreign-lambda c-string "C_asctime" scheme-object)]
1717        [strftime (foreign-lambda c-string "C_strftime" scheme-object scheme-object)])
1718    (lambda (tm #!optional fmt)
1719      (check-time-vector 'time->string tm)
1720      (if fmt
1721          (begin
1722            (##sys#check-string fmt 'time->string)
1723            (or (strftime tm (##sys#make-c-string fmt))
1724                (##sys#error 'time->string "time formatting overflows buffer" tm)) )
1725          (let ([str (asctime tm)])
1726            (if str
1727                (##sys#substring str 0 (fx- (##sys#size str) 1))
1728                (##sys#error 'time->string "cannot convert time vector to string" tm) ) ) ) ) ) )
1729
1730(define (local-time->seconds tm)
1731  (check-time-vector 'local-time->seconds tm)
1732  (if (##core#inline "C_mktime" tm)
1733      (##sys#cons-flonum)
1734      (##sys#error 'local-time->seconds "cannot convert time vector to seconds" tm) ) )
1735
1736(define local-timezone-abbreviation
1737  (foreign-lambda* c-string ()
1738   "char *z = (_daylight ? _tzname[1] : _tzname[0]);\n"
1739   "return(z);") )
1740
1741;;; Other things:
1742
1743(define _exit
1744  (let ([ex0 (foreign-lambda void "_exit" int)])
1745    (lambda code
1746      (ex0 (if (pair? code) (car code) 0)) ) ) )
1747
1748(define (terminal-port? port)
1749  (##sys#check-port port 'terminal-port?)
1750  #f)
1751
1752(define-foreign-variable _iofbf int "_IOFBF")
1753(define-foreign-variable _iolbf int "_IOLBF")
1754(define-foreign-variable _ionbf int "_IONBF")
1755(define-foreign-variable _bufsiz int "BUFSIZ")
1756
1757(define set-buffering-mode!
1758    (lambda (port mode . size)
1759      (##sys#check-port port 'set-buffering-mode!)
1760      (let ([size (if (pair? size) (car size) _bufsiz)]
1761            [mode (case mode
1762                    [(###full) _iofbf]
1763                    [(###line) _iolbf]
1764                    [(###none) _ionbf]
1765                    [else (##sys#error 'set-buffering-mode! "invalid buffering-mode" mode port)] ) ] )
1766        (##sys#check-exact size 'set-buffering-mode!)
1767        (when (fx< (if (eq? 'stream (##sys#slot port 7))
1768                       (##core#inline "C_setvbuf" port mode size)
1769                       -1)
1770                   0)
1771          (##sys#error 'set-buffering-mode! "cannot set buffering mode" port mode size) ) ) ) )
1772
1773;;; Filename globbing:
1774
1775(define glob
1776  (let ([regexp regexp]
1777        [string-match string-match]
1778        [glob->regexp glob->regexp]
1779        [directory directory]
1780        [make-pathname make-pathname]
1781        [decompose-pathname decompose-pathname] )
1782    (lambda paths
1783      (let conc-loop ([paths paths])
1784        (if (null? paths)
1785            '()
1786            (let ([path (car paths)])
1787              (let-values ([(dir fil ext) (decompose-pathname path)])
1788                (let* ([patt (glob->regexp (make-pathname #f (or fil "*") ext))]
1789                       [rx (regexp patt)])
1790                  (let loop ([fns (directory (or dir ".") #t)])
1791                    (cond [(null? fns) (conc-loop (cdr paths))]
1792                          [(string-match rx (car fns))
1793                           => (lambda (m) (cons (make-pathname dir (car m)) (loop (cdr fns)))) ]
1794                          [else (loop (cdr fns))] ) ) ) ) ) ) ) ) ) )
1795
1796
1797;;; Process handling:
1798
1799(define-foreign-variable _p_overlay int "P_OVERLAY")
1800(define-foreign-variable _p_wait int "P_WAIT")
1801(define-foreign-variable _p_nowait int "P_NOWAIT")
1802(define-foreign-variable _p_nowaito int "P_NOWAITO")
1803(define-foreign-variable _p_detach int "P_DETACH")
1804
1805(define spawn/overlay _p_overlay)
1806(define spawn/wait _p_wait)
1807(define spawn/nowait _p_nowait)
1808(define spawn/nowaito _p_nowaito)
1809(define spawn/detach _p_detach)
1810
1811; Windows uses a commandline style for process arguments. Thus any
1812; arguments with embedded whitespace will parse incorrectly. Must
1813; string-quote such arguments.
1814(define $quote-args-list
1815  (let ([char-whitespace? char-whitespace?]
1816        [string-length string-length]
1817        [string-ref string-ref]
1818        [string-append string-append])
1819    (lambda (lst exactf)
1820      (if exactf
1821        lst
1822        (let ([needs-quoting?
1823                ; This is essentially (string-any char-whitespace? s) but we don't
1824                ; want a SRFI-13 dependency. (Do we?)
1825                (lambda (s)
1826                  (let ([len (string-length s)])
1827                    (let loop ([i 0])
1828                      (cond
1829                        [(fx= i len) #f]
1830                        [(char-whitespace? (string-ref s i)) #t]
1831                        [else (loop (fx+ i 1))]))))])
1832            (let loop ([ilst lst] [olst '()])
1833              (if (null? ilst)
1834                (reverse olst)
1835                (let ([str (car ilst)])
1836                  (loop
1837                    (cdr ilst)
1838                    (cons
1839                      (if (needs-quoting? str) (string-append "\"" str "\"") str)
1840                      olst)) ) ) ) ) ) ) ) )
1841
1842(define $exec-setup
1843  (let ([setarg (foreign-lambda void "C_set_exec_arg" int scheme-pointer int)]
1844        [setenv (foreign-lambda void "C_set_exec_env" int scheme-pointer int)]
1845        [pathname-strip-directory pathname-strip-directory]
1846        [build-exec-argvec
1847          (lambda (loc lst argvec-setter idx)
1848            (if lst
1849              (begin
1850                (##sys#check-list lst loc)
1851                (do ([l lst (cdr l)]
1852                     [i idx (fx+ i 1)] )
1853                    ((null? l) (argvec-setter i #f 0))
1854                  (let ([s (car l)])
1855                    (##sys#check-string s loc)
1856                    (argvec-setter i s (##sys#size s)) ) ) )
1857              (argvec-setter idx #f 0) ) )])
1858    (lambda (loc filename arglst envlst exactf)
1859      (##sys#check-string filename loc)
1860      (let ([s (pathname-strip-directory filename)])
1861        (setarg 0 s (##sys#size s)) )
1862      (build-exec-argvec loc ($quote-args-list arglst exactf) setarg 1)
1863      (build-exec-argvec loc envlst setenv 0)
1864      (##core#inline "C_flushall")
1865      (##sys#make-c-string (##sys#expand-home-path filename)) ) ) )
1866
1867(define ($exec-teardown loc msg filename res)
1868  (##sys#update-errno)
1869  (##core#inline "C_free_exec_args")
1870  (##core#inline "C_free_exec_env")
1871  (if (fx= res -1)
1872      (##sys#error loc msg filename)
1873      res ) )
1874
1875(define (process-execute filename #!optional arglst envlst exactf)
1876  (let ([prg ($exec-setup 'process-execute filename arglst envlst exactf)])
1877    ($exec-teardown 'process-execute "cannot execute process" filename
1878      (if envlst (##core#inline "C_execve" prg) (##core#inline "C_execvp" prg))) ) )
1879
1880(define (process-spawn mode filename #!optional arglst envlst exactf)
1881  (let ([prg ($exec-setup 'process-spawn filename arglst envlst exactf)])
1882    ($exec-teardown 'process-spawn "cannot spawn process" filename
1883      (if envlst (##core#inline "C_spawnvpe" mode prg) (##core#inline "C_spawnvp" mode prg))) ) )
1884
1885(define current-process-id (foreign-lambda int "C_getpid"))
1886
1887(define-foreign-variable _shlcmd c-string "C_shlcmd")
1888
1889(define (##sys#shell-command)
1890  (or (get-environment-variable "COMSPEC")
1891      (if (##core#inline "C_get_shlcmd")
1892          _shlcmd
1893          (begin
1894            (##sys#update-errno)
1895            (##sys#error '##sys#shell-command "cannot retrieve system directory") ) ) ) )
1896
1897(define (##sys#shell-command-arguments cmdlin)
1898  (list "/c" cmdlin) )
1899
1900(define process-run
1901  (let ([process-spawn process-spawn]
1902        [get-environment-variable get-environment-variable] )
1903    (lambda (f . args)
1904      (let ([args (if (pair? args) (car args) #f)])
1905        (if args
1906            (process-spawn spawn/nowait f args)
1907            (process-spawn spawn/nowait (##sys#shell-command) (##sys#shell-command-arguments f)) ) ) ) ) )
1908
1909;;; Run subprocess connected with pipes:
1910(define-foreign-variable _rdbuf char "C_rdbuf")
1911(define-foreign-variable _wr0 int "C_wr0_")
1912(define-foreign-variable _rd1 int "C_rd1_")
1913
1914; from original by Mejedi
1915;; ##sys#process
1916; loc            caller procedure symbol
1917; cmd            pathname or commandline
1918; args           string-list or '()
1919; env            string-list or #f (currently ignored)
1920; stdoutf        #f then share, or #t then create
1921; stdinf         #f then share, or #t then create
1922; stderrf        #f then share, or #t then create
1923;
1924; (values stdin-input-port? stdout-output-port? pid stderr-input-port?)
1925; where stdin-input-port?, etc. is a port or #f, indicating no port created.
1926
1927(define ##sys#process
1928  (let ([c-process
1929          (foreign-lambda bool "C_process" c-string c-string c-pointer
1930            (pointer int) (pointer int) (pointer int) (pointer int) int)])
1931    ; The environment list must be sorted & include current directory
1932    ; information for the system drives. i.e !C:=...
1933    ; For now any environment is ignored.
1934    (lambda (loc cmd args env stdoutf stdinf stderrf #!optional exactf)
1935      (let ([cmdlin (string-intersperse ($quote-args-list (cons cmd args) exactf))])
1936        (let-location ([handle int -1]
1937                       [stdin_fd int -1] [stdout_fd int -1] [stderr_fd int -1])
1938          (let ([res
1939                  (c-process cmd cmdlin #f
1940                    (location handle)
1941                    (location stdin_fd) (location stdout_fd) (location stderr_fd)
1942                    (+ (if stdinf 0 1) (if stdoutf 0 2) (if stderrf 0 4)))])
1943            (if res
1944              (values
1945                (and stdoutf (open-input-file* stdout_fd)) ;Parent stdin
1946                (and stdinf (open-output-file* stdin_fd))  ;Parent stdout
1947                handle
1948                (and stderrf (open-input-file* stderr_fd)))
1949              (begin
1950                (##sys#update-errno)
1951                (##sys#signal-hook #:process-error loc "cannot execute process" cmdlin))) ) ) ) ) ) )
1952
1953#;(define process (void))
1954#;(define process* (void))
1955(let ([%process
1956        (lambda (loc err? cmd args env exactf)
1957          (let ([chkstrlst
1958                 (lambda (lst)
1959                   (##sys#check-list lst loc)
1960                   (for-each (cut ##sys#check-string <> loc) lst) )])
1961            (##sys#check-string cmd loc)
1962            (if args
1963              (chkstrlst args)
1964              (begin
1965                (set! exactf #t)
1966                (set! args (##sys#shell-command-arguments cmd))
1967                (set! cmd (##sys#shell-command)) ) )
1968            (when env (chkstrlst env))
1969            (receive [in out pid err] (##sys#process loc cmd args env #t #t err? exactf)
1970              (if err?
1971                (values in out pid err)
1972                (values in out pid) ) ) ) )] )
1973  (set! process
1974    (lambda (cmd #!optional args env exactf)
1975      (%process 'process #f cmd args env exactf) ))
1976  (set! process*
1977    (lambda (cmd #!optional args env exactf)
1978      (%process 'process* #t cmd args env exactf) )) )
1979
1980(define-foreign-variable _exstatus int "C_exstatus")
1981
1982(define (##sys#process-wait pid nohang)
1983  (if (##core#inline "C_process_wait" pid nohang)
1984    (values pid #t _exstatus)
1985    (values -1 #f #f) ) )
1986
1987(define process-wait
1988  (lambda (pid . args)
1989    (let-optionals* args ([nohang #f])
1990      (##sys#check-exact pid 'process-wait)
1991      (receive [epid enorm ecode] (##sys#process-wait pid nohang)
1992        (if (fx= epid -1)
1993          (begin
1994            (##sys#update-errno)
1995            (##sys#signal-hook #:process-error 'process-wait "waiting for child process failed" pid) )
1996          (values epid enorm ecode) ) ) ) ) )
1997
1998(define sleep
1999  (lambda (t)
2000    (##core#inline "C_sleep" t)
2001    0) )
2002
2003(define-foreign-variable _hostname c-string "C_hostname")
2004(define-foreign-variable _osver c-string "C_osver")
2005(define-foreign-variable _osrel c-string "C_osrel")
2006(define-foreign-variable _processor c-string "C_processor")
2007
2008(define get-host-name
2009  (lambda ()
2010    (if (##core#inline "C_get_hostname")
2011      _hostname
2012      (##sys#error 'get-host-name "cannot retrieve host-name") ) ) )
2013
2014
2015;;; Getting system-, group- and user-information:
2016
2017(define system-information
2018  (lambda ()
2019    (if (##core#inline "C_sysinfo")
2020      (list "windows" _hostname _osrel _osver _processor)
2021      (begin
2022        (##sys#update-errno)
2023        (##sys#error 'system-information "cannot retrieve system-information") ) ) ) )
2024
2025(define-foreign-variable _username c-string "C_username")
2026
2027(define (current-user-name)
2028  (if (##core#inline "C_get_user_name")
2029      _username
2030      (begin
2031        (##sys#update-errno)
2032        (##sys#error 'current-user-name "cannot retrieve current user-name") ) ) )
2033
2034
2035;;; Find matching files:
2036
2037(define find-files
2038  (let ([glob glob]
2039        [string-match string-match]
2040        [make-pathname make-pathname]
2041        [directory? directory?] )
2042    (lambda (dir pred . action-id-limit)
2043      (let-optionals action-id-limit
2044          ([action (lambda (x y) (cons x y))] ; no eta reduction here - we want cons inlined.
2045           [id '()]
2046           [limit #f] )
2047        (##sys#check-string dir 'find-files)
2048        (let* ([depth 0]
2049               [lproc
2050                (cond [(not limit) (lambda _ #t)]
2051                      [(fixnum? limit) (lambda _ (fx< depth limit))]
2052                      [else limit] ) ]
2053               [pproc
2054                (if (string? pred)
2055                    (lambda (x) (string-match pred x))
2056                    pred) ] )
2057          (let loop ([fs (glob (make-pathname dir "*"))]
2058                     [r id] )
2059            (if (null? fs)
2060                r
2061                (let ([f (##sys#slot fs 0)]
2062                      [rest (##sys#slot fs 1)] )
2063                  (cond [(directory? f)
2064                         (cond [(member (pathname-file f) '("." "..")) (loop rest r)]
2065                               [(lproc f)
2066                                (loop rest
2067                                      (fluid-let ([depth (fx+ depth 1)])
2068                                        (loop (glob (make-pathname f "*")) r) ) ) ]
2069                               [else (loop rest r)] ) ]
2070                        [(pproc f) (loop rest (action f r))]
2071                        [else (loop rest r)] ) ) ) ) ) ) ) ) )
2072
2073;;; unimplemented stuff:
2074
2075(define-syntax define-unimplemented
2076  (syntax-rules ()
2077    [(_ ?name)
2078     (define (?name . _)
2079       (error '?name (##core#immutable '"this function is not available on this platform")) ) ] ) )
2080
2081(define-unimplemented change-file-owner)
2082(define-unimplemented create-fifo)
2083(define-unimplemented create-session)
2084(define-unimplemented create-symbolic-link)
2085(define-unimplemented current-effective-group-id)
2086(define-unimplemented current-effective-user-id)
2087(define-unimplemented current-effective-user-name)
2088(define-unimplemented current-group-id)
2089(define-unimplemented current-user-id)
2090(define-unimplemented map-file-to-memory)
2091(define-unimplemented file-link)
2092(define-unimplemented file-lock)
2093(define-unimplemented file-lock/blocking)
2094(define-unimplemented file-select)
2095(define-unimplemented file-test-lock)
2096(define-unimplemented file-truncate)
2097(define-unimplemented file-unlock)
2098(define-unimplemented get-groups)
2099(define-unimplemented group-information)
2100(define-unimplemented initialize-groups)
2101(define-unimplemented memory-mapped-file-pointer)
2102(define-unimplemented parent-process-id)
2103(define-unimplemented process-fork)
2104(define-unimplemented process-group-id)
2105(define-unimplemented process-signal)
2106(define-unimplemented read-symbolic-link)
2107(define-unimplemented set-alarm!)
2108(define-unimplemented set-group-id!)
2109(define-unimplemented set-groups!)
2110(define-unimplemented set-process-group-id!)
2111(define-unimplemented set-root-directory!)
2112(define-unimplemented set-signal-mask!)
2113(define-unimplemented set-user-id!)
2114(define-unimplemented signal-mask)
2115(define-unimplemented signal-mask!)
2116(define-unimplemented signal-masked?)
2117(define-unimplemented signal-unmask!)
2118(define-unimplemented terminal-name)
2119(define-unimplemented terminal-size)
2120(define-unimplemented unmap-file-from-memory)
2121(define-unimplemented user-information)
2122(define-unimplemented utc-time->seconds)
2123(define-unimplemented string->time)
2124
2125(define errno/wouldblock 0)
2126
2127(define (fifo? _) #f)
2128(define (memory-mapped-file? _) #f)
2129
2130(define map/anonymous 0)
2131(define map/file 0)
2132(define map/fixed 0)
2133(define map/private 0)
2134(define map/shared 0)
2135(define open/fsync 0)
2136(define open/noctty 0)
2137(define open/nonblock 0)
2138(define open/sync 0)
2139(define perm/isgid 0)
2140(define perm/isuid 0)
2141(define perm/isvtx 0)
2142(define prot/exec 0)
2143(define prot/none 0)
2144(define prot/read 0)
2145(define prot/write 0)
Note: See TracBrowser for help on using the repository browser.