Replaced many define-foreign by define-stubless-foreign
This commit is contained in:
mainzelm
parent
b3447ad964
commit
2a6d087f0d
|
|
@ -101,36 +101,18 @@
|
|||
(%%exec prog argv env)))
|
||||
|
||||
|
||||
(define-foreign exit/errno ; errno -- misnomer.
|
||||
(exit (fixnum status))
|
||||
ignore)
|
||||
(define-stubless-foreign exit/errno ; errno -- misnomer.
|
||||
(status) "scsh_exit")
|
||||
|
||||
(define-foreign %exit/errno ; errno -- misnomer
|
||||
(_exit (fixnum status))
|
||||
ignore)
|
||||
(status) "scsh__exit")
|
||||
|
||||
(define (%exit . maybe-status)
|
||||
(%exit/errno (:optional maybe-status 0))
|
||||
(error "Yikes! %exit returned."))
|
||||
|
||||
|
||||
(define-foreign %%fork/errno (fork)
|
||||
(multi-rep (to-scheme pid_t errno_or_false)
|
||||
pid_t))
|
||||
|
||||
;;; If the fork fails, and we are doing early zombie reaping, then reap
|
||||
;;; some zombies to try and free up a some space in the process table,
|
||||
;;; and try again.
|
||||
;;;
|
||||
;;; This ugly little hack will have to stay in until I do early
|
||||
;;; zombie reaping with SIGCHLD interrupts.
|
||||
|
||||
(define (%%fork-with-retry/errno)
|
||||
(receive (err pid) (%%fork/errno)
|
||||
(values err pid)))
|
||||
|
||||
(define-errno-syscall (%%fork) %%fork-with-retry/errno
|
||||
pid)
|
||||
(define-stubless-foreign %%fork () "fork")
|
||||
|
||||
;;; Posix waitpid(2) call.
|
||||
(define-stubless-foreign %wait-pid/errno-list (pid options)
|
||||
|
|
@ -372,17 +354,7 @@
|
|||
(lambda (err)
|
||||
(if err (errno-error err create-directory path mode)))))))
|
||||
|
||||
|
||||
(define-foreign read-symlink/errno (scm_readlink (string path))
|
||||
desc
|
||||
desc)
|
||||
|
||||
;(to-scheme string errno_on_zero_or_false) ; NULL => errno, otw #f
|
||||
; static-string))
|
||||
|
||||
(define-errno-syscall (read-symlink path) read-symlink/errno
|
||||
new-path)
|
||||
|
||||
(define-stubless-foreign read-symlink (path) "scm_readlink")
|
||||
|
||||
(define-foreign %rename-file/errno
|
||||
(rename (string old-name) (string new-name))
|
||||
|
|
@ -624,21 +596,16 @@
|
|||
(%open path flags (:optional maybe-mode #o666))))
|
||||
|
||||
|
||||
(define-foreign pipe-fdes/errno (scheme_pipe)
|
||||
(to-scheme fixnum "False_on_zero") ; Win: #f, lose: errno
|
||||
fixnum ; r
|
||||
fixnum) ; w
|
||||
|
||||
(define-errno-syscall (pipe-fdes) pipe-fdes/errno
|
||||
r w)
|
||||
(define-stubless-foreign pipe-fdes () "scheme_pipe")
|
||||
|
||||
(define (pipe)
|
||||
(receive (r-fd w-fd) (pipe-fdes)
|
||||
(apply (pipe-fdes)
|
||||
(lambda (r-fd w-fd)
|
||||
(let ((r (fdes->inport r-fd))
|
||||
(w (fdes->outport w-fd)))
|
||||
(release-port-handle r)
|
||||
(release-port-handle w)
|
||||
(values r w))))
|
||||
(values r w)))))
|
||||
|
||||
(define-foreign %read-fdes-char
|
||||
(read_fdes_char (fixnum fd))
|
||||
|
|
@ -678,11 +645,7 @@
|
|||
;;; Signals (rather incomplete)
|
||||
;;; ---------------------------
|
||||
|
||||
(define-foreign signal-pid/errno
|
||||
(kill (pid_t pid) (fixnum signal))
|
||||
(to-scheme fixnum errno_or_false))
|
||||
|
||||
(define-errno-syscall (signal-pid pid signal) signal-pid/errno)
|
||||
(define-stubless-foreign signal-pid (pid signal) "scsh_kill")
|
||||
|
||||
(define (signal-process proc signal)
|
||||
(signal-pid (cond ((proc? proc) (proc:pid proc))
|
||||
|
|
@ -955,22 +918,13 @@
|
|||
;;; Fd-ports
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-foreign %set-cloexec (set_cloexec (fixnum fd) (bool val))
|
||||
(to-scheme fixnum "errno_or_false"))
|
||||
(define-stubless-foreign %set-cloexec (fd val) "set_cloexec")
|
||||
|
||||
;;; Some of fcntl()
|
||||
;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-foreign %fcntl-read/errno (fcntl_read (fixnum fd) (fixnum command))
|
||||
(multi-rep (to-scheme fixnum errno_or_false)
|
||||
fixnum))
|
||||
|
||||
(define-foreign %fcntl-write/errno
|
||||
(fcntl_write (fixnum fd) (fixnum command) (fixnum val))
|
||||
(to-scheme fixnum errno_or_false))
|
||||
|
||||
(define-errno-syscall (%fcntl-read fd command) %fcntl-read/errno value)
|
||||
(define-errno-syscall (%fcntl-write fd command val) %fcntl-write/errno)
|
||||
(define-stubless-foreign %fcntl-read (fd command) "fcntl_read")
|
||||
(define-stubless-foreign %fcntl-write (fd command val) "fcntl_write")
|
||||
|
||||
;;; 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
|
||||
|
|
@ -1019,16 +973,14 @@
|
|||
(define-foreign %sleep-until (sleep_until (time_t secs))
|
||||
desc)
|
||||
|
||||
(define-foreign %gethostname (scm_gethostname)
|
||||
desc)
|
||||
(define-stubless-foreign %gethostname () "scm_gethostname")
|
||||
|
||||
(define system-name %gethostname)
|
||||
|
||||
(define-foreign errno-msg (errno_msg (integer i))
|
||||
static-string)
|
||||
|
||||
(define-foreign %crypt (scm_crypt (desc key) (desc salt))
|
||||
desc)
|
||||
(define-stubless-foreign %crypt (key salt) "scm_crypt")
|
||||
|
||||
(define (crypt key salt)
|
||||
(let* ((allowed-char-set (rx (| alpha digit "." "/")))
|
||||
|
|
|
|||
|
|
@ -120,43 +120,68 @@ int scheme_exec(const char *prog, s48_value argv, s48_value env)
|
|||
return e;
|
||||
}
|
||||
|
||||
s48_value scsh_exit(s48_value status)
|
||||
{
|
||||
exit(s48_extract_fixnum(status));
|
||||
return S48_FALSE;
|
||||
}
|
||||
|
||||
s48_value scsh__exit(s48_value status)
|
||||
{
|
||||
_exit(s48_extract_fixnum(status));
|
||||
return S48_FALSE;
|
||||
}
|
||||
|
||||
s48_value scsh_fork()
|
||||
{
|
||||
pid_t pid = fork();
|
||||
if (pid == -1)
|
||||
s48_raise_os_error(errno);
|
||||
else return s48_enter_fixnum (pid);
|
||||
}
|
||||
|
||||
/* Random file and I/O stuff
|
||||
*******************************************************************************
|
||||
*/
|
||||
|
||||
/* Returns [errno, r, w] */
|
||||
int scheme_pipe(int *r, int *w)
|
||||
/* Returns (r w) */
|
||||
s48_value scheme_pipe()
|
||||
{
|
||||
int fds[2];
|
||||
if( pipe(fds) ) {
|
||||
*r = 0; *w = 0;
|
||||
return errno;
|
||||
}
|
||||
if(pipe(fds) == -1)
|
||||
s48_raise_os_error(errno);
|
||||
else
|
||||
return s48_cons (s48_enter_fixnum (fds[0]),
|
||||
s48_cons (s48_enter_fixnum (fds [1]),
|
||||
S48_NULL));
|
||||
}
|
||||
|
||||
*r = fds[0]; *w = fds[1];
|
||||
return 0;
|
||||
s48_value scsh_kill (s48_value pid, s48_value signal)
|
||||
{
|
||||
int ret = kill ((pid_t) s48_extract_fixnum (pid),
|
||||
s48_extract_fixnum (signal));
|
||||
if (ret == -1)
|
||||
s48_raise_os_error(errno);
|
||||
else return s48_enter_fixnum (ret);
|
||||
}
|
||||
|
||||
|
||||
/* Read the symlink into static memory. Return NULL on error. */
|
||||
/* Read the symlink. */
|
||||
|
||||
// JMG: static char linkpath[MAXPATHLEN+1]; /* Maybe unaligned. Not reentrant. */
|
||||
|
||||
s48_value scm_readlink(const char *path, s48_value *ret_string)
|
||||
s48_value scm_readlink(s48_value path)
|
||||
{
|
||||
char linkpath[MAXPATHLEN+1];
|
||||
int retval = readlink(path, linkpath, MAXPATHLEN);
|
||||
if (retval != -1){
|
||||
if (retval == -1)
|
||||
s48_raise_os_error(errno);
|
||||
else
|
||||
{
|
||||
linkpath[retval] = '\0';
|
||||
*ret_string = s48_enter_string(linkpath);
|
||||
return S48_FALSE;
|
||||
return s48_enter_string(linkpath);
|
||||
}
|
||||
return s48_enter_fixnum(errno);
|
||||
}
|
||||
|
||||
|
||||
|
||||
/* Scheme interfaces to utime().
|
||||
** Complicated by need to pass real 32-bit quantities.
|
||||
*/
|
||||
|
|
@ -172,18 +197,22 @@ int scm_utime(char const *path, time_t ac, time_t mod)
|
|||
int scm_utime_now(char const *path) {return utime(path, 0);}
|
||||
|
||||
|
||||
int set_cloexec(int fd, int val)
|
||||
s48_value set_cloexec(s48_value _fd, s48_value _val)
|
||||
{
|
||||
int fd = s48_extract_fixnum (_fd);
|
||||
int val = (_val == S48_TRUE) ? 1 : 0;
|
||||
int flags = fcntl(fd, F_GETFD);
|
||||
if( flags == -1 ) return errno;
|
||||
if( flags == -1 ) s48_raise_os_error(errno);
|
||||
val = -val; /* 0 -> 0 and 1 -> -1 */
|
||||
|
||||
/* If it's already what we want, just return. */
|
||||
if( (flags & FD_CLOEXEC) == (FD_CLOEXEC & val) ) return 0;
|
||||
if( (flags & FD_CLOEXEC) == (FD_CLOEXEC & val) ) return S48_FALSE;
|
||||
|
||||
flags = (flags & ~FD_CLOEXEC) | (val & FD_CLOEXEC);
|
||||
return fcntl(fd, F_SETFD, flags) ? errno : 0;
|
||||
}
|
||||
if (fcntl(fd, F_SETFD, flags) == -1)
|
||||
s48_raise_os_error(errno);
|
||||
else return S48_FALSE;
|
||||
}
|
||||
|
||||
|
||||
/* Two versions of CWD
|
||||
|
|
@ -661,12 +690,25 @@ char *errno_msg(int i)
|
|||
******************
|
||||
*/
|
||||
|
||||
int fcntl_read(int fd, int command)
|
||||
{ return fcntl(fd, command); }
|
||||
s48_value fcntl_read(s48_value fd, s48_value command)
|
||||
{
|
||||
int ret = fcntl(s48_extract_fixnum (fd),
|
||||
s48_extract_integer (command));
|
||||
if (ret == -1)
|
||||
s48_raise_os_error(errno);
|
||||
else return s48_enter_fixnum (ret);
|
||||
}
|
||||
|
||||
|
||||
int fcntl_write(int fd, int command, int value)
|
||||
{ return fcntl(fd, command, value); }
|
||||
s48_value fcntl_write(s48_value fd, s48_value command, s48_value value)
|
||||
{
|
||||
int ret = fcntl(s48_extract_fixnum (fd),
|
||||
s48_extract_integer (command),
|
||||
s48_extract_integer (value));
|
||||
if (ret == -1)
|
||||
s48_raise_os_error(errno);
|
||||
else return s48_enter_fixnum (ret);
|
||||
}
|
||||
|
||||
/* crypt()
|
||||
******************
|
||||
|
|
|
|||
|
|
@ -4,7 +4,15 @@ s48_value wait_pid(s48_value pid, s48_value flags);
|
|||
|
||||
int scheme_exec(const char *prog, s48_value argv, s48_value env);
|
||||
|
||||
int scheme_pipe(int *r, int *w);
|
||||
s48_value scsh_exit (s48_value status);
|
||||
|
||||
s48_value scsh__exit (s48_value status);
|
||||
|
||||
s48_value scsh_fork ();
|
||||
|
||||
s48_value scheme_pipe();
|
||||
|
||||
s48_value scsh_kill (s48_value pid, s48_value signal);
|
||||
|
||||
s48_value scm_readlink(const char *path, s48_value*);
|
||||
|
||||
|
|
@ -51,8 +59,8 @@ s48_value scm_gethostname(void);
|
|||
|
||||
char *errno_msg(int i);
|
||||
|
||||
int fcntl_read(int fd, int command);
|
||||
s48_value fcntl_read(s48_value fd, s48_value command);
|
||||
|
||||
int fcntl_write(int fd, int command, int value);
|
||||
s48_value fcntl_write(s48_value fd, s48_value command, s48_value value);
|
||||
|
||||
s48_value scm_crypt(s48_value key, s48_value salt);
|
||||
|
|
|
|||
Loading…
Reference in New Issue