source: project/chicken/branches/prerelease/posixwin.scm @ 15101

Last change on this file since 15101 was 15101, checked in by felix winkelmann, 10 years ago

merged trunk changes from 14491:15100 into prerelease branch

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