Replaced most of define-foreign by
define-stubless-foreign/define-retrying-syscall in syscalls.scm.
This commit is contained in:
parent
10b97c9e82
commit
327daeed32
154
scsh/dirstuff1.c
154
scsh/dirstuff1.c
|
@ -7,139 +7,39 @@
|
||||||
#include <dirent.h>
|
#include <dirent.h>
|
||||||
#include <stdlib.h>
|
#include <stdlib.h>
|
||||||
#include <string.h>
|
#include <string.h>
|
||||||
|
#include <errno.h>
|
||||||
#include "libcig.h"
|
|
||||||
#include "scsh_aux.h"
|
|
||||||
|
|
||||||
/* Make sure our exports match up w/the implementation: */
|
/* Make sure our exports match up w/the implementation: */
|
||||||
|
#include "scheme48.h"
|
||||||
#include "dirstuff1.h"
|
#include "dirstuff1.h"
|
||||||
|
|
||||||
extern int errno;
|
s48_value open_dir(s48_value sch_dirname)
|
||||||
|
|
||||||
/* Linked list of malloc'd entries. */
|
|
||||||
struct scm_dirent_struct
|
|
||||||
{ char *fname; /* File name */
|
|
||||||
struct scm_dirent_struct *next;}; /* Next pointer */
|
|
||||||
typedef struct scm_dirent_struct scm_dirent_t;
|
|
||||||
|
|
||||||
void free_dirent_list(scm_dirent_t *entry)
|
|
||||||
{
|
{
|
||||||
while(entry) {
|
char *fname;
|
||||||
scm_dirent_t *next = entry->next;
|
struct dirent *dirent;
|
||||||
Free(entry);
|
DIR *d;
|
||||||
entry = next;
|
s48_value dirlist = S48_NULL;
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
/* Returns [err, fnames, len]
|
S48_DECLARE_GC_PROTECT(1);
|
||||||
** err is 0 for success, otw errno.
|
|
||||||
** fnames is a vector of strings (filenames), null terminated.
|
S48_GC_PROTECT_1(dirlist);
|
||||||
** len is the length of fnames.
|
|
||||||
*/
|
if( NULL == (d = opendir(s48_extract_string (sch_dirname))) )
|
||||||
int open_dir(const char *dirname, char ***fnames, int *len)
|
s48_raise_os_error_1 (errno, sch_dirname);
|
||||||
{
|
|
||||||
scm_dirent_t *dep, *entries;
|
while( NULL != (dirent = readdir(d)) ) {
|
||||||
struct dirent *dirent;
|
if((strcmp(dirent->d_name,".") == 0) || (strcmp(dirent->d_name,"..") == 0))
|
||||||
char *fname, **dirvec, **vecp;
|
continue;
|
||||||
DIR *d;
|
if( NULL == (fname=copystring(NULL, dirent->d_name)) )
|
||||||
int num_entries;
|
s48_raise_os_error_1 (errno, sch_dirname);
|
||||||
int e; /* errno temp */
|
|
||||||
|
|
||||||
if( NULL == (d = opendir(dirname)) ) {
|
|
||||||
fnames = 0; len = 0;
|
|
||||||
return errno;
|
|
||||||
}
|
|
||||||
|
|
||||||
entries = NULL; num_entries = 0;
|
dirlist = s48_cons (s48_enter_string (dirent->d_name),
|
||||||
while( NULL != (dirent = readdir(d)) ) {
|
dirlist);
|
||||||
if((strcmp(dirent->d_name,".") == 0) || (strcmp(dirent->d_name,"..") == 0))
|
|
||||||
continue;
|
|
||||||
if( NULL == (dep=Alloc(scm_dirent_t)) )
|
|
||||||
{e=errno; goto lose2;}
|
|
||||||
if( NULL == (fname=copystring(NULL, dirent->d_name)) ) goto lose1;
|
|
||||||
dep->fname = fname;
|
|
||||||
dep->next = entries;
|
|
||||||
entries = dep; num_entries++;
|
|
||||||
}
|
|
||||||
closedir(d);
|
|
||||||
|
|
||||||
/* Load the filenames into a vector and free the structs. */
|
}
|
||||||
if( NULL == (dirvec = Malloc(char *, num_entries+1)) )
|
if (closedir(d) == -1)
|
||||||
{e=errno; goto lose3;}
|
s48_raise_os_error_1 (errno, sch_dirname);
|
||||||
for(dep=entries, vecp=dirvec; dep; vecp++) {
|
|
||||||
scm_dirent_t *next = dep->next;
|
S48_GC_UNPROTECT ();
|
||||||
*vecp = dep->fname;
|
return dirlist;
|
||||||
Free(dep);
|
|
||||||
dep = next;
|
|
||||||
}
|
|
||||||
dirvec[num_entries] = NULL;
|
|
||||||
|
|
||||||
*fnames = dirvec;
|
|
||||||
*len = num_entries;
|
|
||||||
return 0;
|
|
||||||
|
|
||||||
|
|
||||||
lose1: e = errno; Free(dep);
|
|
||||||
lose2: closedir(d);
|
|
||||||
lose3: free_dirent_list(entries);
|
|
||||||
fnames = 0; len = 0;
|
|
||||||
return e;
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
#define DOTFILE(a) ((a) && *(a) == '.') /* Not a function. */
|
|
||||||
|
|
||||||
/* a <= b in the Unix filename ordering:
|
|
||||||
** dotfiles come first, lexicographically ordered.
|
|
||||||
** others come second, lexicographically ordered.
|
|
||||||
**
|
|
||||||
** This is for sorting filenames in directory listings.
|
|
||||||
*/
|
|
||||||
|
|
||||||
static int compare_fname(const void *aptr, const void *bptr)
|
|
||||||
{
|
|
||||||
char const *a = * (char const * *) aptr;
|
|
||||||
char const *b = * (char const * *) bptr;
|
|
||||||
if( DOTFILE(a) )
|
|
||||||
return DOTFILE(b) ? strcmp(a+1,b+1) : -1;
|
|
||||||
return DOTFILE(b) ? 1 : strcmp(a,b);
|
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
void scm_sort_filevec(const char **dirvec, int nelts)
|
|
||||||
{
|
|
||||||
qsort((char *) dirvec, nelts, sizeof(char*), compare_fname);
|
|
||||||
}
|
|
||||||
|
|
||||||
#if 0
|
|
||||||
/* This one is a little more complex, but we don't use it because we
|
|
||||||
** never try to sort lists of filenames with . or .. in the list.
|
|
||||||
*/
|
|
||||||
|
|
||||||
/* Boolean function: a <= b in the Unix filename ordering:
|
|
||||||
** . comes first
|
|
||||||
** .. comes second
|
|
||||||
** Other dotfiles come next, lexicographically ordered.
|
|
||||||
** Non-dotfiles come last, lexicographically ordered.
|
|
||||||
**
|
|
||||||
** This is for sorting filenames in directory listings.
|
|
||||||
*/
|
|
||||||
|
|
||||||
static int comp1(const void *aptr, const void* bptr)
|
|
||||||
{
|
|
||||||
char const *a = *(char const **)aptr;
|
|
||||||
char const *b = *(char const **)bptr;
|
|
||||||
|
|
||||||
if(streq(a,b)) return 0;
|
|
||||||
|
|
||||||
if(DOTFILE(a))
|
|
||||||
if( DOTFILE(b) )
|
|
||||||
return streq(a, ".") ||
|
|
||||||
(!streq(b, ".") && (streq(a, "..") || (!streq(b, "..") &&
|
|
||||||
(strcmp(a,b) <= 0))))
|
|
||||||
? -1 : 1;
|
|
||||||
else return -1;
|
|
||||||
|
|
||||||
else return DOTFILE(b) ? 1 : strcmp(a,b);
|
|
||||||
}
|
|
||||||
#endif
|
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
/* Exports from dirstuff1.c. */
|
/* Exports from dirstuff1.c. */
|
||||||
|
|
||||||
int open_dir(const char *dirname, char ***fnames, int *len);
|
s48_value open_dir(s48_value dirname);
|
||||||
void scm_sort_filevec(const char **dirvec, int nelts);
|
|
||||||
|
|
|
@ -39,22 +39,24 @@
|
||||||
(let ((query (lambda ()
|
(let ((query (lambda ()
|
||||||
(y-or-n? (string-append op-name ": " fname
|
(y-or-n? (string-append op-name ": " fname
|
||||||
" already exists. Delete")))))
|
" already exists. Delete")))))
|
||||||
(let loop ((override? override?))
|
(let ((result
|
||||||
;; MAKEIT returns #f if win, errno if lose.
|
(let loop ((override? override?))
|
||||||
(cond ((makeit fname) =>
|
(with-errno-handler
|
||||||
(lambda (err)
|
((err data)
|
||||||
(if (not (= err errno/exist))
|
((errno/exist)
|
||||||
(errno-error err syscall fname)
|
(cond ((if (eq? override? 'query)
|
||||||
|
(query)
|
||||||
;; FNAME exists. Nuke it and retry?
|
override?)
|
||||||
(cond ((if (eq? override? 'query)
|
(delete-filesys-object fname)
|
||||||
(query)
|
(loop #t))
|
||||||
override?)
|
;;; raising an error here won't work due to S48's
|
||||||
(delete-filesys-object fname)
|
;;; broken exception system
|
||||||
(loop #t))
|
(else (list err syscall fname)))))
|
||||||
(else
|
(makeit fname)
|
||||||
(errno-error err syscall fname))))))))))
|
#f))))
|
||||||
|
(if (list? result)
|
||||||
|
(apply errno-error result)
|
||||||
|
(if #f #f)))))
|
||||||
|
|
||||||
;;;;;;;
|
;;;;;;;
|
||||||
|
|
||||||
|
@ -63,7 +65,7 @@
|
||||||
(override? (if (or (null? rest) (null? (cdr rest))) #f
|
(override? (if (or (null? rest) (null? (cdr rest))) #f
|
||||||
(cadr rest))))
|
(cadr rest))))
|
||||||
(create-file-thing dir
|
(create-file-thing dir
|
||||||
(lambda (dir) (create-directory/errno dir perms))
|
(lambda (dir) (%create-directory dir perms))
|
||||||
override?
|
override?
|
||||||
"create-directory"
|
"create-directory"
|
||||||
create-directory)))
|
create-directory)))
|
||||||
|
@ -73,7 +75,7 @@
|
||||||
(override? (if (or (null? rest) (null? (cdr rest))) #f
|
(override? (if (or (null? rest) (null? (cdr rest))) #f
|
||||||
(cadr rest))))
|
(cadr rest))))
|
||||||
(create-file-thing fifo
|
(create-file-thing fifo
|
||||||
(lambda (fifo) (create-fifo/errno fifo perms))
|
(lambda (fifo) (%create-fifo fifo perms))
|
||||||
override?
|
override?
|
||||||
"create-fifo"
|
"create-fifo"
|
||||||
create-fifo)))
|
create-fifo)))
|
||||||
|
@ -81,7 +83,7 @@
|
||||||
(define (create-hard-link old-fname new-fname . maybe-override?)
|
(define (create-hard-link old-fname new-fname . maybe-override?)
|
||||||
(create-file-thing new-fname
|
(create-file-thing new-fname
|
||||||
(lambda (new-fname)
|
(lambda (new-fname)
|
||||||
(create-hard-link/errno old-fname new-fname))
|
(%create-hard-link old-fname new-fname))
|
||||||
(:optional maybe-override? #f)
|
(:optional maybe-override? #f)
|
||||||
"create-hard-link"
|
"create-hard-link"
|
||||||
create-hard-link))
|
create-hard-link))
|
||||||
|
@ -89,7 +91,7 @@
|
||||||
(define (create-symlink old-fname new-fname . maybe-override?)
|
(define (create-symlink old-fname new-fname . maybe-override?)
|
||||||
(create-file-thing new-fname
|
(create-file-thing new-fname
|
||||||
(lambda (symlink)
|
(lambda (symlink)
|
||||||
(create-symlink/errno old-fname symlink))
|
(%create-symlink old-fname symlink))
|
||||||
(:optional maybe-override? #f)
|
(:optional maybe-override? #f)
|
||||||
"create-symlink"
|
"create-symlink"
|
||||||
create-symlink))
|
create-symlink))
|
||||||
|
|
|
@ -134,6 +134,7 @@
|
||||||
))
|
))
|
||||||
(scsh-level-0-internals (export set-command-line-args!
|
(scsh-level-0-internals (export set-command-line-args!
|
||||||
init-scsh-hindbrain
|
init-scsh-hindbrain
|
||||||
|
initialize-cwd
|
||||||
init-scsh-vars))
|
init-scsh-vars))
|
||||||
; (scsh-regexp-package scsh-regexp-interface)
|
; (scsh-regexp-package scsh-regexp-interface)
|
||||||
)
|
)
|
||||||
|
@ -205,6 +206,7 @@
|
||||||
simple-syntax)
|
simple-syntax)
|
||||||
(for-syntax (open scsh-syntax-helpers scheme))
|
(for-syntax (open scsh-syntax-helpers scheme))
|
||||||
(access interrupts
|
(access interrupts
|
||||||
|
sort
|
||||||
command-processor
|
command-processor
|
||||||
escapes
|
escapes
|
||||||
i/o ; S48's force-output
|
i/o ; S48's force-output
|
||||||
|
|
627
scsh/syscalls.c
627
scsh/syscalls.c
|
@ -29,491 +29,6 @@ extern int errno;
|
||||||
#define errno_or_false(x) (((x) == -1) ? s48_enter_fixnum(errno) : S48_FALSE)
|
#define errno_or_false(x) (((x) == -1) ? s48_enter_fixnum(errno) : S48_FALSE)
|
||||||
#define False_on_zero(x) ((x) ? s48_enter_fixnum(x) : S48_FALSE)
|
#define False_on_zero(x) ((x) ? s48_enter_fixnum(x) : S48_FALSE)
|
||||||
|
|
||||||
s48_value df_getpid(void)
|
|
||||||
{
|
|
||||||
extern pid_t getpid(void);
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
pid_t r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_1(ret1);
|
|
||||||
r1 = getpid();
|
|
||||||
ret1 = s48_enter_fixnum(r1);
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_getppid(void)
|
|
||||||
{
|
|
||||||
extern pid_t getppid(void);
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
pid_t r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_1(ret1);
|
|
||||||
r1 = getppid();
|
|
||||||
ret1 = s48_enter_fixnum(r1);
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_getpgrp(void)
|
|
||||||
{
|
|
||||||
extern pid_t getpgrp(void);
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
pid_t r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_1(ret1);
|
|
||||||
r1 = getpgrp();
|
|
||||||
ret1 = s48_enter_fixnum(r1);
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_setpgid(s48_value g1, s48_value g2)
|
|
||||||
{
|
|
||||||
extern int setpgid(pid_t , pid_t );
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
int r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_1(ret1);
|
|
||||||
r1 = setpgid(s48_extract_fixnum(g1), s48_extract_fixnum(g2));
|
|
||||||
ret1 = errno_or_false(r1);
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_setsid(s48_value mv_vec)
|
|
||||||
{
|
|
||||||
extern pid_t setsid(void);
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(2);
|
|
||||||
pid_t r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_2(mv_vec,ret1);
|
|
||||||
r1 = setsid();
|
|
||||||
ret1 = errno_or_false(r1);
|
|
||||||
S48_VECTOR_SET(mv_vec,0,s48_enter_fixnum(r1));
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_umask(s48_value g1)
|
|
||||||
{
|
|
||||||
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
mode_t r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_1(ret1);
|
|
||||||
r1 = umask(s48_extract_fixnum(g1));
|
|
||||||
ret1 = s48_enter_fixnum(r1);
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_process_times(s48_value mv_vec)
|
|
||||||
{
|
|
||||||
extern int process_times(clock_t *, clock_t *, clock_t *, clock_t *);
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(2);
|
|
||||||
int r1;
|
|
||||||
clock_t r2 = 0;
|
|
||||||
clock_t r3 = 0;
|
|
||||||
clock_t r4 = 0;
|
|
||||||
clock_t r5 = 0;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_2(mv_vec,ret1);
|
|
||||||
r1 = process_times(&r2, &r3, &r4, &r5);
|
|
||||||
ret1 = errno_or_false(r1);
|
|
||||||
S48_VECTOR_SET(mv_vec,0,s48_enter_fixnum(r2));
|
|
||||||
S48_VECTOR_SET(mv_vec,1,s48_enter_fixnum(r3));
|
|
||||||
S48_VECTOR_SET(mv_vec,2,s48_enter_fixnum(r4));
|
|
||||||
S48_VECTOR_SET(mv_vec,3,s48_enter_fixnum(r5));
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_cpu_clock_ticks_per_sec(void)
|
|
||||||
{
|
|
||||||
extern int cpu_clock_ticks_per_sec(void);
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
int r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_1(ret1);
|
|
||||||
r1 = cpu_clock_ticks_per_sec();
|
|
||||||
ret1 = s48_enter_integer(r1);
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_chmod(s48_value g1, s48_value g2)
|
|
||||||
{
|
|
||||||
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
int r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_1(ret1);
|
|
||||||
r1 = chmod(s48_extract_string(g1), s48_extract_fixnum(g2));
|
|
||||||
ret1 = errno_or_false(r1);
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_fchmod(s48_value g1, s48_value g2)
|
|
||||||
{
|
|
||||||
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
int r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_1(ret1);
|
|
||||||
r1 = fchmod(s48_extract_fixnum(g1), s48_extract_fixnum(g2));
|
|
||||||
ret1 = errno_or_false(r1);
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_chown(s48_value g1, s48_value g2, s48_value g3)
|
|
||||||
{
|
|
||||||
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
int r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_1(ret1);
|
|
||||||
r1 = chown(s48_extract_string(g1), s48_extract_fixnum(g2), s48_extract_fixnum(g3));
|
|
||||||
ret1 = errno_or_false(r1);
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_fchown(s48_value g1, s48_value g2, s48_value g3)
|
|
||||||
{
|
|
||||||
extern int fchown(int , uid_t , gid_t );
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
int r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_1(ret1);
|
|
||||||
r1 = fchown(s48_extract_fixnum(g1), s48_extract_fixnum(g2), s48_extract_fixnum(g3));
|
|
||||||
ret1 = errno_or_false(r1);
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_access(s48_value g1, s48_value g2)
|
|
||||||
{
|
|
||||||
extern int access(const char *, int );
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
int r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_1(ret1);
|
|
||||||
r1 = access(s48_extract_string(g1), s48_extract_integer(g2));
|
|
||||||
ret1 = ENTER_BOOLEAN(r1);
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_link(s48_value g1, s48_value g2)
|
|
||||||
{
|
|
||||||
extern int link(const char *, const char *);
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
int r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_1(ret1);
|
|
||||||
r1 = link(s48_extract_string(g1), s48_extract_string(g2));
|
|
||||||
ret1 = errno_or_false(r1);
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_mkfifo(s48_value g1, s48_value g2)
|
|
||||||
{
|
|
||||||
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
int r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_1(ret1);
|
|
||||||
r1 = mkfifo(s48_extract_string(g1), s48_extract_fixnum(g2));
|
|
||||||
ret1 = errno_or_false(r1);
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_mkdir(s48_value g1, s48_value g2)
|
|
||||||
{
|
|
||||||
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
int r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_1(ret1);
|
|
||||||
r1 = mkdir(s48_extract_string(g1), s48_extract_fixnum(g2));
|
|
||||||
ret1 = errno_or_false(r1);
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_rename(s48_value g1, s48_value g2)
|
|
||||||
{
|
|
||||||
extern int rename(const char *, const char *);
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
int r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_1(ret1);
|
|
||||||
r1 = rename(s48_extract_string(g1), s48_extract_string(g2));
|
|
||||||
ret1 = errno_or_false(r1);
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_rmdir(s48_value g1)
|
|
||||||
{
|
|
||||||
extern int rmdir(const char *);
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
int r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_1(ret1);
|
|
||||||
r1 = rmdir(s48_extract_string(g1));
|
|
||||||
ret1 = errno_or_false(r1);
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_scm_utime(s48_value g1, s48_value g2, s48_value g3)
|
|
||||||
{
|
|
||||||
extern int scm_utime(const char *, time_t , time_t );
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
int r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_1(ret1);
|
|
||||||
r1 = scm_utime(s48_extract_string(g1), s48_extract_integer(g2), s48_extract_integer(g3));
|
|
||||||
ret1 = errno_or_false(r1);
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_scm_utime_now(s48_value g1)
|
|
||||||
{
|
|
||||||
extern int scm_utime_now(const char *);
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
int r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_1(ret1);
|
|
||||||
r1 = scm_utime_now(s48_extract_string(g1));
|
|
||||||
ret1 = errno_or_false(r1);
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_symlink(s48_value g1, s48_value g2)
|
|
||||||
{
|
|
||||||
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
int r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_1(ret1);
|
|
||||||
r1 = symlink(s48_extract_string(g1), s48_extract_string(g2));
|
|
||||||
ret1 = errno_or_false(r1);
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_truncate(s48_value g1, s48_value g2)
|
|
||||||
{
|
|
||||||
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
int r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_1(ret1);
|
|
||||||
r1 = truncate(s48_extract_string(g1), s48_extract_fixnum(g2));
|
|
||||||
ret1 = errno_or_false(r1);
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_ftruncate(s48_value g1, s48_value g2)
|
|
||||||
{
|
|
||||||
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
int r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_1(ret1);
|
|
||||||
r1 = ftruncate(s48_extract_fixnum(g1), s48_extract_fixnum(g2));
|
|
||||||
ret1 = errno_or_false(r1);
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_unlink(s48_value g1)
|
|
||||||
{
|
|
||||||
extern int unlink(const char *);
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
int r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_1(ret1);
|
|
||||||
r1 = unlink(s48_extract_string(g1));
|
|
||||||
ret1 = errno_or_false(r1);
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_fsync(s48_value g1)
|
|
||||||
{
|
|
||||||
extern int fsync(int );
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
int r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_1(ret1);
|
|
||||||
r1 = fsync(s48_extract_fixnum(g1));
|
|
||||||
ret1 = errno_or_false(r1);
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_sync(void)
|
|
||||||
{
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
sync();
|
|
||||||
return S48_FALSE;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_close(s48_value g1)
|
|
||||||
{
|
|
||||||
extern int close(int );
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(1);
|
|
||||||
int r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_1(ret1);
|
|
||||||
r1 = close(s48_extract_fixnum(g1));
|
|
||||||
ret1 = errno_or_false(r1);
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_dup(s48_value g1, s48_value mv_vec)
|
|
||||||
{
|
|
||||||
extern int dup(int );
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(2);
|
|
||||||
int r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_2(mv_vec,ret1);
|
|
||||||
r1 = dup(s48_extract_fixnum(g1));
|
|
||||||
ret1 = errno_or_false(r1);
|
|
||||||
S48_VECTOR_SET(mv_vec,0,s48_enter_fixnum(r1));
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_dup2(s48_value g1, s48_value g2, s48_value mv_vec)
|
|
||||||
{
|
|
||||||
extern int dup2(int , int );
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(2);
|
|
||||||
int r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_2(mv_vec,ret1);
|
|
||||||
r1 = dup2(s48_extract_fixnum(g1), s48_extract_fixnum(g2));
|
|
||||||
ret1 = errno_or_false(r1);
|
|
||||||
S48_VECTOR_SET(mv_vec,0,s48_enter_fixnum(r1));
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_lseek(s48_value g1, s48_value g2, s48_value g3, s48_value mv_vec)
|
|
||||||
{
|
|
||||||
extern off_t lseek(int , off_t , int );
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(2);
|
|
||||||
off_t r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_2(mv_vec,ret1);
|
|
||||||
r1 = lseek(s48_extract_fixnum(g1), s48_extract_fixnum(g2), s48_extract_fixnum(g3));
|
|
||||||
ret1 = errno_or_false(r1);
|
|
||||||
S48_VECTOR_SET(mv_vec,0,s48_enter_fixnum(r1));
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_char_ready_fdes(s48_value g1)
|
s48_value df_char_ready_fdes(s48_value g1)
|
||||||
{
|
{
|
||||||
extern s48_value char_ready_fdes(int );
|
extern s48_value char_ready_fdes(int );
|
||||||
|
@ -530,23 +45,6 @@ s48_value df_char_ready_fdes(s48_value g1)
|
||||||
return ret1;
|
return ret1;
|
||||||
}
|
}
|
||||||
|
|
||||||
s48_value df_open(s48_value g1, s48_value g2, s48_value g3, s48_value mv_vec)
|
|
||||||
{
|
|
||||||
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(2);
|
|
||||||
int r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_2(mv_vec,ret1);
|
|
||||||
r1 = open(s48_extract_string(g1), s48_extract_fixnum(g2), s48_extract_fixnum(g3));
|
|
||||||
ret1 = errno_or_false(r1);
|
|
||||||
S48_VECTOR_SET(mv_vec,0,s48_enter_fixnum(r1));
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_read_fdes_char(s48_value g1)
|
s48_value df_read_fdes_char(s48_value g1)
|
||||||
{
|
{
|
||||||
extern s48_value read_fdes_char(int );
|
extern s48_value read_fdes_char(int );
|
||||||
|
@ -613,44 +111,6 @@ s48_value df_write_fdes_substring(s48_value g1, s48_value g2, s48_value g3, s48_
|
||||||
return ret1;
|
return ret1;
|
||||||
}
|
}
|
||||||
|
|
||||||
s48_value df_pause(void)
|
|
||||||
{
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
pause();
|
|
||||||
return S48_FALSE;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_open_dir(s48_value g1, s48_value mv_vec)
|
|
||||||
{
|
|
||||||
extern int open_dir(const char *, char** *, int *);
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(2);
|
|
||||||
int r1;
|
|
||||||
char** r2 = 0;
|
|
||||||
int r3 = 0;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_2(mv_vec,ret1);
|
|
||||||
r1 = open_dir(s48_extract_string(g1), &r2, &r3);
|
|
||||||
ret1 = False_on_zero(r1);
|
|
||||||
SetAlienVal(S48_VECTOR_REF(mv_vec,0),(long) r2);//simple-assign
|
|
||||||
S48_VECTOR_SET(mv_vec,1,s48_enter_fixnum(r3));
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_scm_sort_filevec(s48_value g1, s48_value g2)
|
|
||||||
{
|
|
||||||
extern void scm_sort_filevec(const char** , int );
|
|
||||||
|
|
||||||
|
|
||||||
scm_sort_filevec((const char** )AlienVal(g1), s48_extract_fixnum(g2));
|
|
||||||
return S48_FALSE;
|
|
||||||
}
|
|
||||||
|
|
||||||
s48_value df_sleep_until(s48_value g1)
|
s48_value df_sleep_until(s48_value g1)
|
||||||
{
|
{
|
||||||
extern s48_value sleep_until(time_t );
|
extern s48_value sleep_until(time_t );
|
||||||
|
@ -667,23 +127,6 @@ s48_value df_sleep_until(s48_value g1)
|
||||||
return ret1;
|
return ret1;
|
||||||
}
|
}
|
||||||
|
|
||||||
s48_value df_errno_msg(s48_value g1, s48_value mv_vec)
|
|
||||||
{
|
|
||||||
extern char *errno_msg(int );
|
|
||||||
s48_value ret1 = S48_FALSE;
|
|
||||||
S48_DECLARE_GC_PROTECT(2);
|
|
||||||
char *r1;
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
S48_GC_PROTECT_2(mv_vec,ret1);
|
|
||||||
r1 = errno_msg(s48_extract_integer(g1));
|
|
||||||
ret1 = S48_VECTOR_REF(mv_vec,0);
|
|
||||||
SetAlienVal(S48_CAR(ret1),(long) r1); S48_SET_CDR(ret1,strlen_or_false(r1));//str-and-len
|
|
||||||
S48_GC_UNPROTECT();
|
|
||||||
return ret1;
|
|
||||||
}
|
|
||||||
|
|
||||||
void s48_init_syscalls(void)
|
void s48_init_syscalls(void)
|
||||||
{
|
{
|
||||||
S48_EXPORT_FUNCTION(scheme_exec);
|
S48_EXPORT_FUNCTION(scheme_exec);
|
||||||
|
@ -702,50 +145,48 @@ void s48_init_syscalls(void)
|
||||||
S48_EXPORT_FUNCTION(scsh_geteuid);
|
S48_EXPORT_FUNCTION(scsh_geteuid);
|
||||||
S48_EXPORT_FUNCTION(scsh_setuid);
|
S48_EXPORT_FUNCTION(scsh_setuid);
|
||||||
S48_EXPORT_FUNCTION(scsh_seteuid);
|
S48_EXPORT_FUNCTION(scsh_seteuid);
|
||||||
S48_EXPORT_FUNCTION(df_getpid);
|
S48_EXPORT_FUNCTION(scsh_getpid);
|
||||||
S48_EXPORT_FUNCTION(df_getppid);
|
S48_EXPORT_FUNCTION(scsh_getppid);
|
||||||
S48_EXPORT_FUNCTION(df_getpgrp);
|
S48_EXPORT_FUNCTION(scsh_getpgrp);
|
||||||
S48_EXPORT_FUNCTION(df_setpgid);
|
S48_EXPORT_FUNCTION(setpgid);
|
||||||
S48_EXPORT_FUNCTION(df_setsid);
|
S48_EXPORT_FUNCTION(scsh_setsid);
|
||||||
S48_EXPORT_FUNCTION(df_umask);
|
S48_EXPORT_FUNCTION(scsh_umask);
|
||||||
S48_EXPORT_FUNCTION(df_process_times);
|
S48_EXPORT_FUNCTION(process_times);
|
||||||
S48_EXPORT_FUNCTION(df_cpu_clock_ticks_per_sec);
|
S48_EXPORT_FUNCTION(cpu_clock_ticks_per_sec);
|
||||||
S48_EXPORT_FUNCTION(df_chmod);
|
S48_EXPORT_FUNCTION(scsh_chmod);
|
||||||
S48_EXPORT_FUNCTION(df_fchmod);
|
S48_EXPORT_FUNCTION(scsh_fchmod);
|
||||||
S48_EXPORT_FUNCTION(df_chown);
|
S48_EXPORT_FUNCTION(scsh_chown);
|
||||||
S48_EXPORT_FUNCTION(df_fchown);
|
S48_EXPORT_FUNCTION(scsh_fchown);
|
||||||
S48_EXPORT_FUNCTION(df_access);
|
S48_EXPORT_FUNCTION(scsh_access);
|
||||||
S48_EXPORT_FUNCTION(df_link);
|
S48_EXPORT_FUNCTION(scsh_link);
|
||||||
S48_EXPORT_FUNCTION(df_mkfifo);
|
S48_EXPORT_FUNCTION(scsh_mkfifo);
|
||||||
S48_EXPORT_FUNCTION(df_mkdir);
|
S48_EXPORT_FUNCTION(scsh_mkdir);
|
||||||
S48_EXPORT_FUNCTION(scm_readlink);
|
S48_EXPORT_FUNCTION(scsh_readlink);
|
||||||
S48_EXPORT_FUNCTION(df_rename);
|
S48_EXPORT_FUNCTION(scsh_rename);
|
||||||
S48_EXPORT_FUNCTION(df_rmdir);
|
S48_EXPORT_FUNCTION(scsh_rmdir);
|
||||||
S48_EXPORT_FUNCTION(df_scm_utime);
|
S48_EXPORT_FUNCTION(scm_utime);
|
||||||
S48_EXPORT_FUNCTION(df_scm_utime_now);
|
S48_EXPORT_FUNCTION(scm_utime_now);
|
||||||
S48_EXPORT_FUNCTION(scheme_stat);
|
S48_EXPORT_FUNCTION(scheme_stat);
|
||||||
S48_EXPORT_FUNCTION(scheme_fstat);
|
S48_EXPORT_FUNCTION(scheme_fstat);
|
||||||
S48_EXPORT_FUNCTION(df_symlink);
|
S48_EXPORT_FUNCTION(scsh_symlink);
|
||||||
S48_EXPORT_FUNCTION(df_truncate);
|
S48_EXPORT_FUNCTION(scsh_truncate);
|
||||||
S48_EXPORT_FUNCTION(df_ftruncate);
|
S48_EXPORT_FUNCTION(scsh_ftruncate);
|
||||||
S48_EXPORT_FUNCTION(df_unlink);
|
S48_EXPORT_FUNCTION(scsh_unlink);
|
||||||
S48_EXPORT_FUNCTION(df_fsync);
|
S48_EXPORT_FUNCTION(scsh_fsync);
|
||||||
S48_EXPORT_FUNCTION(df_sync);
|
S48_EXPORT_FUNCTION(scsh_sync);
|
||||||
S48_EXPORT_FUNCTION(df_close);
|
S48_EXPORT_FUNCTION(scsh_close);
|
||||||
S48_EXPORT_FUNCTION(df_dup);
|
S48_EXPORT_FUNCTION(scsh_dup);
|
||||||
S48_EXPORT_FUNCTION(df_dup2);
|
S48_EXPORT_FUNCTION(scsh_dup2);
|
||||||
S48_EXPORT_FUNCTION(df_lseek);
|
S48_EXPORT_FUNCTION(scsh_lseek);
|
||||||
S48_EXPORT_FUNCTION(df_char_ready_fdes);
|
S48_EXPORT_FUNCTION(df_char_ready_fdes);
|
||||||
S48_EXPORT_FUNCTION(df_open);
|
S48_EXPORT_FUNCTION(scsh_open);
|
||||||
S48_EXPORT_FUNCTION(scheme_pipe);
|
S48_EXPORT_FUNCTION(scheme_pipe);
|
||||||
S48_EXPORT_FUNCTION(df_read_fdes_char);
|
S48_EXPORT_FUNCTION(df_read_fdes_char);
|
||||||
S48_EXPORT_FUNCTION(df_write_fdes_char);
|
S48_EXPORT_FUNCTION(df_write_fdes_char);
|
||||||
S48_EXPORT_FUNCTION(df_read_fdes_substring);
|
S48_EXPORT_FUNCTION(df_read_fdes_substring);
|
||||||
S48_EXPORT_FUNCTION(df_write_fdes_substring);
|
S48_EXPORT_FUNCTION(df_write_fdes_substring);
|
||||||
S48_EXPORT_FUNCTION(scsh_kill);
|
S48_EXPORT_FUNCTION(scsh_kill);
|
||||||
S48_EXPORT_FUNCTION(df_pause);
|
S48_EXPORT_FUNCTION(open_dir);
|
||||||
S48_EXPORT_FUNCTION(df_open_dir);
|
|
||||||
S48_EXPORT_FUNCTION(df_scm_sort_filevec);
|
|
||||||
S48_EXPORT_FUNCTION(scm_envvec);
|
S48_EXPORT_FUNCTION(scm_envvec);
|
||||||
S48_EXPORT_FUNCTION(create_env);
|
S48_EXPORT_FUNCTION(create_env);
|
||||||
S48_EXPORT_FUNCTION(align_env);
|
S48_EXPORT_FUNCTION(align_env);
|
||||||
|
@ -755,6 +196,6 @@ void s48_init_syscalls(void)
|
||||||
S48_EXPORT_FUNCTION(fcntl_write);
|
S48_EXPORT_FUNCTION(fcntl_write);
|
||||||
S48_EXPORT_FUNCTION(df_sleep_until);
|
S48_EXPORT_FUNCTION(df_sleep_until);
|
||||||
S48_EXPORT_FUNCTION(scm_gethostname);
|
S48_EXPORT_FUNCTION(scm_gethostname);
|
||||||
S48_EXPORT_FUNCTION(df_errno_msg);
|
S48_EXPORT_FUNCTION(errno_msg);
|
||||||
S48_EXPORT_FUNCTION(scm_crypt);
|
S48_EXPORT_FUNCTION(scm_crypt);
|
||||||
}
|
}
|
||||||
|
|
|
@ -79,6 +79,16 @@
|
||||||
;;; like crazy. So I'm doing it this way. Ech.
|
;;; like crazy. So I'm doing it this way. Ech.
|
||||||
|
|
||||||
|
|
||||||
|
(define-syntax define-retrying-syscall
|
||||||
|
(syntax-rules ()
|
||||||
|
((define-retrying-syscall syscall syscall/eintr)
|
||||||
|
(define (syscall . args)
|
||||||
|
(let loop ()
|
||||||
|
(with-errno-handler
|
||||||
|
((errno packet)
|
||||||
|
((errno/intr) (display "eintr")(loop)))
|
||||||
|
(apply syscall/eintr args)))))))
|
||||||
|
|
||||||
;;; Process
|
;;; Process
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; we can't algin env here, because exec-path/env calls
|
;; we can't algin env here, because exec-path/env calls
|
||||||
|
@ -161,21 +171,17 @@
|
||||||
|
|
||||||
;;; PID
|
;;; PID
|
||||||
|
|
||||||
(define-foreign pid (getpid) pid_t)
|
(define-stubless-foreign pid () "scsh_getpid")
|
||||||
(define-foreign parent-pid (getppid) pid_t)
|
(define-stubless-foreign parent-pid () "scsh_getppid")
|
||||||
|
|
||||||
|
|
||||||
;;; Process groups and session ids
|
;;; Process groups and session ids
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(define-foreign process-group (getpgrp) pid_t)
|
(define-stubless-foreign process-group () "scsh_getpgrp")
|
||||||
(define-foreign %set-process-group/errno
|
|
||||||
(setpgid (pid_t pid) (pid_t groupid))
|
|
||||||
(to-scheme fixnum errno_or_false))
|
|
||||||
|
|
||||||
(define-errno-syscall (%set-process-group pid pgrp)
|
(define-stubless-foreign %set-process-group/eintr
|
||||||
%set-process-group/errno)
|
(pid groupid) "setpgid")
|
||||||
|
|
||||||
|
(define-retrying-syscall %set-process-group %set-process-group/eintr)
|
||||||
|
|
||||||
(define (set-process-group arg1 . maybe-arg2)
|
(define (set-process-group arg1 . maybe-arg2)
|
||||||
(receive (pid pgrp) (if (null? maybe-arg2)
|
(receive (pid pgrp) (if (null? maybe-arg2)
|
||||||
|
@ -184,18 +190,12 @@
|
||||||
(%set-process-group pid pgrp)))
|
(%set-process-group pid pgrp)))
|
||||||
|
|
||||||
|
|
||||||
(define-foreign become-session-leader/errno (setsid)
|
(define-stubless-foreign become-session-leader/eintr () "scsh_setsid")
|
||||||
(multi-rep (to-scheme pid_t errno_or_false)
|
(define-retrying-syscall become-session-leader become-session-leader/eintr)
|
||||||
pid_t))
|
|
||||||
|
|
||||||
(define-errno-syscall (become-session-leader) become-session-leader/errno
|
|
||||||
sid)
|
|
||||||
|
|
||||||
|
|
||||||
;;; UMASK
|
;;; UMASK
|
||||||
|
|
||||||
(define-foreign set-process-umask (umask (mode_t mask)) no-declare ; integer on SunOS
|
(define-stubless-foreign set-process-umask (mask) "scsh_umask")
|
||||||
mode_t)
|
|
||||||
|
|
||||||
(define (process-umask)
|
(define (process-umask)
|
||||||
(let ((m (set-process-umask 0)))
|
(let ((m (set-process-umask 0)))
|
||||||
|
@ -208,17 +208,13 @@
|
||||||
;;; OOPS: The POSIX times() has a mildly useful ret value we are throwing away.
|
;;; OOPS: The POSIX times() has a mildly useful ret value we are throwing away.
|
||||||
|
|
||||||
|
|
||||||
(define-foreign process-times/errno (process_times)
|
(define-stubless-foreign process-times/eintr-list () "process_times")
|
||||||
(to-scheme integer errno_or_false)
|
|
||||||
clock_t ; user cpu time
|
|
||||||
clock_t ; system cpu time
|
|
||||||
clock_t ; user cpu time for me and all my descendants.
|
|
||||||
clock_t) ; system cpu time for me and all my descendants.
|
|
||||||
|
|
||||||
(define-errno-syscall (process-times) process-times/errno
|
(define (process-times)
|
||||||
utime stime cutime cstime)
|
(define-retrying-syscall process-times/list process-times/eintr-list)
|
||||||
|
(apply values (process-times/list)))
|
||||||
|
|
||||||
(define-foreign cpu-ticks/sec (cpu_clock_ticks_per_sec) integer)
|
(define-stubless-foreign cpu-ticks/sec () "cpu_clock_ticks_per_sec")
|
||||||
|
|
||||||
;;; File system
|
;;; File system
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
@ -231,54 +227,38 @@
|
||||||
(call/fdes thing fd-op)))
|
(call/fdes thing fd-op)))
|
||||||
|
|
||||||
|
|
||||||
(define-foreign set-file-mode/errno
|
(define-stubless-foreign %set-file-mode/eintr (path mode) "scsh_chmod")
|
||||||
(chmod (string path) (mode_t mode)) no-declare ; integer on SunOS
|
(define-retrying-syscall %set-file-mode %set-file-mode/eintr)
|
||||||
(to-scheme fixnum errno_or_false))
|
|
||||||
|
|
||||||
; IBM's AIX include files declare fchmod(char*, mode_t).
|
(define-stubless-foreign %set-fdes-mode/eintr (path mode) "scsh_fchmod")
|
||||||
; Amazing, but true. So we must prevent this def-foreign from issuing
|
(define-retrying-syscall %set-fdes-mode %set-fdes-mode/eintr)
|
||||||
; the conflicting, correct declaration. Hence the NO-DECLARE.
|
|
||||||
|
|
||||||
(define-foreign set-fdes-mode/errno
|
(define (set-file-mode thing mode)
|
||||||
(fchmod (fixnum fd) (mode_t mode)) ; integer on SunOS
|
(generic-file-op thing
|
||||||
no-declare ; Workaround for AIX bug.
|
(lambda (fd) (%set-fdes-mode fd mode))
|
||||||
(to-scheme fixnum errno_or_false))
|
(lambda (fname) (%set-file-mode fname mode))))
|
||||||
|
|
||||||
(define-errno-syscall (set-file-mode thing mode)
|
|
||||||
(lambda (thing mode)
|
|
||||||
(generic-file-op thing
|
|
||||||
(lambda (fd) (set-fdes-mode/errno fd mode))
|
|
||||||
(lambda (fname) (set-file-mode/errno fname mode)))))
|
|
||||||
|
|
||||||
|
|
||||||
;;; NO-DECLARE: gcc unistd.h bogusness.
|
(define-stubless-foreign set-file-uid&gid/eintr (path uid gid) "scsh_chown")
|
||||||
(define-foreign set-file-uid&gid/errno
|
(define-retrying-syscall set-file-uid&gid set-file-uid&gid/eintr)
|
||||||
(chown (string path) (uid_t uid) (gid_t gid)) no-declare
|
|
||||||
(to-scheme fixnum errno_or_false))
|
|
||||||
|
|
||||||
(define-foreign set-fdes-uid&gid/errno
|
(define-stubless-foreign set-fdes-uid&gid/eintr (fd uid gid) "scsh_fchown")
|
||||||
(fchown (fixnum fd) (uid_t uid) (gid_t gid))
|
(define-retrying-syscall set-fdes-uid&gid set-fdes-uid&gid/eintr)
|
||||||
(to-scheme fixnum errno_or_false))
|
|
||||||
|
|
||||||
(define-errno-syscall (set-file-owner thing uid)
|
(define (set-file-owner thing uid)
|
||||||
(lambda (thing uid)
|
(generic-file-op thing
|
||||||
(generic-file-op thing
|
(lambda (fd) (set-fdes-uid&gid fd uid -1))
|
||||||
(lambda (fd) (set-fdes-uid&gid/errno fd uid -1))
|
(lambda (fname) (set-file-uid&gid fname uid -1))))
|
||||||
(lambda (fname) (set-file-uid&gid/errno fname uid -1)))))
|
|
||||||
|
|
||||||
(define-errno-syscall (set-file-group thing gid)
|
(define (set-file-group thing gid)
|
||||||
(lambda (thing gid)
|
(generic-file-op thing
|
||||||
(generic-file-op thing
|
(lambda (fd) (set-fdes-uid&gid fd -1 gid))
|
||||||
(lambda (fd) (set-fdes-uid&gid/errno fd -1 gid))
|
(lambda (fname) (set-file-uid&gid fname -1 gid))))
|
||||||
(lambda (fname) (set-file-uid&gid/errno fname -1 gid)))))
|
|
||||||
|
|
||||||
|
|
||||||
;;; Uses real uid and gid, not effective. I don't use this anywhere.
|
;;; Uses real uid and gid, not effective. I don't use this anywhere.
|
||||||
|
|
||||||
(define-foreign %file-ruid-access-not?
|
(define-stubless-foreign %file-ruid-access-not? (path perms) "scsh_access")
|
||||||
(access (string path)
|
|
||||||
(integer perms))
|
|
||||||
bool)
|
|
||||||
|
|
||||||
;(define (file-access? path perms)
|
;(define (file-access? path perms)
|
||||||
; (not (%file-access-not? path perms)))
|
; (not (%file-access-not? path perms)))
|
||||||
|
@ -293,80 +273,58 @@
|
||||||
; (file-access? fname 4))
|
; (file-access? fname 4))
|
||||||
|
|
||||||
|
|
||||||
(define-foreign create-hard-link/errno
|
(define-stubless-foreign create-hard-link/eintr (original-name new-name)
|
||||||
(link (string original-name) (string new-name))
|
"scsh_link")
|
||||||
(to-scheme fixnum errno_or_false))
|
(define-retrying-syscall %create-hard-link create-hard-link/eintr)
|
||||||
|
|
||||||
(define-errno-syscall (create-hard-link original-name new-name)
|
(define-stubless-foreign create-fifo/eintr (path mode) "scsh_mkfifo")
|
||||||
create-hard-link/errno)
|
(define-retrying-syscall %create-fifo create-fifo/eintr)
|
||||||
|
|
||||||
|
(define-stubless-foreign create-directory/eintr (path mode) "scsh_mkdir")
|
||||||
|
(define-retrying-syscall %%create-directory create-directory/eintr)
|
||||||
|
|
||||||
(define-foreign create-fifo/errno (mkfifo (string path) (mode_t mode))
|
(define (%create-directory path . maybe-mode)
|
||||||
no-declare ; integer on SunOS
|
|
||||||
(to-scheme fixnum errno_or_false))
|
|
||||||
|
|
||||||
(define-errno-syscall (create-fifo path mode) create-fifo/errno)
|
|
||||||
|
|
||||||
|
|
||||||
(define-foreign create-directory/errno
|
|
||||||
(mkdir (string path) (mode_t mode)) no-declare ; integer on SunOS.
|
|
||||||
(to-scheme fixnum errno_or_false))
|
|
||||||
|
|
||||||
(define (create-directory path . maybe-mode)
|
|
||||||
(let ((mode (:optional maybe-mode #o777))
|
(let ((mode (:optional maybe-mode #o777))
|
||||||
(fname (ensure-file-name-is-nondirectory path)))
|
(fname (ensure-file-name-is-nondirectory path)))
|
||||||
(cond ((create-directory/errno fname mode) =>
|
(%%create-directory fname mode)))
|
||||||
(lambda (err)
|
|
||||||
(if err (errno-error err create-directory path mode)))))))
|
|
||||||
|
|
||||||
(define-stubless-foreign read-symlink (path) "scm_readlink")
|
(define-stubless-foreign read-symlink/eintr (path) "scsh_readlink")
|
||||||
|
(define-retrying-syscall read-symlink read-symlink/eintr)
|
||||||
|
|
||||||
(define-foreign %rename-file/errno
|
(define-stubless-foreign %rename-file/eintr (old-name new-name) "scsh_rename")
|
||||||
(rename (string old-name) (string new-name))
|
(define-retrying-syscall %rename-file %rename-file/eintr)
|
||||||
(to-scheme fixnum errno_or_false))
|
|
||||||
|
|
||||||
(define-errno-syscall (%rename-file old-name new-name)
|
|
||||||
%rename-file/errno)
|
|
||||||
|
|
||||||
|
|
||||||
(define-foreign delete-directory/errno
|
(define-stubless-foreign delete-directory/eintr (path) "scsh_rmdir")
|
||||||
(rmdir (string path))
|
(define-retrying-syscall delete-directory delete-directory/eintr)
|
||||||
(to-scheme fixnum errno_or_false))
|
|
||||||
|
|
||||||
(define-errno-syscall (delete-directory path) delete-directory/errno)
|
(define-stubless-foreign %utime/eintr (path ac m) "scm_utime")
|
||||||
|
(define-retrying-syscall %utime %utime/eintr)
|
||||||
|
|
||||||
|
(define-stubless-foreign %utime-now/eintr (path) "scm_utime_now")
|
||||||
|
(define-retrying-syscall %utime-now %utime-now/eintr)
|
||||||
|
|
||||||
(define-foreign %utime/errno (scm_utime (string path)
|
;;; (SET-FILE-TIMES path [access-time mod-time])
|
||||||
(time_t ac)
|
|
||||||
(time_t m))
|
|
||||||
(to-scheme fixnum errno_or_false))
|
|
||||||
|
|
||||||
(define-foreign %utime-now/errno (scm_utime_now (string path))
|
(define (set-file-times path . maybe-times)
|
||||||
(to-scheme fixnum errno_or_false))
|
|
||||||
|
|
||||||
|
|
||||||
;;; (SET-FILE-TIMES/ERRNO path [access-time mod-time])
|
|
||||||
|
|
||||||
(define (set-file-times/errno path . maybe-times)
|
|
||||||
(if (pair? maybe-times)
|
(if (pair? maybe-times)
|
||||||
(let* ((access-time (real->exact-integer (car maybe-times)))
|
(let* ((access-time (real->exact-integer (car maybe-times)))
|
||||||
(mod-time (if (pair? (cddr maybe-times))
|
(mod-time (if (pair? (cddr maybe-times))
|
||||||
(error "Too many arguments to set-file-times/errno"
|
(error "Too many arguments to set-file-times/errno"
|
||||||
(cons path maybe-times))
|
(cons path maybe-times))
|
||||||
(real->exact-integer (cadr maybe-times)))))
|
(real->exact-integer (cadr maybe-times)))))
|
||||||
(%utime/errno path access-time
|
(%utime path access-time
|
||||||
mod-time ))
|
mod-time ))
|
||||||
(%utime-now/errno path)))
|
(%utime-now path)))
|
||||||
|
|
||||||
(define-errno-syscall (set-file-times . args) set-file-times/errno)
|
|
||||||
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;;; STAT
|
;;; STAT
|
||||||
|
|
||||||
(define-stubless-foreign stat-file (path data chase?) "scheme_stat")
|
(define-stubless-foreign stat-file/eintr (path data chase?) "scheme_stat")
|
||||||
|
(define-retrying-syscall stat-file stat-file/eintr)
|
||||||
|
|
||||||
(define-stubless-foreign stat-fdes (fd data) "scheme_fstat")
|
(define-stubless-foreign stat-fdes/eintr (fd data) "scheme_fstat")
|
||||||
|
(define-retrying-syscall stat-fdes stat-fdes/eintr)
|
||||||
|
|
||||||
(define-record file-info
|
(define-record file-info
|
||||||
type
|
type
|
||||||
|
@ -421,90 +379,52 @@
|
||||||
;;; "no-declare" as there is no agreement among the OS's as to whether or not
|
;;; "no-declare" as there is no agreement among the OS's as to whether or not
|
||||||
;;; the OLD-NAME arg is "const". It *should* be const.
|
;;; the OLD-NAME arg is "const". It *should* be const.
|
||||||
|
|
||||||
(define-foreign create-symlink/errno
|
(define-stubless-foreign create-symlink/eintr (old-name new-name) "scsh_symlink")
|
||||||
(symlink (string old-name) (string new-name)) no-declare
|
(define-retrying-syscall %create-symlink create-symlink/eintr)
|
||||||
(to-scheme fixnum errno_or_false))
|
|
||||||
|
|
||||||
;(define-errno-syscall (create-symlink old-name new-name)
|
|
||||||
; create-symlink/errno)
|
|
||||||
|
|
||||||
|
|
||||||
;;; "no-declare" as there is no agreement among the OS's as to whether or not
|
;;; "no-declare" as there is no agreement among the OS's as to whether or not
|
||||||
;;; the PATH arg is "const". It *should* be const.
|
;;; the PATH arg is "const". It *should* be const.
|
||||||
|
|
||||||
(define-foreign truncate-file/errno
|
(define-stubless-foreign %truncate-file/eintr (path length) "scsh_truncate")
|
||||||
(truncate (string path) (off_t length)) no-declare
|
(define-retrying-syscall %truncate-file %truncate-file/eintr)
|
||||||
(to-scheme fixnum errno_or_false))
|
|
||||||
|
|
||||||
(define-foreign truncate-fdes/errno
|
(define-stubless-foreign %truncate-fdes/eintr (path length) "scsh_ftruncate")
|
||||||
(ftruncate (fixnum fd) (off_t length)) no-declare ; Indigo bogosity.
|
(define-retrying-syscall %truncate-fdes %truncate-fdes/eintr)
|
||||||
(to-scheme fixnum errno_or_false))
|
|
||||||
|
|
||||||
(define-errno-syscall (truncate-file path length)
|
(define (truncate-file thing length)
|
||||||
(lambda (thing length)
|
(generic-file-op thing
|
||||||
(generic-file-op thing
|
(lambda (fd) (%truncate-fdes fd length))
|
||||||
(lambda (fd) (truncate-fdes/errno fd length))
|
(lambda (fname) (%truncate-file fname length))))
|
||||||
(lambda (fname) (truncate-file/errno fname length)))))
|
|
||||||
|
|
||||||
|
(define-stubless-foreign delete-file/eintr (path) "scsh_unlink")
|
||||||
|
(define-retrying-syscall delete-file delete-file/eintr)
|
||||||
|
|
||||||
(define-foreign delete-file/errno
|
(define-stubless-foreign %sync-file/eintr (fd) "scsh_fsync")
|
||||||
(unlink (string path))
|
(define-retrying-syscall %sync-file %sync-file/eintr)
|
||||||
(to-scheme fixnum errno_or_false))
|
|
||||||
|
|
||||||
(define-errno-syscall (delete-file path) delete-file/errno)
|
(define (sync-file fd/port)
|
||||||
|
(if (output-port? fd/port) (force-output fd/port))
|
||||||
|
(sleazy-call/fdes fd/port %sync-file))
|
||||||
(define-foreign sync-file/errno (fsync (fixnum fd))
|
|
||||||
(to-scheme fixnum errno_or_false))
|
|
||||||
|
|
||||||
(define-errno-syscall (sync-file fd/port)
|
|
||||||
(lambda (fd/port)
|
|
||||||
(if (output-port? fd/port) (force-output fd/port))
|
|
||||||
(sleazy-call/fdes fd/port sync-file/errno)))
|
|
||||||
|
|
||||||
|
|
||||||
;;; Amazingly bogus syscall -- doesn't *actually* sync the filesys.
|
;;; Amazingly bogus syscall -- doesn't *actually* sync the filesys.
|
||||||
(define-foreign sync-file-system (sync) no-declare ; Linux sux - says int
|
(define-stubless-foreign sync-file-system () "scsh_sync")
|
||||||
ignore)
|
|
||||||
|
|
||||||
|
|
||||||
;;; I/O
|
;;; I/O
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(define-foreign %close-fdes/errno (close (fixnum fd))
|
(define-stubless-foreign %close-fdes/eintr (fd) "scsh_close")
|
||||||
(to-scheme fixnum "errno_or_false"))
|
(define-retrying-syscall %close-fdes %close-fdes/eintr)
|
||||||
|
|
||||||
(define (%close-fdes fd)
|
(define-stubless-foreign %dup/eintr (fd) "scsh_dup")
|
||||||
(let lp ()
|
(define-retrying-syscall %dup %dup/eintr)
|
||||||
(let ((errno (%close-fdes/errno fd)))
|
|
||||||
(cond ((not errno) #t) ; Successful close.
|
|
||||||
((= errno errno/badf) #f) ; File descriptor already closed.
|
|
||||||
((= errno errno/intr) (lp)) ; Retry.
|
|
||||||
(else
|
|
||||||
(errno-error errno %close-fdes fd)))))) ; You lose.
|
|
||||||
|
|
||||||
(define-foreign %dup/errno
|
(define-stubless-foreign %dup2/eintr (fd-from fd-to) "scsh_dup2")
|
||||||
(dup (fixnum fd))
|
(define-retrying-syscall %dup2 %dup2/eintr)
|
||||||
(multi-rep (to-scheme fixnum errno_or_false)
|
|
||||||
fixnum))
|
|
||||||
|
|
||||||
(define-errno-syscall (%dup fd) %dup/errno
|
|
||||||
new-fd)
|
|
||||||
|
|
||||||
(define-foreign %dup2/errno
|
|
||||||
(dup2 (fixnum fd-from) (fixnum fd-to))
|
|
||||||
(multi-rep (to-scheme fixnum errno_or_false)
|
|
||||||
fixnum))
|
|
||||||
|
|
||||||
(define-errno-syscall (%dup2 fd-from fd-to) %dup2/errno
|
|
||||||
new-fd)
|
|
||||||
|
|
||||||
|
|
||||||
(define-foreign %fd-seek/errno
|
(define-stubless-foreign %fd-seek/eintr (fd offset whence) "scsh_lseek")
|
||||||
(lseek (fixnum fd) (off_t offset) (fixnum whence))
|
(define-retrying-syscall %fd-seek %fd-seek/eintr)
|
||||||
(multi-rep (to-scheme off_t errno_or_false)
|
|
||||||
off_t))
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
(define seek/set 0) ;Unix codes for "whence"
|
(define seek/set 0) ;Unix codes for "whence"
|
||||||
|
@ -514,13 +434,11 @@
|
||||||
(define (seek fd/port offset . maybe-whence)
|
(define (seek fd/port offset . maybe-whence)
|
||||||
(let ((whence (:optional maybe-whence seek/set))
|
(let ((whence (:optional maybe-whence seek/set))
|
||||||
(fd (if (integer? fd/port) fd/port (port->fdes fd/port))))
|
(fd (if (integer? fd/port) fd/port (port->fdes fd/port))))
|
||||||
(receive (err cursor) (%fd-seek/errno fd offset whence)
|
(%fd-seek fd offset whence)))
|
||||||
(if err (errno-error err seek fd offset whence) cursor))))
|
|
||||||
|
|
||||||
(define (tell fd/port)
|
(define (tell fd/port)
|
||||||
(let ((fd (if (integer? fd/port) fd/port (port->fdes fd/port))))
|
(let ((fd (if (integer? fd/port) fd/port (port->fdes fd/port))))
|
||||||
(receive (err offset) (%fd-seek/errno fd 0 seek/delta)
|
(%fd-seek fd 0 seek/delta)))
|
||||||
(if err (errno-error err tell fd/port) offset))))
|
|
||||||
|
|
||||||
(define-foreign %char-ready-fdes?/errno
|
(define-foreign %char-ready-fdes?/errno
|
||||||
(char_ready_fdes (fixnum fd))
|
(char_ready_fdes (fixnum fd))
|
||||||
|
@ -532,16 +450,8 @@
|
||||||
retval)))
|
retval)))
|
||||||
|
|
||||||
|
|
||||||
(define-foreign %open/errno
|
(define-stubless-foreign %open/eintr (path flags mode) "scsh_open")
|
||||||
(open (string path)
|
(define-retrying-syscall %open %open/eintr)
|
||||||
(fixnum flags)
|
|
||||||
(mode_t mode)) ; integer on SunOS
|
|
||||||
no-declare ; NOTE
|
|
||||||
(multi-rep (to-scheme fixnum errno_or_false)
|
|
||||||
fixnum))
|
|
||||||
|
|
||||||
(define-errno-syscall (%open path flags mode) %open/errno
|
|
||||||
fd)
|
|
||||||
|
|
||||||
(define (open-fdes path flags . maybe-mode) ; mode defaults to 0666
|
(define (open-fdes path flags . maybe-mode) ; mode defaults to 0666
|
||||||
(with-cwd-aligned
|
(with-cwd-aligned
|
||||||
|
@ -549,7 +459,8 @@
|
||||||
(%open path flags (:optional maybe-mode #o666)))))
|
(%open path flags (:optional maybe-mode #o666)))))
|
||||||
|
|
||||||
|
|
||||||
(define-stubless-foreign pipe-fdes () "scheme_pipe")
|
(define-stubless-foreign pipe-fdes/eintr () "scheme_pipe")
|
||||||
|
(define-retrying-syscall pipe-fdes pipe-fdes/eintr)
|
||||||
|
|
||||||
(define (pipe)
|
(define (pipe)
|
||||||
(apply (lambda (r-fd w-fd)
|
(apply (lambda (r-fd w-fd)
|
||||||
|
@ -598,7 +509,8 @@
|
||||||
;;; Signals (rather incomplete)
|
;;; Signals (rather incomplete)
|
||||||
;;; ---------------------------
|
;;; ---------------------------
|
||||||
|
|
||||||
(define-stubless-foreign signal-pid (pid signal) "scsh_kill")
|
(define-stubless-foreign signal-pid/eintr (pid signal) "scsh_kill")
|
||||||
|
(define-retrying-syscall signal-pid signal-pid/eintr)
|
||||||
|
|
||||||
(define (signal-process proc signal)
|
(define (signal-process proc signal)
|
||||||
(signal-pid (cond ((proc? proc) (proc:pid proc))
|
(signal-pid (cond ((proc? proc) (proc:pid proc))
|
||||||
|
@ -622,9 +534,9 @@
|
||||||
;;; (define-errno-syscall (signal-process-group proc-group signal)
|
;;; (define-errno-syscall (signal-process-group proc-group signal)
|
||||||
;;; signal-process-group/errno)
|
;;; signal-process-group/errno)
|
||||||
|
|
||||||
(define-foreign pause-until-interrupt (pause) no-declare ignore)
|
(define (pause-until-interrupt)
|
||||||
|
(next-sigevent (most-recent-sigevent) full-interrupt-set))
|
||||||
|
|
||||||
;;; now in low-interrupt: (define-foreign itimer (alarm (uint_t secs)) uint_t)
|
|
||||||
|
|
||||||
;;; User info
|
;;; User info
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
@ -726,32 +638,31 @@
|
||||||
;;; Directory stuff
|
;;; Directory stuff
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(define-foreign %open-dir (open_dir (string dir-name))
|
(define-stubless-foreign %open-dir/eintr (dir-name) "open_dir")
|
||||||
(to-scheme integer "False_on_zero") ; Win: #f, lose: errno
|
(define-retrying-syscall %open-dir %open-dir/eintr)
|
||||||
(C char**) ; Vector of strings
|
|
||||||
fixnum) ; Length of strings
|
|
||||||
|
|
||||||
;;; Takes a null-terminated C vector of strings -- filenames.
|
|
||||||
;;; Sorts them in place by the Unix filename order: ., .., dotfiles, others.
|
|
||||||
|
|
||||||
(define-foreign %sort-file-vector
|
|
||||||
(scm_sort_filevec ((C "const char** ~a") cvec)
|
|
||||||
(fixnum veclen))
|
|
||||||
ignore)
|
|
||||||
|
|
||||||
(define (directory-files . args)
|
(define (directory-files . args)
|
||||||
(with-cwd-aligned
|
(with-cwd-aligned
|
||||||
(let-optionals args ((dir ".")
|
(let-optionals args ((dir ".")
|
||||||
(dotfiles? #f))
|
(dotfiles? #f))
|
||||||
(check-arg string? dir directory-files)
|
(check-arg string? dir directory-files)
|
||||||
(receive (err cvec numfiles)
|
(let* ((files (%open-dir (ensure-file-name-is-nondirectory dir)))
|
||||||
(%open-dir (ensure-file-name-is-nondirectory dir))
|
(files-sorted ((structure-ref sort sort-list!) files filename<=)))
|
||||||
(if err (errno-error err directory-files dir dotfiles?))
|
(if dotfiles? files-sorted
|
||||||
(%sort-file-vector cvec numfiles)
|
(filter (lambda (f) (not (dotfile? f)))
|
||||||
(let ((files (vector->list (C-string-vec->Scheme&free cvec numfiles))))
|
files-sorted))))))
|
||||||
(if dotfiles? files
|
|
||||||
(filter (lambda (f) (not (char=? (string-ref f 0) #\.)))
|
(define (dotfile? f)
|
||||||
files)))))))
|
(char=? (string-ref f 0) #\.))
|
||||||
|
|
||||||
|
(define (filename<= f1 f2)
|
||||||
|
(if (dotfile? f1)
|
||||||
|
(if (dotfile? f2)
|
||||||
|
(string<= f1 f2)
|
||||||
|
#t)
|
||||||
|
(if (dotfile? f2)
|
||||||
|
#f
|
||||||
|
(string<= f1 f2))))
|
||||||
|
|
||||||
;;; I do this one in C, I'm not sure why:
|
;;; I do this one in C, I'm not sure why:
|
||||||
;;; It is used by MATCH-FILES.
|
;;; It is used by MATCH-FILES.
|
||||||
|
@ -833,13 +744,16 @@
|
||||||
;;; Fd-ports
|
;;; Fd-ports
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(define-stubless-foreign %set-cloexec (fd val) "set_cloexec")
|
(define-stubless-foreign %set-cloexec/eintr (fd val) "set_cloexec")
|
||||||
|
(define-retrying-syscall %set-cloexec %set-cloexec/eintr)
|
||||||
|
|
||||||
;;; Some of fcntl()
|
;;; Some of fcntl()
|
||||||
;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(define-stubless-foreign %fcntl-read (fd command) "fcntl_read")
|
(define-stubless-foreign %fcntl-read/eintr (fd command) "fcntl_read")
|
||||||
(define-stubless-foreign %fcntl-write (fd command val) "fcntl_write")
|
(define-retrying-syscall %fcntl-read %fcntl-read/eintr)
|
||||||
|
(define-stubless-foreign %fcntl-write/eintr (fd command val) "fcntl_write")
|
||||||
|
(define-retrying-syscall %fcntl-write %fcntl-write/eintr)
|
||||||
|
|
||||||
;;; fcntl()'s F_GETFD and F_SETFD. Note that the SLEAZY- prefix on the
|
;;; fcntl()'s F_GETFD and F_SETFD. Note that the SLEAZY- prefix on the
|
||||||
;;; CALL/FDES isn't an optimisation; it's *required* for the correct behaviour
|
;;; CALL/FDES isn't an optimisation; it's *required* for the correct behaviour
|
||||||
|
@ -888,12 +802,12 @@
|
||||||
(define-foreign %sleep-until (sleep_until (time_t secs))
|
(define-foreign %sleep-until (sleep_until (time_t secs))
|
||||||
desc)
|
desc)
|
||||||
|
|
||||||
(define-stubless-foreign %gethostname () "scm_gethostname")
|
(define-stubless-foreign %gethostname/eintr () "scm_gethostname")
|
||||||
|
(define-retrying-syscall %gethostname %gethostname/eintr)
|
||||||
|
|
||||||
(define system-name %gethostname)
|
(define system-name %gethostname)
|
||||||
|
|
||||||
(define-foreign errno-msg (errno_msg (integer i))
|
(define-stubless-foreign errno-msg (i) "errno_msg")
|
||||||
static-string)
|
|
||||||
|
|
||||||
(define-stubless-foreign %crypt (key salt) "scm_crypt")
|
(define-stubless-foreign %crypt (key salt) "scm_crypt")
|
||||||
|
|
||||||
|
|
326
scsh/syscalls1.c
326
scsh/syscalls1.c
|
@ -156,24 +156,24 @@ s48_value scheme_pipe()
|
||||||
S48_NULL));
|
S48_NULL));
|
||||||
}
|
}
|
||||||
|
|
||||||
s48_value scsh_kill (s48_value pid, s48_value signal)
|
s48_value scsh_kill (s48_value sch_pid, s48_value sch_signal)
|
||||||
{
|
{
|
||||||
int ret = kill ((pid_t) s48_extract_fixnum (pid),
|
int retval = kill ((pid_t) s48_extract_fixnum (sch_pid),
|
||||||
s48_extract_fixnum (signal));
|
s48_extract_fixnum (sch_signal));
|
||||||
if (ret == -1)
|
if (retval == -1)
|
||||||
s48_raise_os_error_2(errno, pid, signal);
|
s48_raise_os_error_2(errno, sch_pid, sch_signal);
|
||||||
else return s48_enter_fixnum (ret);
|
else return s48_enter_fixnum (retval);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
/* Read the symlink. */
|
/* Read the symlink. */
|
||||||
|
|
||||||
s48_value scm_readlink(s48_value path)
|
s48_value scsh_readlink(s48_value sch_path)
|
||||||
{
|
{
|
||||||
char linkpath[MAXPATHLEN+1];
|
char linkpath[MAXPATHLEN+1];
|
||||||
int retval = readlink(s48_extract_string (path), linkpath, MAXPATHLEN);
|
int retval = readlink(s48_extract_string (sch_path), linkpath, MAXPATHLEN);
|
||||||
if (retval == -1)
|
if (retval == -1)
|
||||||
s48_raise_os_error_1(errno, path);
|
s48_raise_os_error_1(errno, sch_path);
|
||||||
else
|
else
|
||||||
{
|
{
|
||||||
linkpath[retval] = '\0';
|
linkpath[retval] = '\0';
|
||||||
|
@ -181,20 +181,47 @@ s48_value scm_readlink(s48_value path)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
s48_value scsh_rename(s48_value sch_from, s48_value sch_to)
|
||||||
|
{
|
||||||
|
int retval = rename (s48_extract_string (sch_from),
|
||||||
|
s48_extract_string (sch_to));
|
||||||
|
if (retval == -1)
|
||||||
|
s48_raise_os_error_2(errno, sch_from, sch_to);
|
||||||
|
return S48_UNSPECIFIC;
|
||||||
|
}
|
||||||
|
|
||||||
|
s48_value scsh_rmdir(s48_value sch_path)
|
||||||
|
{
|
||||||
|
int retval = rmdir (s48_extract_string (sch_path));
|
||||||
|
if (retval == -1)
|
||||||
|
s48_raise_os_error_1(errno, sch_path);
|
||||||
|
return S48_UNSPECIFIC;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
/* Scheme interfaces to utime().
|
/* Scheme interfaces to utime().
|
||||||
** Complicated by need to pass real 32-bit quantities.
|
** Complicated by need to pass real 32-bit quantities.
|
||||||
*/
|
*/
|
||||||
|
|
||||||
int scm_utime(char const *path, time_t ac, time_t mod)
|
s48_value scm_utime(s48_value sch_path, s48_value sch_ac, s48_value sch_mod)
|
||||||
{
|
{
|
||||||
struct utimbuf t;
|
struct utimbuf t;
|
||||||
t.actime = ac;
|
int retval;
|
||||||
t.modtime = mod;
|
t.actime = s48_extract_integer (sch_ac);
|
||||||
return utime(path, &t);
|
t.modtime = s48_extract_integer (sch_mod);
|
||||||
|
retval = utime(s48_extract_string (sch_path), &t);
|
||||||
|
if (retval == -1)
|
||||||
|
s48_raise_os_error_3(errno, sch_path, sch_ac, sch_mod);
|
||||||
|
return S48_UNSPECIFIC;
|
||||||
}
|
}
|
||||||
|
|
||||||
int scm_utime_now(char const *path) {return utime(path, 0);}
|
s48_value scm_utime_now(s48_value sch_path){
|
||||||
|
int retval = utime (s48_extract_string (sch_path), 0);
|
||||||
|
if (retval == -1)
|
||||||
|
s48_raise_os_error_1(errno, sch_path);
|
||||||
|
return S48_UNSPECIFIC;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
s48_value set_cloexec(s48_value _fd, s48_value _val)
|
s48_value set_cloexec(s48_value _fd, s48_value _val)
|
||||||
|
@ -214,7 +241,8 @@ s48_value set_cloexec(s48_value _fd, s48_value _val)
|
||||||
else return S48_FALSE;
|
else return S48_FALSE;
|
||||||
}
|
}
|
||||||
|
|
||||||
s48_value scsh_chdir(s48_value directory){
|
s48_value scsh_chdir(s48_value directory)
|
||||||
|
{
|
||||||
int retval = chdir (s48_extract_string (directory));
|
int retval = chdir (s48_extract_string (directory));
|
||||||
if (retval == -1)
|
if (retval == -1)
|
||||||
s48_raise_os_error_1(errno, directory);
|
s48_raise_os_error_1(errno, directory);
|
||||||
|
@ -270,36 +298,117 @@ s48_value scheme_cwd()
|
||||||
** but cig can't handle it.
|
** but cig can't handle it.
|
||||||
*/
|
*/
|
||||||
|
|
||||||
int process_times(clock_t *utime, clock_t *stime,
|
s48_value process_times()
|
||||||
clock_t *cutime, clock_t *cstime)
|
|
||||||
{
|
{
|
||||||
struct tms tms;
|
struct tms tms;
|
||||||
clock_t t = times(&tms);
|
clock_t t = times(&tms);
|
||||||
if (t == -1) return -1;
|
if (t == -1) s48_raise_os_error(errno);
|
||||||
*utime = tms.tms_utime;
|
return
|
||||||
*stime = tms.tms_stime;
|
s48_cons(s48_enter_integer (tms.tms_utime),
|
||||||
*cutime = tms.tms_cutime;
|
s48_cons(s48_enter_integer (tms.tms_stime),
|
||||||
*cstime = tms.tms_cstime;
|
s48_cons(s48_enter_integer (tms.tms_cutime),
|
||||||
return t;
|
s48_cons(s48_enter_integer (tms.tms_cstime),
|
||||||
}
|
S48_NULL))));
|
||||||
|
}
|
||||||
|
|
||||||
int cpu_clock_ticks_per_sec()
|
s48_value cpu_clock_ticks_per_sec()
|
||||||
{
|
{
|
||||||
#ifdef _SC_CLK_TCK
|
#ifdef _SC_CLK_TCK
|
||||||
static long clock_tick = 0;
|
static long clock_tick = 0;
|
||||||
|
|
||||||
if (clock_tick == 0)
|
if (clock_tick == 0){
|
||||||
clock_tick = sysconf(_SC_CLK_TCK); /* POSIX.1, POSIX.2 */
|
clock_tick = sysconf(_SC_CLK_TCK); /* POSIX.1, POSIX.2 */
|
||||||
return clock_tick;
|
if (clock_tick == -1)
|
||||||
|
s48_raise_os_error(errno);
|
||||||
|
}
|
||||||
|
return s48_enter_integer(clock_tick);
|
||||||
#else
|
#else
|
||||||
#ifdef CLK_TCK
|
#ifdef CLK_TCK
|
||||||
return CLK_TCK;
|
return s48_enter_integer(CLK_TCK);
|
||||||
#else
|
#else
|
||||||
return 60;
|
return s48_enter_fixnum(60);
|
||||||
#endif
|
#endif
|
||||||
#endif
|
#endif
|
||||||
}
|
}
|
||||||
|
|
||||||
|
s48_value scsh_chmod(s48_value sch_path, s48_value sch_mode)
|
||||||
|
{
|
||||||
|
int retval = chmod (s48_extract_string(sch_path),
|
||||||
|
s48_extract_integer(sch_mode));
|
||||||
|
if (retval == -1)
|
||||||
|
s48_raise_os_error_2(errno, sch_path, sch_mode);
|
||||||
|
return S48_UNSPECIFIC;
|
||||||
|
}
|
||||||
|
|
||||||
|
s48_value scsh_fchmod(s48_value sch_fd, s48_value sch_mode)
|
||||||
|
{
|
||||||
|
int retval = fchmod (s48_extract_fixnum(sch_fd),
|
||||||
|
s48_extract_integer(sch_mode));
|
||||||
|
if (retval == -1)
|
||||||
|
s48_raise_os_error_2(errno, sch_fd, sch_mode);
|
||||||
|
return S48_UNSPECIFIC;
|
||||||
|
}
|
||||||
|
|
||||||
|
s48_value scsh_chown(s48_value sch_path, s48_value sch_uid, s48_value sch_gid)
|
||||||
|
{
|
||||||
|
int retval = chown(s48_extract_string(sch_path),
|
||||||
|
s48_extract_integer(sch_uid),
|
||||||
|
s48_extract_integer(sch_gid));
|
||||||
|
|
||||||
|
if (retval == -1)
|
||||||
|
s48_raise_os_error_3(errno, sch_path, sch_uid, sch_gid);
|
||||||
|
return S48_UNSPECIFIC;
|
||||||
|
}
|
||||||
|
|
||||||
|
s48_value scsh_fchown(s48_value sch_fd, s48_value sch_uid, s48_value sch_gid)
|
||||||
|
{
|
||||||
|
int retval = fchown(s48_extract_fixnum(sch_fd),
|
||||||
|
s48_extract_integer(sch_uid),
|
||||||
|
s48_extract_integer(sch_gid));
|
||||||
|
|
||||||
|
if (retval == -1)
|
||||||
|
s48_raise_os_error_3(errno, sch_fd, sch_uid, sch_gid);
|
||||||
|
return S48_UNSPECIFIC;
|
||||||
|
}
|
||||||
|
|
||||||
|
s48_value scsh_access(s48_value sch_path, s48_value sch_mode)
|
||||||
|
{
|
||||||
|
int retval = access (s48_extract_string(sch_path),
|
||||||
|
s48_extract_integer(sch_mode));
|
||||||
|
if (retval == -1)
|
||||||
|
s48_raise_os_error_2(errno, sch_path, sch_mode);
|
||||||
|
return S48_UNSPECIFIC;
|
||||||
|
}
|
||||||
|
|
||||||
|
s48_value scsh_link(s48_value sch_name1, s48_value sch_name2)
|
||||||
|
{
|
||||||
|
int retval = link (s48_extract_string (sch_name1),
|
||||||
|
s48_extract_string (sch_name2));
|
||||||
|
if (retval == -1)
|
||||||
|
s48_raise_os_error_2(errno, sch_name1, sch_name2);
|
||||||
|
return S48_UNSPECIFIC;
|
||||||
|
}
|
||||||
|
|
||||||
|
s48_value scsh_mkfifo(s48_value sch_path, s48_value sch_mode)
|
||||||
|
{
|
||||||
|
int retval = mkfifo (s48_extract_string (sch_path),
|
||||||
|
s48_extract_fixnum (sch_mode));
|
||||||
|
if (retval == -1)
|
||||||
|
s48_raise_os_error_2(errno, sch_path, sch_mode);
|
||||||
|
return S48_UNSPECIFIC;
|
||||||
|
}
|
||||||
|
|
||||||
|
s48_value scsh_mkdir(s48_value sch_path, s48_value sch_mode)
|
||||||
|
{
|
||||||
|
int retval = mkdir (s48_extract_string (sch_path),
|
||||||
|
s48_extract_fixnum (sch_mode));
|
||||||
|
if (retval == -1)
|
||||||
|
s48_raise_os_error_2(errno, sch_path, sch_mode);
|
||||||
|
return S48_UNSPECIFIC;
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
/* Reading and writing
|
/* Reading and writing
|
||||||
*******************************************************************************
|
*******************************************************************************
|
||||||
*/
|
*/
|
||||||
|
@ -399,7 +508,106 @@ s48_value scheme_fstat(s48_value fd, s48_value vec)
|
||||||
return really_stat (&s, vec);
|
return really_stat (&s, vec);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
s48_value scsh_symlink(s48_value sch_name1, s48_value sch_name2)
|
||||||
|
{
|
||||||
|
int retval = symlink (s48_extract_string (sch_name1),
|
||||||
|
s48_extract_string (sch_name2));
|
||||||
|
if (retval == -1)
|
||||||
|
s48_raise_os_error_2(errno, sch_name1, sch_name2);
|
||||||
|
return S48_UNSPECIFIC;
|
||||||
|
}
|
||||||
|
|
||||||
|
s48_value scsh_truncate(s48_value sch_path, s48_value sch_length)
|
||||||
|
{
|
||||||
|
int retval = truncate (s48_extract_string (sch_path),
|
||||||
|
s48_extract_integer (sch_length));
|
||||||
|
if (retval == -1)
|
||||||
|
s48_raise_os_error_2(errno, sch_path, sch_length);
|
||||||
|
return S48_UNSPECIFIC;
|
||||||
|
}
|
||||||
|
|
||||||
|
s48_value scsh_ftruncate(s48_value sch_fdes, s48_value sch_length)
|
||||||
|
{
|
||||||
|
int retval = ftruncate (s48_extract_fixnum (sch_fdes),
|
||||||
|
s48_extract_integer (sch_length));
|
||||||
|
if (retval == -1)
|
||||||
|
s48_raise_os_error_2(errno, sch_fdes, sch_length);
|
||||||
|
return S48_UNSPECIFIC;
|
||||||
|
}
|
||||||
|
|
||||||
|
s48_value scsh_unlink(s48_value sch_path)
|
||||||
|
{
|
||||||
|
int retval = unlink (s48_extract_string (sch_path));
|
||||||
|
if (retval == -1)
|
||||||
|
s48_raise_os_error_1(errno, sch_path);
|
||||||
|
return S48_UNSPECIFIC;
|
||||||
|
}
|
||||||
|
|
||||||
|
s48_value scsh_fsync(s48_value sch_fdes)
|
||||||
|
{
|
||||||
|
int retval = fsync (s48_extract_fixnum (sch_fdes));
|
||||||
|
if (retval == -1)
|
||||||
|
s48_raise_os_error_1(errno, sch_fdes);
|
||||||
|
return S48_UNSPECIFIC;
|
||||||
|
}
|
||||||
|
|
||||||
|
s48_value scsh_sync()
|
||||||
|
{
|
||||||
|
sync();
|
||||||
|
return S48_UNSPECIFIC;
|
||||||
|
}
|
||||||
|
|
||||||
|
s48_value scsh_close(s48_value sch_fdes)
|
||||||
|
{
|
||||||
|
int retval = close (s48_extract_fixnum (sch_fdes));
|
||||||
|
if (retval == 0)
|
||||||
|
return S48_TRUE;
|
||||||
|
else if (retval == EBADF)
|
||||||
|
return S48_FALSE;
|
||||||
|
else s48_raise_os_error_1 (errno, sch_fdes);
|
||||||
|
}
|
||||||
|
|
||||||
|
s48_value scsh_dup(s48_value sch_fdes)
|
||||||
|
{
|
||||||
|
int retval = dup (s48_extract_fixnum (sch_fdes));
|
||||||
|
if (retval == -1)
|
||||||
|
s48_raise_os_error_1 (errno, sch_fdes);
|
||||||
|
return s48_enter_fixnum (retval);
|
||||||
|
}
|
||||||
|
|
||||||
|
s48_value scsh_dup2(s48_value sch_oldd, s48_value sch_newd)
|
||||||
|
{
|
||||||
|
int retval = dup2 (s48_extract_fixnum (sch_oldd),
|
||||||
|
s48_extract_fixnum (sch_newd));
|
||||||
|
if (retval == -1)
|
||||||
|
s48_raise_os_error_2 (errno, sch_oldd, sch_newd);
|
||||||
|
return s48_enter_fixnum (retval);
|
||||||
|
}
|
||||||
|
|
||||||
|
s48_value scsh_lseek(s48_value sch_fdes, s48_value sch_offset,
|
||||||
|
s48_value sch_whence)
|
||||||
|
{
|
||||||
|
int retval = lseek (s48_extract_fixnum (sch_fdes),
|
||||||
|
s48_extract_integer (sch_offset),
|
||||||
|
s48_extract_fixnum (sch_whence));
|
||||||
|
if (retval == -1)
|
||||||
|
s48_raise_os_error_3 (errno, sch_fdes, sch_offset, sch_whence);
|
||||||
|
return s48_enter_integer (retval);
|
||||||
|
}
|
||||||
|
|
||||||
|
s48_value scsh_open(s48_value sch_path, s48_value sch_flags, s48_value sch_mode)
|
||||||
|
{
|
||||||
|
int retval = open (s48_extract_string (sch_path),
|
||||||
|
s48_extract_fixnum (sch_flags),
|
||||||
|
s48_extract_fixnum (sch_mode));
|
||||||
|
if (retval == -1)
|
||||||
|
s48_raise_os_error_3 (errno, sch_path, sch_flags, sch_mode);
|
||||||
|
|
||||||
|
return s48_enter_fixnum (retval);
|
||||||
|
}
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
/* Supplementary groups access
|
/* Supplementary groups access
|
||||||
*******************************************************************************
|
*******************************************************************************
|
||||||
*/
|
*/
|
||||||
|
@ -487,7 +695,44 @@ s48_value scsh_seteuid(s48_value uid)
|
||||||
s48_raise_os_error_1(errno, uid);
|
s48_raise_os_error_1(errno, uid);
|
||||||
return S48_UNSPECIFIC;
|
return S48_UNSPECIFIC;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
s48_value scsh_getpid()
|
||||||
|
{
|
||||||
|
return s48_enter_integer(getpid());
|
||||||
|
}
|
||||||
|
|
||||||
|
s48_value scsh_getppid()
|
||||||
|
{
|
||||||
|
return s48_enter_integer(getppid());
|
||||||
|
}
|
||||||
|
|
||||||
|
s48_value scsh_getpgrp()
|
||||||
|
{
|
||||||
|
return s48_enter_integer(getpgrp());
|
||||||
|
}
|
||||||
|
|
||||||
|
s48_value scsh_setpgid(s48_value sch_pid, s48_value sch_pgrp)
|
||||||
|
{
|
||||||
|
int retval = setpgid(s48_extract_integer(sch_pid),
|
||||||
|
s48_extract_integer(sch_pgrp));
|
||||||
|
if (retval == -1)
|
||||||
|
s48_raise_os_error_2(errno, sch_pid, sch_pgrp);
|
||||||
|
return S48_UNSPECIFIC;
|
||||||
|
}
|
||||||
|
|
||||||
|
s48_value scsh_setsid()
|
||||||
|
{
|
||||||
|
pid_t retval = setsid();
|
||||||
|
if (retval == -1)
|
||||||
|
s48_raise_os_error(errno);
|
||||||
|
return s48_enter_integer(retval);
|
||||||
|
}
|
||||||
|
|
||||||
|
s48_value scsh_umask(s48_value sch_mask)
|
||||||
|
{
|
||||||
|
return s48_enter_integer(umask(s48_extract_integer(sch_mask)));
|
||||||
|
}
|
||||||
|
|
||||||
/* Environment hackery
|
/* Environment hackery
|
||||||
*******************************************************************************
|
*******************************************************************************
|
||||||
*/
|
*/
|
||||||
|
@ -614,20 +859,21 @@ s48_value scm_gethostname(void)
|
||||||
|
|
||||||
#include <errno.h>
|
#include <errno.h>
|
||||||
|
|
||||||
char *errno_msg(int i)
|
s48_value errno_msg(s48_value sch_i)
|
||||||
{
|
{
|
||||||
|
int i = s48_extract_fixnum (sch_i);
|
||||||
#ifdef HAVE_STRERROR
|
#ifdef HAVE_STRERROR
|
||||||
return(strerror(i));
|
return(s48_enter_string (strerror(i)));
|
||||||
#else
|
#else
|
||||||
/* temp hack until we figure out what to do about losing sys_errlist's */
|
/* temp hack until we figure out what to do about losing sys_errlist's */
|
||||||
extern
|
extern
|
||||||
#ifdef HAVE_CONST_SYS_ERRLIST
|
#ifdef HAVE_CONST_SYS_ERRLIST
|
||||||
const
|
const
|
||||||
#endif
|
#endif
|
||||||
char *sys_errlist[];
|
char *sys_errlist[];
|
||||||
extern int sys_nerr;
|
extern int sys_nerr;
|
||||||
return ( i < 0 || i > sys_nerr ) ? NULL /* i.e., #f */
|
return ( i < 0 || i > sys_nerr ) ? s48_raise_argtype_error(sch_i)
|
||||||
: (char*) sys_errlist[i];
|
: s48_enter_string (sys_errlist[i]);
|
||||||
#endif /* !HAVE_STRERROR */
|
#endif /* !HAVE_STRERROR */
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
|
@ -14,11 +14,38 @@ s48_value scheme_pipe();
|
||||||
|
|
||||||
s48_value scsh_kill (s48_value pid, s48_value signal);
|
s48_value scsh_kill (s48_value pid, s48_value signal);
|
||||||
|
|
||||||
s48_value scm_readlink(s48_value path);
|
s48_value scsh_readlink(s48_value path);
|
||||||
|
|
||||||
int scm_utime(char const *path, time_t ac, time_t mod);
|
s48_value scsh_rename(s48_value sch_from, s48_value sch_to);
|
||||||
|
|
||||||
int scm_utime_now(char const *path);
|
s48_value scsh_rmdir(s48_value sch_path);
|
||||||
|
|
||||||
|
s48_value scsh_symlink(s48_value sch_name1, s48_value name2);
|
||||||
|
|
||||||
|
s48_value scsh_truncate(s48_value sch_path, s48_value sch_length);
|
||||||
|
|
||||||
|
s48_value scsh_ftruncate(s48_value sch_fdes, s48_value sch_length);
|
||||||
|
|
||||||
|
s48_value scsh_unlink(s48_value sch_path);
|
||||||
|
|
||||||
|
s48_value scsh_fsync(s48_value sch_fdes);
|
||||||
|
|
||||||
|
s48_value scsh_sync();
|
||||||
|
|
||||||
|
s48_value scsh_close(s48_value sch_fdes);
|
||||||
|
|
||||||
|
s48_value scsh_dup(s48_value sch_fdes);
|
||||||
|
|
||||||
|
s48_value scsh_dup2(s48_value sch_oldd, s48_value sch_newd);
|
||||||
|
|
||||||
|
s48_value scsh_lseek(s48_value sch_fdes, s48_value sch_offset,
|
||||||
|
s48_value sch_whence);
|
||||||
|
|
||||||
|
s48_value scsh_open(s48_value sch_path, s48_value sch_flags, s48_value sch_mode);
|
||||||
|
|
||||||
|
s48_value scm_utime(s48_value path, s48_value ac, s48_value mod);
|
||||||
|
|
||||||
|
s48_value scm_utime_now(s48_value path);
|
||||||
|
|
||||||
s48_value set_cloexec(s48_value _fd, s48_value _val);
|
s48_value set_cloexec(s48_value _fd, s48_value _val);
|
||||||
|
|
||||||
|
@ -26,10 +53,25 @@ s48_value scsh_chdir(s48_value directory);
|
||||||
|
|
||||||
s48_value scheme_cwd();
|
s48_value scheme_cwd();
|
||||||
|
|
||||||
int process_times(clock_t *utime, clock_t *stime,
|
s48_value process_times();
|
||||||
clock_t *cutime, clock_t *cstime);
|
|
||||||
|
|
||||||
int cpu_clock_ticks_per_sec();
|
s48_value cpu_clock_ticks_per_sec();
|
||||||
|
|
||||||
|
s48_value scsh_chmod(s48_value sch_path, s48_value sch_mode);
|
||||||
|
|
||||||
|
s48_value scsh_fchmod(s48_value sch_fd, s48_value sch_mode);
|
||||||
|
|
||||||
|
s48_value scsh_chown(s48_value sch_path, s48_value sch_uid, s48_value sch_gid);
|
||||||
|
|
||||||
|
s48_value scsh_fchown(s48_value sch_fd, s48_value sch_uid, s48_value sch_gid);
|
||||||
|
|
||||||
|
s48_value scsh_access(s48_value sch_path, s48_value sch_mode);
|
||||||
|
|
||||||
|
s48_value scsh_link(s48_value sch_name1, s48_value name2);
|
||||||
|
|
||||||
|
s48_value scsh_mkfifo(s48_value sch_path, s48_value sch_mode);
|
||||||
|
|
||||||
|
s48_value scsh_mkdir(s48_value sch_path, s48_value sch_mode);
|
||||||
|
|
||||||
s48_value read_fdes_char(int fd);
|
s48_value read_fdes_char(int fd);
|
||||||
|
|
||||||
|
@ -65,6 +107,18 @@ s48_value scsh_setuid(s48_value uid);
|
||||||
|
|
||||||
s48_value scsh_seteuid(s48_value uid);
|
s48_value scsh_seteuid(s48_value uid);
|
||||||
|
|
||||||
|
s48_value scsh_getpid();
|
||||||
|
|
||||||
|
s48_value scsh_getppid();
|
||||||
|
|
||||||
|
s48_value scsh_getpgrp();
|
||||||
|
|
||||||
|
s48_value scsh_setpgid(s48_value sch_pid, s48_value sch_pgrp);
|
||||||
|
|
||||||
|
s48_value scsh_setsid();
|
||||||
|
|
||||||
|
s48_value scsh_umask(s48_value sch_mask);
|
||||||
|
|
||||||
s48_value align_env(s48_value pointer_to_struct);
|
s48_value align_env(s48_value pointer_to_struct);
|
||||||
|
|
||||||
s48_value free_envvec (s48_value pointer_to_struct);
|
s48_value free_envvec (s48_value pointer_to_struct);
|
||||||
|
@ -75,7 +129,7 @@ s48_value create_env(s48_value vec);
|
||||||
|
|
||||||
s48_value scm_gethostname(void);
|
s48_value scm_gethostname(void);
|
||||||
|
|
||||||
char *errno_msg(int i);
|
s48_value errno_msg(s48_value sch_i);
|
||||||
|
|
||||||
s48_value fcntl_read(s48_value fd, s48_value command);
|
s48_value fcntl_read(s48_value fd, s48_value command);
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue