From 327daeed328342685e7f750d4f8e488d66b0af18 Mon Sep 17 00:00:00 2001 From: mainzelm Date: Wed, 8 Aug 2001 09:21:20 +0000 Subject: [PATCH] Replaced most of define-foreign by define-stubless-foreign/define-retrying-syscall in syscalls.scm. --- scsh/dirstuff1.c | 154 ++--------- scsh/dirstuff1.h | 4 +- scsh/filesys.scm | 42 +-- scsh/scsh-package.scm | 2 + scsh/syscalls.c | 627 +++--------------------------------------- scsh/syscalls.scm | 358 +++++++++--------------- scsh/syscalls1.c | 326 +++++++++++++++++++--- scsh/syscalls1.h | 68 ++++- 8 files changed, 570 insertions(+), 1011 deletions(-) diff --git a/scsh/dirstuff1.c b/scsh/dirstuff1.c index 8defc1a..1a3d51b 100644 --- a/scsh/dirstuff1.c +++ b/scsh/dirstuff1.c @@ -7,139 +7,39 @@ #include #include #include - -#include "libcig.h" -#include "scsh_aux.h" +#include /* Make sure our exports match up w/the implementation: */ +#include "scheme48.h" #include "dirstuff1.h" -extern int errno; - -/* 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) +s48_value open_dir(s48_value sch_dirname) { - while(entry) { - scm_dirent_t *next = entry->next; - Free(entry); - entry = next; - } - } + char *fname; + struct dirent *dirent; + DIR *d; + s48_value dirlist = S48_NULL; -/* Returns [err, fnames, len] -** err is 0 for success, otw errno. -** fnames is a vector of strings (filenames), null terminated. -** len is the length of fnames. -*/ -int open_dir(const char *dirname, char ***fnames, int *len) -{ - scm_dirent_t *dep, *entries; - struct dirent *dirent; - char *fname, **dirvec, **vecp; - DIR *d; - int num_entries; - int e; /* errno temp */ - - if( NULL == (d = opendir(dirname)) ) { - fnames = 0; len = 0; - return errno; - } + S48_DECLARE_GC_PROTECT(1); + + S48_GC_PROTECT_1(dirlist); + + if( NULL == (d = opendir(s48_extract_string (sch_dirname))) ) + s48_raise_os_error_1 (errno, sch_dirname); + + while( NULL != (dirent = readdir(d)) ) { + if((strcmp(dirent->d_name,".") == 0) || (strcmp(dirent->d_name,"..") == 0)) + continue; + if( NULL == (fname=copystring(NULL, dirent->d_name)) ) + s48_raise_os_error_1 (errno, sch_dirname); - entries = NULL; num_entries = 0; - while( NULL != (dirent = readdir(d)) ) { - 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); + dirlist = s48_cons (s48_enter_string (dirent->d_name), + dirlist); - /* Load the filenames into a vector and free the structs. */ - if( NULL == (dirvec = Malloc(char *, num_entries+1)) ) - {e=errno; goto lose3;} - for(dep=entries, vecp=dirvec; dep; vecp++) { - scm_dirent_t *next = dep->next; - *vecp = dep->fname; - 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); + } + if (closedir(d) == -1) + s48_raise_os_error_1 (errno, sch_dirname); + + S48_GC_UNPROTECT (); + return dirlist; } - - -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 diff --git a/scsh/dirstuff1.h b/scsh/dirstuff1.h index c27f91b..ef8ee90 100644 --- a/scsh/dirstuff1.h +++ b/scsh/dirstuff1.h @@ -1,4 +1,4 @@ /* Exports from dirstuff1.c. */ -int open_dir(const char *dirname, char ***fnames, int *len); -void scm_sort_filevec(const char **dirvec, int nelts); +s48_value open_dir(s48_value dirname); + diff --git a/scsh/filesys.scm b/scsh/filesys.scm index c9d7127..9a5e565 100644 --- a/scsh/filesys.scm +++ b/scsh/filesys.scm @@ -39,22 +39,24 @@ (let ((query (lambda () (y-or-n? (string-append op-name ": " fname " already exists. Delete"))))) - (let loop ((override? override?)) - ;; MAKEIT returns #f if win, errno if lose. - (cond ((makeit fname) => - (lambda (err) - (if (not (= err errno/exist)) - (errno-error err syscall fname) - - ;; FNAME exists. Nuke it and retry? - (cond ((if (eq? override? 'query) - (query) - override?) - (delete-filesys-object fname) - (loop #t)) - (else - (errno-error err syscall fname)))))))))) - + (let ((result + (let loop ((override? override?)) + (with-errno-handler + ((err data) + ((errno/exist) + (cond ((if (eq? override? 'query) + (query) + override?) + (delete-filesys-object fname) + (loop #t)) + ;;; raising an error here won't work due to S48's + ;;; broken exception system + (else (list err syscall fname))))) + (makeit 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 (cadr rest)))) (create-file-thing dir - (lambda (dir) (create-directory/errno dir perms)) + (lambda (dir) (%create-directory dir perms)) override? "create-directory" create-directory))) @@ -73,7 +75,7 @@ (override? (if (or (null? rest) (null? (cdr rest))) #f (cadr rest)))) (create-file-thing fifo - (lambda (fifo) (create-fifo/errno fifo perms)) + (lambda (fifo) (%create-fifo fifo perms)) override? "create-fifo" create-fifo))) @@ -81,7 +83,7 @@ (define (create-hard-link old-fname new-fname . maybe-override?) (create-file-thing new-fname (lambda (new-fname) - (create-hard-link/errno old-fname new-fname)) + (%create-hard-link old-fname new-fname)) (:optional maybe-override? #f) "create-hard-link" create-hard-link)) @@ -89,7 +91,7 @@ (define (create-symlink old-fname new-fname . maybe-override?) (create-file-thing new-fname (lambda (symlink) - (create-symlink/errno old-fname symlink)) + (%create-symlink old-fname symlink)) (:optional maybe-override? #f) "create-symlink" create-symlink)) diff --git a/scsh/scsh-package.scm b/scsh/scsh-package.scm index 4b5a7c8..9084051 100644 --- a/scsh/scsh-package.scm +++ b/scsh/scsh-package.scm @@ -134,6 +134,7 @@ )) (scsh-level-0-internals (export set-command-line-args! init-scsh-hindbrain + initialize-cwd init-scsh-vars)) ; (scsh-regexp-package scsh-regexp-interface) ) @@ -205,6 +206,7 @@ simple-syntax) (for-syntax (open scsh-syntax-helpers scheme)) (access interrupts + sort command-processor escapes i/o ; S48's force-output diff --git a/scsh/syscalls.c b/scsh/syscalls.c index f8f17fa..90a1b7f 100644 --- a/scsh/syscalls.c +++ b/scsh/syscalls.c @@ -29,491 +29,6 @@ extern int errno; #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) -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) { extern s48_value char_ready_fdes(int ); @@ -530,23 +45,6 @@ s48_value df_char_ready_fdes(s48_value g1) 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) { 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; } -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) { extern s48_value sleep_until(time_t ); @@ -667,23 +127,6 @@ s48_value df_sleep_until(s48_value g1) 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) { S48_EXPORT_FUNCTION(scheme_exec); @@ -702,50 +145,48 @@ void s48_init_syscalls(void) S48_EXPORT_FUNCTION(scsh_geteuid); S48_EXPORT_FUNCTION(scsh_setuid); S48_EXPORT_FUNCTION(scsh_seteuid); - S48_EXPORT_FUNCTION(df_getpid); - S48_EXPORT_FUNCTION(df_getppid); - S48_EXPORT_FUNCTION(df_getpgrp); - S48_EXPORT_FUNCTION(df_setpgid); - S48_EXPORT_FUNCTION(df_setsid); - S48_EXPORT_FUNCTION(df_umask); - S48_EXPORT_FUNCTION(df_process_times); - S48_EXPORT_FUNCTION(df_cpu_clock_ticks_per_sec); - S48_EXPORT_FUNCTION(df_chmod); - S48_EXPORT_FUNCTION(df_fchmod); - S48_EXPORT_FUNCTION(df_chown); - S48_EXPORT_FUNCTION(df_fchown); - S48_EXPORT_FUNCTION(df_access); - S48_EXPORT_FUNCTION(df_link); - S48_EXPORT_FUNCTION(df_mkfifo); - S48_EXPORT_FUNCTION(df_mkdir); - S48_EXPORT_FUNCTION(scm_readlink); - S48_EXPORT_FUNCTION(df_rename); - S48_EXPORT_FUNCTION(df_rmdir); - S48_EXPORT_FUNCTION(df_scm_utime); - S48_EXPORT_FUNCTION(df_scm_utime_now); + S48_EXPORT_FUNCTION(scsh_getpid); + S48_EXPORT_FUNCTION(scsh_getppid); + S48_EXPORT_FUNCTION(scsh_getpgrp); + S48_EXPORT_FUNCTION(setpgid); + S48_EXPORT_FUNCTION(scsh_setsid); + S48_EXPORT_FUNCTION(scsh_umask); + S48_EXPORT_FUNCTION(process_times); + S48_EXPORT_FUNCTION(cpu_clock_ticks_per_sec); + S48_EXPORT_FUNCTION(scsh_chmod); + S48_EXPORT_FUNCTION(scsh_fchmod); + S48_EXPORT_FUNCTION(scsh_chown); + S48_EXPORT_FUNCTION(scsh_fchown); + S48_EXPORT_FUNCTION(scsh_access); + S48_EXPORT_FUNCTION(scsh_link); + S48_EXPORT_FUNCTION(scsh_mkfifo); + S48_EXPORT_FUNCTION(scsh_mkdir); + S48_EXPORT_FUNCTION(scsh_readlink); + S48_EXPORT_FUNCTION(scsh_rename); + S48_EXPORT_FUNCTION(scsh_rmdir); + S48_EXPORT_FUNCTION(scm_utime); + S48_EXPORT_FUNCTION(scm_utime_now); S48_EXPORT_FUNCTION(scheme_stat); S48_EXPORT_FUNCTION(scheme_fstat); - S48_EXPORT_FUNCTION(df_symlink); - S48_EXPORT_FUNCTION(df_truncate); - S48_EXPORT_FUNCTION(df_ftruncate); - S48_EXPORT_FUNCTION(df_unlink); - S48_EXPORT_FUNCTION(df_fsync); - S48_EXPORT_FUNCTION(df_sync); - S48_EXPORT_FUNCTION(df_close); - S48_EXPORT_FUNCTION(df_dup); - S48_EXPORT_FUNCTION(df_dup2); - S48_EXPORT_FUNCTION(df_lseek); + S48_EXPORT_FUNCTION(scsh_symlink); + S48_EXPORT_FUNCTION(scsh_truncate); + S48_EXPORT_FUNCTION(scsh_ftruncate); + S48_EXPORT_FUNCTION(scsh_unlink); + S48_EXPORT_FUNCTION(scsh_fsync); + S48_EXPORT_FUNCTION(scsh_sync); + S48_EXPORT_FUNCTION(scsh_close); + S48_EXPORT_FUNCTION(scsh_dup); + S48_EXPORT_FUNCTION(scsh_dup2); + S48_EXPORT_FUNCTION(scsh_lseek); 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(df_read_fdes_char); S48_EXPORT_FUNCTION(df_write_fdes_char); S48_EXPORT_FUNCTION(df_read_fdes_substring); S48_EXPORT_FUNCTION(df_write_fdes_substring); S48_EXPORT_FUNCTION(scsh_kill); - S48_EXPORT_FUNCTION(df_pause); - S48_EXPORT_FUNCTION(df_open_dir); - S48_EXPORT_FUNCTION(df_scm_sort_filevec); + S48_EXPORT_FUNCTION(open_dir); S48_EXPORT_FUNCTION(scm_envvec); S48_EXPORT_FUNCTION(create_env); S48_EXPORT_FUNCTION(align_env); @@ -755,6 +196,6 @@ void s48_init_syscalls(void) S48_EXPORT_FUNCTION(fcntl_write); S48_EXPORT_FUNCTION(df_sleep_until); S48_EXPORT_FUNCTION(scm_gethostname); - S48_EXPORT_FUNCTION(df_errno_msg); + S48_EXPORT_FUNCTION(errno_msg); S48_EXPORT_FUNCTION(scm_crypt); } diff --git a/scsh/syscalls.scm b/scsh/syscalls.scm index 1817074..ac0faf3 100644 --- a/scsh/syscalls.scm +++ b/scsh/syscalls.scm @@ -79,6 +79,16 @@ ;;; 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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; we can't algin env here, because exec-path/env calls @@ -161,21 +171,17 @@ ;;; PID -(define-foreign pid (getpid) pid_t) -(define-foreign parent-pid (getppid) pid_t) - - +(define-stubless-foreign pid () "scsh_getpid") +(define-stubless-foreign parent-pid () "scsh_getppid") ;;; Process groups and session ids ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-foreign process-group (getpgrp) pid_t) -(define-foreign %set-process-group/errno - (setpgid (pid_t pid) (pid_t groupid)) - (to-scheme fixnum errno_or_false)) +(define-stubless-foreign process-group () "scsh_getpgrp") -(define-errno-syscall (%set-process-group pid pgrp) - %set-process-group/errno) +(define-stubless-foreign %set-process-group/eintr + (pid groupid) "setpgid") +(define-retrying-syscall %set-process-group %set-process-group/eintr) (define (set-process-group arg1 . maybe-arg2) (receive (pid pgrp) (if (null? maybe-arg2) @@ -184,18 +190,12 @@ (%set-process-group pid pgrp))) -(define-foreign become-session-leader/errno (setsid) - (multi-rep (to-scheme pid_t errno_or_false) - pid_t)) - -(define-errno-syscall (become-session-leader) become-session-leader/errno - sid) - +(define-stubless-foreign become-session-leader/eintr () "scsh_setsid") +(define-retrying-syscall become-session-leader become-session-leader/eintr) ;;; UMASK -(define-foreign set-process-umask (umask (mode_t mask)) no-declare ; integer on SunOS - mode_t) +(define-stubless-foreign set-process-umask (mask) "scsh_umask") (define (process-umask) (let ((m (set-process-umask 0))) @@ -208,17 +208,13 @@ ;;; OOPS: The POSIX times() has a mildly useful ret value we are throwing away. -(define-foreign process-times/errno (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-stubless-foreign process-times/eintr-list () "process_times") -(define-errno-syscall (process-times) process-times/errno - utime stime cutime cstime) +(define (process-times) + (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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -231,54 +227,38 @@ (call/fdes thing fd-op))) -(define-foreign set-file-mode/errno - (chmod (string path) (mode_t mode)) no-declare ; integer on SunOS - (to-scheme fixnum errno_or_false)) +(define-stubless-foreign %set-file-mode/eintr (path mode) "scsh_chmod") +(define-retrying-syscall %set-file-mode %set-file-mode/eintr) -; IBM's AIX include files declare fchmod(char*, mode_t). -; Amazing, but true. So we must prevent this def-foreign from issuing -; the conflicting, correct declaration. Hence the NO-DECLARE. +(define-stubless-foreign %set-fdes-mode/eintr (path mode) "scsh_fchmod") +(define-retrying-syscall %set-fdes-mode %set-fdes-mode/eintr) -(define-foreign set-fdes-mode/errno - (fchmod (fixnum fd) (mode_t mode)) ; integer on SunOS - no-declare ; Workaround for AIX bug. - (to-scheme fixnum errno_or_false)) - -(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))))) +(define (set-file-mode thing mode) + (generic-file-op thing + (lambda (fd) (%set-fdes-mode fd mode)) + (lambda (fname) (%set-file-mode fname mode)))) -;;; NO-DECLARE: gcc unistd.h bogusness. -(define-foreign set-file-uid&gid/errno - (chown (string path) (uid_t uid) (gid_t gid)) no-declare - (to-scheme fixnum errno_or_false)) +(define-stubless-foreign set-file-uid&gid/eintr (path uid gid) "scsh_chown") +(define-retrying-syscall set-file-uid&gid set-file-uid&gid/eintr) -(define-foreign set-fdes-uid&gid/errno - (fchown (fixnum fd) (uid_t uid) (gid_t gid)) - (to-scheme fixnum errno_or_false)) +(define-stubless-foreign set-fdes-uid&gid/eintr (fd uid gid) "scsh_fchown") +(define-retrying-syscall set-fdes-uid&gid set-fdes-uid&gid/eintr) -(define-errno-syscall (set-file-owner thing uid) - (lambda (thing uid) - (generic-file-op thing - (lambda (fd) (set-fdes-uid&gid/errno fd uid -1)) - (lambda (fname) (set-file-uid&gid/errno fname uid -1))))) +(define (set-file-owner thing uid) + (generic-file-op thing + (lambda (fd) (set-fdes-uid&gid fd uid -1)) + (lambda (fname) (set-file-uid&gid fname uid -1)))) -(define-errno-syscall (set-file-group thing gid) - (lambda (thing gid) - (generic-file-op thing - (lambda (fd) (set-fdes-uid&gid/errno fd -1 gid)) - (lambda (fname) (set-file-uid&gid/errno fname -1 gid))))) +(define (set-file-group thing gid) + (generic-file-op thing + (lambda (fd) (set-fdes-uid&gid fd -1 gid)) + (lambda (fname) (set-file-uid&gid fname -1 gid)))) ;;; Uses real uid and gid, not effective. I don't use this anywhere. -(define-foreign %file-ruid-access-not? - (access (string path) - (integer perms)) - bool) +(define-stubless-foreign %file-ruid-access-not? (path perms) "scsh_access") ;(define (file-access? path perms) ; (not (%file-access-not? path perms))) @@ -293,80 +273,58 @@ ; (file-access? fname 4)) -(define-foreign create-hard-link/errno - (link (string original-name) (string new-name)) - (to-scheme fixnum errno_or_false)) +(define-stubless-foreign create-hard-link/eintr (original-name new-name) + "scsh_link") +(define-retrying-syscall %create-hard-link create-hard-link/eintr) -(define-errno-syscall (create-hard-link original-name new-name) - create-hard-link/errno) +(define-stubless-foreign create-fifo/eintr (path mode) "scsh_mkfifo") +(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)) - 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) +(define (%create-directory path . maybe-mode) (let ((mode (:optional maybe-mode #o777)) (fname (ensure-file-name-is-nondirectory path))) - (cond ((create-directory/errno fname mode) => - (lambda (err) - (if err (errno-error err create-directory path mode))))))) + (%%create-directory fname 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 - (rename (string old-name) (string new-name)) - (to-scheme fixnum errno_or_false)) - -(define-errno-syscall (%rename-file old-name new-name) - %rename-file/errno) +(define-stubless-foreign %rename-file/eintr (old-name new-name) "scsh_rename") +(define-retrying-syscall %rename-file %rename-file/eintr) -(define-foreign delete-directory/errno - (rmdir (string path)) - (to-scheme fixnum errno_or_false)) +(define-stubless-foreign delete-directory/eintr (path) "scsh_rmdir") +(define-retrying-syscall delete-directory delete-directory/eintr) -(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) - (time_t ac) - (time_t m)) - (to-scheme fixnum errno_or_false)) +;;; (SET-FILE-TIMES path [access-time mod-time]) -(define-foreign %utime-now/errno (scm_utime_now (string path)) - (to-scheme fixnum errno_or_false)) - - -;;; (SET-FILE-TIMES/ERRNO path [access-time mod-time]) - -(define (set-file-times/errno path . maybe-times) +(define (set-file-times path . maybe-times) (if (pair? maybe-times) (let* ((access-time (real->exact-integer (car maybe-times))) (mod-time (if (pair? (cddr maybe-times)) (error "Too many arguments to set-file-times/errno" (cons path maybe-times)) (real->exact-integer (cadr maybe-times))))) - (%utime/errno path access-time + (%utime path access-time mod-time )) - (%utime-now/errno path))) - -(define-errno-syscall (set-file-times . args) set-file-times/errno) - + (%utime-now path))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 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 type @@ -421,90 +379,52 @@ ;;; "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. -(define-foreign create-symlink/errno - (symlink (string old-name) (string new-name)) no-declare - (to-scheme fixnum errno_or_false)) +(define-stubless-foreign create-symlink/eintr (old-name new-name) "scsh_symlink") +(define-retrying-syscall %create-symlink create-symlink/eintr) -;(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 ;;; the PATH arg is "const". It *should* be const. -(define-foreign truncate-file/errno - (truncate (string path) (off_t length)) no-declare - (to-scheme fixnum errno_or_false)) +(define-stubless-foreign %truncate-file/eintr (path length) "scsh_truncate") +(define-retrying-syscall %truncate-file %truncate-file/eintr) -(define-foreign truncate-fdes/errno - (ftruncate (fixnum fd) (off_t length)) no-declare ; Indigo bogosity. - (to-scheme fixnum errno_or_false)) +(define-stubless-foreign %truncate-fdes/eintr (path length) "scsh_ftruncate") +(define-retrying-syscall %truncate-fdes %truncate-fdes/eintr) -(define-errno-syscall (truncate-file path length) - (lambda (thing length) - (generic-file-op thing - (lambda (fd) (truncate-fdes/errno fd length)) - (lambda (fname) (truncate-file/errno fname length))))) +(define (truncate-file thing length) + (generic-file-op thing + (lambda (fd) (%truncate-fdes fd length)) + (lambda (fname) (%truncate-file fname length)))) +(define-stubless-foreign delete-file/eintr (path) "scsh_unlink") +(define-retrying-syscall delete-file delete-file/eintr) -(define-foreign delete-file/errno - (unlink (string path)) - (to-scheme fixnum errno_or_false)) +(define-stubless-foreign %sync-file/eintr (fd) "scsh_fsync") +(define-retrying-syscall %sync-file %sync-file/eintr) -(define-errno-syscall (delete-file path) delete-file/errno) - - -(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))) +(define (sync-file fd/port) + (if (output-port? fd/port) (force-output fd/port)) + (sleazy-call/fdes fd/port %sync-file)) ;;; Amazingly bogus syscall -- doesn't *actually* sync the filesys. -(define-foreign sync-file-system (sync) no-declare ; Linux sux - says int - ignore) - +(define-stubless-foreign sync-file-system () "scsh_sync") ;;; I/O ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-foreign %close-fdes/errno (close (fixnum fd)) - (to-scheme fixnum "errno_or_false")) +(define-stubless-foreign %close-fdes/eintr (fd) "scsh_close") +(define-retrying-syscall %close-fdes %close-fdes/eintr) -(define (%close-fdes fd) - (let lp () - (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-stubless-foreign %dup/eintr (fd) "scsh_dup") +(define-retrying-syscall %dup %dup/eintr) -(define-foreign %dup/errno - (dup (fixnum fd)) - (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-stubless-foreign %dup2/eintr (fd-from fd-to) "scsh_dup2") +(define-retrying-syscall %dup2 %dup2/eintr) -(define-foreign %fd-seek/errno - (lseek (fixnum fd) (off_t offset) (fixnum whence)) - (multi-rep (to-scheme off_t errno_or_false) - off_t)) - +(define-stubless-foreign %fd-seek/eintr (fd offset whence) "scsh_lseek") +(define-retrying-syscall %fd-seek %fd-seek/eintr) (define seek/set 0) ;Unix codes for "whence" @@ -514,13 +434,11 @@ (define (seek fd/port offset . maybe-whence) (let ((whence (:optional maybe-whence seek/set)) (fd (if (integer? fd/port) fd/port (port->fdes fd/port)))) - (receive (err cursor) (%fd-seek/errno fd offset whence) - (if err (errno-error err seek fd offset whence) cursor)))) + (%fd-seek fd offset whence))) (define (tell fd/port) (let ((fd (if (integer? fd/port) fd/port (port->fdes fd/port)))) - (receive (err offset) (%fd-seek/errno fd 0 seek/delta) - (if err (errno-error err tell fd/port) offset)))) + (%fd-seek fd 0 seek/delta))) (define-foreign %char-ready-fdes?/errno (char_ready_fdes (fixnum fd)) @@ -532,16 +450,8 @@ retval))) -(define-foreign %open/errno - (open (string path) - (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-stubless-foreign %open/eintr (path flags mode) "scsh_open") +(define-retrying-syscall %open %open/eintr) (define (open-fdes path flags . maybe-mode) ; mode defaults to 0666 (with-cwd-aligned @@ -549,7 +459,8 @@ (%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) (apply (lambda (r-fd w-fd) @@ -598,7 +509,8 @@ ;;; 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) (signal-pid (cond ((proc? proc) (proc:pid proc)) @@ -622,9 +534,9 @@ ;;; (define-errno-syscall (signal-process-group proc-group signal) ;;; 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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -726,32 +638,31 @@ ;;; Directory stuff ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(define-foreign %open-dir (open_dir (string dir-name)) - (to-scheme integer "False_on_zero") ; Win: #f, lose: errno - (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-stubless-foreign %open-dir/eintr (dir-name) "open_dir") +(define-retrying-syscall %open-dir %open-dir/eintr) (define (directory-files . args) (with-cwd-aligned (let-optionals args ((dir ".") (dotfiles? #f)) (check-arg string? dir directory-files) - (receive (err cvec numfiles) - (%open-dir (ensure-file-name-is-nondirectory dir)) - (if err (errno-error err directory-files dir dotfiles?)) - (%sort-file-vector cvec numfiles) - (let ((files (vector->list (C-string-vec->Scheme&free cvec numfiles)))) - (if dotfiles? files - (filter (lambda (f) (not (char=? (string-ref f 0) #\.))) - files))))))) + (let* ((files (%open-dir (ensure-file-name-is-nondirectory dir))) + (files-sorted ((structure-ref sort sort-list!) files filename<=))) + (if dotfiles? files-sorted + (filter (lambda (f) (not (dotfile? f))) + files-sorted)))))) + +(define (dotfile? f) + (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: ;;; It is used by MATCH-FILES. @@ -833,13 +744,16 @@ ;;; 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() ;;;;;;;;;;;;;;;;;;; -(define-stubless-foreign %fcntl-read (fd command) "fcntl_read") -(define-stubless-foreign %fcntl-write (fd command val) "fcntl_write") +(define-stubless-foreign %fcntl-read/eintr (fd command) "fcntl_read") +(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 ;;; 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)) 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-foreign errno-msg (errno_msg (integer i)) - static-string) +(define-stubless-foreign errno-msg (i) "errno_msg") (define-stubless-foreign %crypt (key salt) "scm_crypt") diff --git a/scsh/syscalls1.c b/scsh/syscalls1.c index 79642ed..2d52e01 100644 --- a/scsh/syscalls1.c +++ b/scsh/syscalls1.c @@ -156,24 +156,24 @@ s48_value scheme_pipe() 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), - s48_extract_fixnum (signal)); - if (ret == -1) - s48_raise_os_error_2(errno, pid, signal); - else return s48_enter_fixnum (ret); + int retval = kill ((pid_t) s48_extract_fixnum (sch_pid), + s48_extract_fixnum (sch_signal)); + if (retval == -1) + s48_raise_os_error_2(errno, sch_pid, sch_signal); + else return s48_enter_fixnum (retval); } /* Read the symlink. */ -s48_value scm_readlink(s48_value path) +s48_value scsh_readlink(s48_value sch_path) { 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) - s48_raise_os_error_1(errno, path); + s48_raise_os_error_1(errno, sch_path); else { 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(). ** 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; - t.actime = ac; - t.modtime = mod; - return utime(path, &t); + int retval; + t.actime = s48_extract_integer (sch_ac); + 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) @@ -214,7 +241,8 @@ s48_value set_cloexec(s48_value _fd, s48_value _val) 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)); if (retval == -1) s48_raise_os_error_1(errno, directory); @@ -270,36 +298,117 @@ s48_value scheme_cwd() ** but cig can't handle it. */ -int process_times(clock_t *utime, clock_t *stime, - clock_t *cutime, clock_t *cstime) +s48_value process_times() { - struct tms tms; - clock_t t = times(&tms); - if (t == -1) return -1; - *utime = tms.tms_utime; - *stime = tms.tms_stime; - *cutime = tms.tms_cutime; - *cstime = tms.tms_cstime; - return t; - } + struct tms tms; + clock_t t = times(&tms); + if (t == -1) s48_raise_os_error(errno); + return + s48_cons(s48_enter_integer (tms.tms_utime), + s48_cons(s48_enter_integer (tms.tms_stime), + s48_cons(s48_enter_integer (tms.tms_cutime), + 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 static long clock_tick = 0; - if (clock_tick == 0) + if (clock_tick == 0){ 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 #ifdef CLK_TCK - return CLK_TCK; + return s48_enter_integer(CLK_TCK); #else - return 60; + return s48_enter_fixnum(60); #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 ******************************************************************************* */ @@ -399,7 +508,106 @@ s48_value scheme_fstat(s48_value fd, s48_value 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 ******************************************************************************* */ @@ -487,7 +695,44 @@ s48_value scsh_seteuid(s48_value uid) s48_raise_os_error_1(errno, uid); 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 ******************************************************************************* */ @@ -614,20 +859,21 @@ s48_value scm_gethostname(void) #include -char *errno_msg(int i) +s48_value errno_msg(s48_value sch_i) { + int i = s48_extract_fixnum (sch_i); #ifdef HAVE_STRERROR - return(strerror(i)); + return(s48_enter_string (strerror(i))); #else /* temp hack until we figure out what to do about losing sys_errlist's */ - extern + extern #ifdef HAVE_CONST_SYS_ERRLIST - const + const #endif - char *sys_errlist[]; - extern int sys_nerr; - return ( i < 0 || i > sys_nerr ) ? NULL /* i.e., #f */ - : (char*) sys_errlist[i]; + char *sys_errlist[]; + extern int sys_nerr; + return ( i < 0 || i > sys_nerr ) ? s48_raise_argtype_error(sch_i) + : s48_enter_string (sys_errlist[i]); #endif /* !HAVE_STRERROR */ } diff --git a/scsh/syscalls1.h b/scsh/syscalls1.h index 302aef4..aec4b08 100644 --- a/scsh/syscalls1.h +++ b/scsh/syscalls1.h @@ -14,11 +14,38 @@ s48_value scheme_pipe(); 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); @@ -26,10 +53,25 @@ s48_value scsh_chdir(s48_value directory); s48_value scheme_cwd(); -int process_times(clock_t *utime, clock_t *stime, - clock_t *cutime, clock_t *cstime); +s48_value process_times(); -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); @@ -65,6 +107,18 @@ s48_value scsh_setuid(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 free_envvec (s48_value pointer_to_struct); @@ -75,7 +129,7 @@ s48_value create_env(s48_value vec); 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);