scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Replaced most of define-foreign by 

define-stubless-foreign/define-retrying-syscall in syscalls.scm.
This commit is contained in:
mainzelm 2001-08-08 09:21:20 +00:00
parent 10b97c9e82
commit 327daeed32
8 changed files with 570 additions and 1011 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

146
scsh/dirstuff1.c
View File

@ -7,139 +7,39 @@
#include <dirent.h>
#include <stdlib.h>
#include <string.h>
#include "libcig.h"
#include "scsh_aux.h"
#include <errno.h>
/* 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 */
S48_DECLARE_GC_PROTECT(1);
if( NULL == (d = opendir(dirname)) ) {
fnames = 0; len = 0;
return errno;
}
S48_GC_PROTECT_1(dirlist);
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);
if( NULL == (d = opendir(s48_extract_string (sch_dirname))) )
s48_raise_os_error_1 (errno, sch_dirname);
/* 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;
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);
*fnames = dirvec;
*len = num_entries;
return 0;
dirlist = s48_cons (s48_enter_string (dirent->d_name),
dirlist);
}
if (closedir(d) == -1)
s48_raise_os_error_1 (errno, sch_dirname);
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);
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

4
scsh/dirstuff1.h
View File

@ -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);

42
scsh/filesys.scm
View File

@ -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))

2
scsh/scsh-package.scm
View File

@ -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

627
scsh/syscalls.c
View File

@ -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);
}

358
scsh/syscalls.scm
View File

@ -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-errno-syscall (create-symlink old-name new-name)
; create-symlink/errno)
(define-stubless-foreign create-symlink/eintr (old-name new-name) "scsh_symlink")
(define-retrying-syscall %create-symlink create-symlink/eintr)
;;; "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")

324
scsh/syscalls1.c
View File

@ -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,6 +508,105 @@ 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
*******************************************************************************
@ -488,6 +696,43 @@ s48_value scsh_seteuid(s48_value 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 <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
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 */
}

68
scsh/syscalls1.h
View File

@ -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);