New signal-handler code.
This commit is contained in:
shivers
parent
509fb5c6d1
commit
84c705fcc7
|
|
@ -196,7 +196,7 @@
|
|||
(string-desc name)) ; scheme descriptor
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define-simple-errno-syscall (%bind sockfd family name) %bind/errno)
|
||||
(define-errno-syscall (%bind sockfd family name) %bind/errno)
|
||||
|
||||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
;;; connect syscall
|
||||
|
|
@ -223,7 +223,7 @@
|
|||
(desc name)) ; scheme descriptor
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define-simple-errno-syscall (%connect sockfd family name) %connect/errno)
|
||||
(define-errno-syscall (%connect sockfd family name) %connect/errno)
|
||||
|
||||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
;;; listen syscall
|
||||
|
|
@ -241,7 +241,7 @@
|
|||
(integer backlog)) ; backlog
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define-simple-errno-syscall (%listen sockfd backlog) %listen/errno)
|
||||
(define-errno-syscall (%listen sockfd backlog) %listen/errno)
|
||||
|
||||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
;;; accept syscall
|
||||
|
|
@ -288,7 +288,7 @@
|
|||
(string-desc name))
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define-simple-errno-syscall (%peer-name sock family name) %peer-name/errno)
|
||||
(define-errno-syscall (%peer-name sock family name) %peer-name/errno)
|
||||
|
||||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
;;; getsockname syscall
|
||||
|
|
@ -310,7 +310,7 @@
|
|||
(string-desc name))
|
||||
(to-scheme integer "False_on_zero"))
|
||||
|
||||
(define-simple-errno-syscall
|
||||
(define-errno-syscall
|
||||
(%socket-name sock family name) %socket-name/errno)
|
||||
|
||||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
|
|
@ -329,7 +329,7 @@
|
|||
(integer how))
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define-simple-errno-syscall
|
||||
(define-errno-syscall
|
||||
(%shutdown sock how) %shutdown/errno)
|
||||
|
||||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
|
|
@ -667,7 +667,7 @@
|
|||
(integer optval))
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define-simple-errno-syscall
|
||||
(define-errno-syscall
|
||||
(%setsockopt sock level option value) %setsockopt/errno)
|
||||
|
||||
|
||||
|
|
@ -679,7 +679,7 @@
|
|||
(integer time))
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define-simple-errno-syscall
|
||||
(define-errno-syscall
|
||||
(%setsockopt-linger sock level option on-off time) %setsockopt-linger/errno)
|
||||
|
||||
(define-foreign %setsockopt-timeout/errno
|
||||
|
|
@ -690,7 +690,7 @@
|
|||
(integer usecs))
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define-simple-errno-syscall
|
||||
(define-errno-syscall
|
||||
(%setsockopt-timeout sock level option secs usecs) %setsockopt-timeout/errno)
|
||||
|
||||
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
|
||||
|
|
|
|||
|
|
@ -0,0 +1,91 @@
|
|||
/* This is an Scheme48/C interface file,
|
||||
** automatically generated by cig.
|
||||
*/
|
||||
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h> /* For malloc. */
|
||||
#include "libcig.h"
|
||||
|
||||
extern int errno;
|
||||
|
||||
/* Make sure foreign-function stubs interface to the C funs correctly: */
|
||||
#include "sighandlers1.h"
|
||||
|
||||
scheme_value df_set_procmask(long nargs, scheme_value *args)
|
||||
{
|
||||
extern int set_procmask(int , int , int *);
|
||||
scheme_value ret1;
|
||||
int r1;
|
||||
int r2;
|
||||
|
||||
cig_check_nargs(3, nargs, "set_procmask");
|
||||
r1 = set_procmask(EXTRACT_FIXNUM(args[2]), EXTRACT_FIXNUM(args[1]), &r2);
|
||||
ret1 = ENTER_FIXNUM(r1);
|
||||
VECTOR_REF(*args,0) = ENTER_FIXNUM(r2);
|
||||
return ret1;
|
||||
}
|
||||
|
||||
scheme_value df_get_procmask(long nargs, scheme_value *args)
|
||||
{
|
||||
extern int get_procmask(int *);
|
||||
scheme_value ret1;
|
||||
int r1;
|
||||
int r2;
|
||||
|
||||
cig_check_nargs(1, nargs, "get_procmask");
|
||||
r1 = get_procmask(&r2);
|
||||
ret1 = ENTER_FIXNUM(r1);
|
||||
VECTOR_REF(*args,0) = ENTER_FIXNUM(r2);
|
||||
return ret1;
|
||||
}
|
||||
|
||||
scheme_value df_do_default_sigaction(long nargs, scheme_value *args)
|
||||
{
|
||||
extern void do_default_sigaction(int );
|
||||
|
||||
cig_check_nargs(1, nargs, "do_default_sigaction");
|
||||
do_default_sigaction(EXTRACT_FIXNUM(args[0]));
|
||||
return SCHFALSE;
|
||||
}
|
||||
|
||||
scheme_value df_set_sig_handler(long nargs, scheme_value *args)
|
||||
{
|
||||
extern scheme_value set_sig_handler(int , scheme_value , int , scheme_value *, int *);
|
||||
scheme_value ret1;
|
||||
scheme_value r1;
|
||||
scheme_value r2;
|
||||
int r3;
|
||||
|
||||
cig_check_nargs(4, nargs, "set_sig_handler");
|
||||
r1 = set_sig_handler(EXTRACT_FIXNUM(args[3]), args[2], EXTRACT_FIXNUM(args[1]), &r2, &r3);
|
||||
ret1 = r1;
|
||||
VECTOR_REF(*args,0) = r2;
|
||||
VECTOR_REF(*args,1) = ENTER_FIXNUM(r3);
|
||||
return ret1;
|
||||
}
|
||||
|
||||
scheme_value df_get_sig_handler(long nargs, scheme_value *args)
|
||||
{
|
||||
extern scheme_value get_sig_handler(int , scheme_value *, int *);
|
||||
scheme_value ret1;
|
||||
scheme_value r1;
|
||||
scheme_value r2;
|
||||
int r3;
|
||||
|
||||
cig_check_nargs(2, nargs, "get_sig_handler");
|
||||
r1 = get_sig_handler(EXTRACT_FIXNUM(args[1]), &r2, &r3);
|
||||
ret1 = r1;
|
||||
VECTOR_REF(*args,0) = r2;
|
||||
VECTOR_REF(*args,1) = ENTER_FIXNUM(r3);
|
||||
return ret1;
|
||||
}
|
||||
|
||||
scheme_value df_install_new_handler_vector(long nargs, scheme_value *args)
|
||||
{
|
||||
extern void install_new_handler_vector(scheme_value );
|
||||
|
||||
cig_check_nargs(1, nargs, "install_new_handler_vector");
|
||||
install_new_handler_vector(args[0]);
|
||||
return SCHFALSE;
|
||||
}
|
||||
|
||||
|
|
@ -0,0 +1,142 @@
|
|||
;;; Copyright (c) 1993 by Olin Shivers.
|
||||
;;; Signal handler system
|
||||
|
||||
;;; The principal trickiness here is that we have to interface to Unix signals
|
||||
;;; *through* an intermediate interface, the S48 vm's idea of interrupts.
|
||||
;;; So there is a difference between delivering a signal to the underlying
|
||||
;;; Unix process and delivering it to the program that runs on the VM.
|
||||
|
||||
;;; These system calls can return EINTR or restart. In order for the S48 vm's
|
||||
;;; interrupt system to detect a signal and invoke the handler, they *must*
|
||||
;;; return EINTR, and this must cause a return from C to Scheme.
|
||||
;;;
|
||||
;;; open close dup2 accept connect
|
||||
;;; read recv recvfrom recvmsg
|
||||
;;; write send sendto sendmsg
|
||||
;;; select
|
||||
;;; wait
|
||||
;;; fcntl* ioctl
|
||||
;;; sigsuspend
|
||||
;;; HP-UX, but I don't use: poll lockf msem_lock msgsnd msgrcv semop
|
||||
;;;
|
||||
;;; * Only during a F_SETLKW
|
||||
|
||||
(foreign-source
|
||||
"extern int errno;"
|
||||
""
|
||||
"/* Make sure foreign-function stubs interface to the C funs correctly: */"
|
||||
"#include \"sighandlers1.h\""
|
||||
"" "")
|
||||
|
||||
;;; Blocking interrupts
|
||||
;;; I think all of this code (and associated C code) has been obsoleted by
|
||||
;;; the new system that uses S48's sigblocking machinery.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define (interrupt-set . interrupts)
|
||||
(let lp ((ints interrupts) (ans 0))
|
||||
(if (pair? ints)
|
||||
(lp (cdr ints) (bitwise-ior ans (arithmetic-shift 1 (- (car ints) 1))))
|
||||
ans)))
|
||||
|
||||
(define-simple-syntax (with-blocked-interrupts mask body ...)
|
||||
(with-blocked-interrupts* mask (lambda () body ...)))
|
||||
|
||||
(define (with-blocked-interrupts* mask thunk)
|
||||
(let ((old-mask #f))
|
||||
(dynamic-wind
|
||||
(lambda () (set! old-mask (set-blocked-interrupts! mask)))
|
||||
thunk
|
||||
(lambda () (set-blocked-interrupts! old-mask)))))
|
||||
|
||||
(define (set-blocked-interrupts! mask)
|
||||
(receive (hi-out lo-out)
|
||||
(%set-blocked-interrupts! (hi8 mask) (lo24 mask))
|
||||
(compose-8/24 hi-out lo-out)))
|
||||
|
||||
|
||||
(define (blocked-interrupts)
|
||||
(call-with-values %blocked-interrupts compose-8/24))
|
||||
|
||||
(define-foreign %set-blocked-interrupts! (set_procmask (fixnum hi)
|
||||
(fixnum lo))
|
||||
fixnum ; hi
|
||||
fixnum) ; lo
|
||||
|
||||
(define-foreign %blocked-interrupts (get_procmask)
|
||||
fixnum ; hi
|
||||
fixnum) ; lo
|
||||
|
||||
|
||||
;;; Get/Set signal handlers
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;; When you set a signal's handler to "default," if the default for that
|
||||
;;; signal is something other than "ignore," we actually install this guy.
|
||||
;;; When he is called by the S48 interrupt system, he'll magically make
|
||||
;;; the default action happen (by calling C code that *really* sets the
|
||||
;;; handler to SIGDFL, and then re-sending the signal). This basically
|
||||
;;; terminates the process, since if the default isn't "ignore," it's always
|
||||
;;; "terminate" of some kind. Doing it this way means the exit code given
|
||||
;;; to our waiting parent proc correctly reflects how we died, and also
|
||||
;;; makes the core dump happen if it should. Details, details.
|
||||
|
||||
(define (default-handler sig)
|
||||
(lambda (enabled-interrupts) (%do-default-sigaction sig)))
|
||||
|
||||
(define-foreign %do-default-sigaction (do_default_sigaction (fixnum signal))
|
||||
ignore)
|
||||
|
||||
|
||||
;;; HANDLER is #f (ignore), #t (default), or an integer procedure.
|
||||
;;; The interrupt is delivered to a procedure by (1) setting the
|
||||
;;; ENABLED-INTERRUPTS register to 0 (i.e., blocking all interrupts),
|
||||
;;; and (2) applying the procedure to the previous value of the
|
||||
;;; ENABLED-INTERRUPTS register. If the procedure returns normally
|
||||
;;; (i.e., it doesn't throw to a continuation), the ENABLED-INTERRUPTS
|
||||
;;; register will be restored to its previous value.
|
||||
|
||||
;;; Should have extra args, MASK & FLAGS.
|
||||
(define (set-signal-handler sig handler)
|
||||
(let ((handler (if (eq? handler #t) ; Hack the default handler.
|
||||
(default-handler sig)
|
||||
handler)))
|
||||
(receive (handler flags) ; Should be (handler mask flags).
|
||||
(%set-signal-handler! sig handler 0)
|
||||
handler)))
|
||||
|
||||
(define (signal-handler sig)
|
||||
(receive (handler flags) (%signal-handler sig)
|
||||
handler))
|
||||
|
||||
(define (%signal-handler sig)
|
||||
(receive (err handler flags) (%%signal-handler sig)
|
||||
(if err (errno-error err %signal-handler sig)
|
||||
(values handler flags))))
|
||||
|
||||
;;; (%set-signal-handler! sig handler [mask flags]) -> [handler mask flags]
|
||||
;;; Except no MASK for now.
|
||||
|
||||
(define (%set-signal-handler! sig handler . args)
|
||||
(let-optionals args ((flags 0))
|
||||
(receive (err handler flags)
|
||||
(%%set-signal-handler! sig handler flags)
|
||||
(if err
|
||||
(errno-error err %set-signal-handler! sig handler flags)
|
||||
(values handler flags)))))
|
||||
|
||||
(define-foreign %%set-signal-handler! (set_sig_handler (fixnum signal)
|
||||
(desc handler)
|
||||
(fixnum flags))
|
||||
desc ; #f or errno
|
||||
desc ; handler
|
||||
fixnum) ; flags
|
||||
|
||||
(define-foreign %%signal-handler (get_sig_handler (fixnum signal))
|
||||
desc ; #f or errno
|
||||
desc ; handler
|
||||
fixnum) ; flags
|
||||
|
||||
(define-foreign %%install-new-handler-vec
|
||||
(install_new_handler_vector (vector-desc vec))
|
||||
ignore)
|
||||
|
|
@ -0,0 +1,292 @@
|
|||
/* Need to define sig2interrupt vector.
|
||||
** Interrupt-system mutators should probably hold interrupts while they
|
||||
** operate.
|
||||
*/
|
||||
|
||||
#include <unistd.h>
|
||||
#include <sys/types.h>
|
||||
#include <signal.h>
|
||||
#include "cstuff.h"
|
||||
|
||||
/* Make sure our exports match up w/the implementation: */
|
||||
#include "sighandlers1.h"
|
||||
|
||||
extern int errno;
|
||||
|
||||
extern scheme_value Spending_interruptsS, Sinterrupt_handlersS;
|
||||
|
||||
/* Translate Unix signal numbers to S48 interrupt numbers.
|
||||
** alarm, keyboard (^C, SIGINT), and memory shortage are 0, 1, and 2.
|
||||
*/
|
||||
|
||||
static int sig2interrupt(int signal)
|
||||
{
|
||||
switch (signal) {
|
||||
case SIGALRM: return 0; /* Already defined by S48. */
|
||||
case SIGCHLD: return 3;
|
||||
case SIGCONT: return 4;
|
||||
case SIGHUP: return 5;
|
||||
case SIGINT: return 1; /* Already defined by S48. */
|
||||
case SIGQUIT: return 6;
|
||||
case SIGTERM: return 7;
|
||||
case SIGTSTP: return 8;
|
||||
case SIGUSR1: return 9;
|
||||
case SIGUSR2: return 10;
|
||||
|
||||
#ifdef SIGINFO
|
||||
case SIGINFO: return 11;
|
||||
#endif
|
||||
#ifdef SIGIO
|
||||
case SIGIO: return 12;
|
||||
#endif
|
||||
#ifdef SIGPOLL
|
||||
case SIGPOLL: return 13;
|
||||
#endif
|
||||
#ifdef SIGPROF
|
||||
case SIGPROF: return 14;
|
||||
#endif
|
||||
#ifdef SIGPWR
|
||||
case SIGPWR: return 15;
|
||||
#endif
|
||||
#ifdef SIGURG
|
||||
case SIGURG: return 16;
|
||||
#endif
|
||||
#ifdef SIGVTALRM
|
||||
case SIGVTALRM: return 17;
|
||||
#endif
|
||||
#ifdef SIGWINCH
|
||||
case SIGWINCH: return 18;
|
||||
#endif
|
||||
#ifdef SIGXCPU
|
||||
case SIGXCPU: return 19;
|
||||
#endif
|
||||
#ifdef SIGXFSZ
|
||||
case SIGXFSZ: return 20;
|
||||
#endif
|
||||
default: return -1;
|
||||
}
|
||||
}
|
||||
|
||||
/* Hack the blocked-signal mask.
|
||||
*******************************************************************************
|
||||
*/
|
||||
|
||||
|
||||
#include "machine/sigset.h"
|
||||
|
||||
int set_procmask(int hi, int lo, int *old_lo_p)
|
||||
{
|
||||
sigset_t mask, old_mask;
|
||||
int old_hi;
|
||||
|
||||
make_sigset(&mask, hi, lo);
|
||||
|
||||
sigprocmask(SIG_SETMASK, &mask, &old_mask);
|
||||
split_sigset(old_mask, &old_hi, old_lo_p);
|
||||
return old_hi;
|
||||
}
|
||||
|
||||
|
||||
int get_procmask(int *old_lo_p)
|
||||
{
|
||||
sigset_t old_mask;
|
||||
int old_hi;
|
||||
|
||||
sigprocmask(SIG_SETMASK, NULL, &old_mask);
|
||||
split_sigset(old_mask, &old_hi, old_lo_p);
|
||||
return old_hi;
|
||||
}
|
||||
|
||||
|
||||
/* Set/Get signal handlers
|
||||
*******************************************************************************
|
||||
*/
|
||||
|
||||
static void scm_handle_sig(int sig)
|
||||
{
|
||||
Spending_interruptsS |= (1<<sig2interrupt(sig));
|
||||
}
|
||||
|
||||
|
||||
scheme_value set_sig_handler(int sig, scheme_value handler, int flags,
|
||||
scheme_value *ohandler, int *oflags)
|
||||
{
|
||||
struct sigaction new, old;
|
||||
int intnum = sig2interrupt(sig);
|
||||
scheme_value old_scsh_handler;
|
||||
|
||||
/* intnum in range? */
|
||||
if( intnum >= VECTOR_LENGTH(Sinterrupt_handlersS) ) {
|
||||
*ohandler = SCHFALSE;
|
||||
return ENTER_FIXNUM(-1);
|
||||
}
|
||||
|
||||
/* We may need this for ohandler later, but it may get clobbered when
|
||||
** when we set the new handler, so stash it away for now.
|
||||
*/
|
||||
old_scsh_handler = VECTOR_REF(Sinterrupt_handlersS, intnum);
|
||||
|
||||
sigemptyset(&new.sa_mask); /* WTF */
|
||||
new.sa_flags = flags;
|
||||
|
||||
if( handler == SCHFALSE ) {
|
||||
new.sa_handler = SIG_IGN;
|
||||
VECTOR_REF(Sinterrupt_handlersS, intnum) = SCHFALSE;
|
||||
}
|
||||
|
||||
/* This *really* sets the Unix signal handler to SIG_DFL.
|
||||
** What usually happens isn't this -- what usually happens is that
|
||||
** we establish a special Scheme handler that does the default, so
|
||||
** that it is subject to S48's blocking machinery.
|
||||
*/
|
||||
else if( handler == SCHTRUE ) {
|
||||
new.sa_handler = SIG_DFL;
|
||||
VECTOR_REF(Sinterrupt_handlersS, intnum) = SCHFALSE;
|
||||
}
|
||||
|
||||
else {
|
||||
new.sa_handler = scm_handle_sig;
|
||||
|
||||
VECTOR_REF(Sinterrupt_handlersS, intnum) = handler;
|
||||
/* Do other stuff. */
|
||||
}
|
||||
|
||||
if( sigaction(sig, &new, &old) ) {
|
||||
*ohandler = SCHFALSE;
|
||||
return ENTER_FIXNUM(errno);
|
||||
}
|
||||
|
||||
*oflags = old.sa_flags;
|
||||
if( old.sa_handler == SIG_IGN ) *ohandler = SCHFALSE;
|
||||
else if( old.sa_handler == SIG_DFL ) *ohandler = SCHTRUE;
|
||||
else if( old.sa_handler == scm_handle_sig ) *ohandler = old_scsh_handler;
|
||||
else *ohandler = ENTER_FIXNUM(-1); /* Unknown signal handler. */
|
||||
return SCHFALSE;
|
||||
}
|
||||
|
||||
|
||||
scheme_value get_sig_handler(int signal, scheme_value *handler, int *flags)
|
||||
{
|
||||
struct sigaction old;
|
||||
|
||||
if( sigaction(signal, NULL, &old) ) {
|
||||
*handler = SCHFALSE;
|
||||
return ENTER_FIXNUM(errno);
|
||||
}
|
||||
|
||||
*flags = old.sa_flags;
|
||||
|
||||
if( old.sa_handler == SIG_IGN ) *handler = SCHFALSE;
|
||||
|
||||
else if( old.sa_handler == SIG_DFL ) *handler = SCHTRUE;
|
||||
|
||||
else if( old.sa_handler == scm_handle_sig ) {
|
||||
int intnum = sig2interrupt(signal);
|
||||
|
||||
/* intnum in range? */
|
||||
if( intnum >= VECTOR_LENGTH(Sinterrupt_handlersS) ) {
|
||||
*handler = SCHFALSE;
|
||||
return ENTER_FIXNUM(-1);
|
||||
}
|
||||
|
||||
*handler = VECTOR_REF(Sinterrupt_handlersS, intnum);
|
||||
}
|
||||
|
||||
else *handler = ENTER_FIXNUM(-1); /* Unknown signal handler. */
|
||||
|
||||
return SCHFALSE;
|
||||
}
|
||||
|
||||
|
||||
/* Return true if SIGNAL's default action is definitely to be ignored. */
|
||||
/* This should be inlined by a good compiler. */
|
||||
|
||||
static int sig_def_is_ignored(int signal)
|
||||
{
|
||||
return
|
||||
/* Posix signals */
|
||||
signal == SIGALRM || signal == SIGHUP ||
|
||||
signal == SIGINT || signal == SIGQUIT ||
|
||||
signal == SIGTERM || signal == SIGUSR1 ||
|
||||
signal == SIGUSR2
|
||||
|
||||
/* Non-Posix signals, when present. */
|
||||
#ifdef SIGINFO
|
||||
|| signal == SIGINFO
|
||||
#endif
|
||||
#ifdef SIGPOLL
|
||||
|| signal == SIGPOLL
|
||||
#endif
|
||||
#ifdef SIGPROF
|
||||
|| signal == SIGPROF
|
||||
#endif
|
||||
#ifdef SIGVTALRM
|
||||
|| signal == SIGVTALRM
|
||||
#endif
|
||||
#ifdef SIGXCPU
|
||||
|| signal == SIGXCPU
|
||||
#endif
|
||||
#ifdef SIGXFSZ
|
||||
|| signal == SIGXFSZ
|
||||
#endif
|
||||
#ifdef SIGIO
|
||||
|| signal == SIGIO /* BSD => ignore; SVR4 => terminate */
|
||||
#endif
|
||||
;
|
||||
}
|
||||
|
||||
|
||||
/* This guy is responsible for making the default action for a
|
||||
** Unix signal happen. Because S48's signal handler system is
|
||||
** interposed between delivery-to-the-process and
|
||||
** delivery-to-the-scheme-handler, when the user sets a signal
|
||||
** handler to default, we install a Scheme proc that calls this
|
||||
** guy, instead of just slapping a SIGDFL in as the Unix handler.
|
||||
** We only have to do this for signals whose default isn't "ignore," i.e.:
|
||||
** Posix: SIGALRM SIGHUP SIGINT SIGQUIT SIGTERM SIGUSR1 SIGUSR2
|
||||
** Non-Posix: SIGINFO SIGPOLL SIGPROF SIGVTALRM SIGXCPU SIGXFSZ SIGIO
|
||||
** This way, the S48 signal-blocking mechanism can work.
|
||||
**
|
||||
** Weird, I know.
|
||||
*/
|
||||
void do_default_sigaction(int signal)
|
||||
{
|
||||
sigset_t ss, old_ss;
|
||||
struct sigaction default_action, old_action;
|
||||
|
||||
if( !sig_def_is_ignored(signal) ) {
|
||||
|
||||
/* OK -- signal's default *isn't* "ignore," so we have to do it. */
|
||||
sigfillset(&ss); /* Block everyone. */
|
||||
sigprocmask(SIG_SETMASK, &ss, &old_ss);
|
||||
|
||||
default_action.sa_handler = SIG_DFL; /* Set for default. */
|
||||
sigemptyset(&default_action.sa_mask);
|
||||
default_action.sa_flags = 0;
|
||||
sigaction(signal, &default_action, &old_action);
|
||||
|
||||
raise(signal); /* Raise the signal. */
|
||||
sigdelset(&ss, signal);
|
||||
sigprocmask(SIG_SETMASK, &ss, 0); /* Handle it. */
|
||||
|
||||
/* Most likely, we'll never get to here, as the default for
|
||||
** the signals we're handling is "terminate," but we'll play it safe.
|
||||
*/
|
||||
sigaction(signal, &old_action, 0); /* Restore old handler, */
|
||||
sigprocmask(SIG_SETMASK, &old_ss, 0); /* and mask. */
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
/* Install a new signal-handler vector.
|
||||
** I use this because the default one is only 3 entries long, and I
|
||||
** don't want to modify the S48 source. So I'll just install my own
|
||||
** at run-time.
|
||||
** It's not a hack, it's a kluge.
|
||||
*/
|
||||
|
||||
void install_new_handler_vector(scheme_value handlers)
|
||||
{
|
||||
extern scheme_value Sinterrupt_handlersS;
|
||||
Sinterrupt_handlersS = handlers;
|
||||
}
|
||||
|
|
@ -30,62 +30,41 @@
|
|||
"#define False_on_zero(x) ((x) ? ENTER_FIXNUM(x) : SCHFALSE)" ; Not a function.
|
||||
"" "")
|
||||
|
||||
;;; Macros for converting syscalls that return error codes to ones that
|
||||
;;; Macro for converting syscalls that return error codes to ones that
|
||||
;;; raise exceptions on errors.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;; DEFINE-ERRNO-SYSCALL defines an error-signalling syscall procedure from
|
||||
;;; one that returns an error code as its first return value -- #f for win,
|
||||
;;; errno for lose.
|
||||
;;; errno for lose. If the error code is ERRNO/INTR (interrupted syscall),
|
||||
;;; we try again.
|
||||
;;;
|
||||
;;; (define-errno-syscall (SYSCALL ARGS) SYSCALL/ERRNO . RET-VALS) ==>
|
||||
;;;
|
||||
;;; (define (SYSCALL . ARGS)
|
||||
;;; (receive (err . RET-VALS) (SYSCALL/ERRNO . ARGS)
|
||||
;;; (if err (errno-error err SYSCALL . ARGS)
|
||||
;;; (values . RET-VALS))))
|
||||
|
||||
;;; (cond ((not err) (values . RET-VALS)) ; Win
|
||||
;;; ((= err errno/intr) (SYSCALL . ARGS)) ; Retry
|
||||
;;; (else (errno-error err SYSCALL . ARGS))))); Lose
|
||||
|
||||
(define-syntax define-errno-syscall
|
||||
(syntax-rules ()
|
||||
((define-errno-syscall (syscall arg ...) syscall/errno
|
||||
ret-val ...)
|
||||
(define (syscall arg ...)
|
||||
(receive (err ret-val ...) (syscall/errno arg ...)
|
||||
(if err (errno-error err syscall arg ...)
|
||||
(values ret-val ...)))))
|
||||
(cond ((not err) (values ret-val ...)) ; Win
|
||||
((= err errno/intr) (syscall arg ...)) ; Retry
|
||||
(else (errno-error err syscall arg ...)))))) ; Lose
|
||||
|
||||
;;; This case handles rest args
|
||||
((define-errno-syscall (syscall . args) syscall/errno
|
||||
ret-val ...)
|
||||
(define (syscall . args)
|
||||
(receive (err ret-val ...) (apply syscall/errno . args)
|
||||
(if err (apply errno-error err syscall args)
|
||||
(values ret-val ...)))))))
|
||||
|
||||
;;; DEFINE-SIMPLE-ERRNO-SYSCALL is for the simple case of a system call
|
||||
;;; that returns no interesting value other than its errno code (or #f
|
||||
;;; for success). This is most syscalls.
|
||||
;;;
|
||||
;;; (define-simple-errno-syscall (SYSCALL . ARGS) SYSCALL/ERRNO) =>
|
||||
;;;
|
||||
;;; (define (SYSCALL . ARGS)
|
||||
;;; (cond ((SYSCALL/ERRNO . ARGS) =>
|
||||
;;; (lambda (err) (errno-error err SYSCALL . ARGS)))))
|
||||
|
||||
(define-syntax define-simple-errno-syscall
|
||||
(syntax-rules ()
|
||||
((define-simple-errno-syscall (syscall arg ...) syscall/errno)
|
||||
(define (syscall arg ...)
|
||||
(cond ((syscall/errno arg ...) =>
|
||||
(lambda (err) (errno-error err syscall arg ...))))))
|
||||
|
||||
|
||||
;; This case handles a single rest arg.
|
||||
((define-simple-errno-syscall (syscall . rest) syscall/errno)
|
||||
(define (syscall . rest)
|
||||
(cond ((apply syscall/errno rest) =>
|
||||
(lambda (err) (apply errno-error err syscall rest))))))))
|
||||
|
||||
(receive (err ret-val ...) (apply syscall/errno args)
|
||||
(cond ((not err) (values ret-val ...)) ; Win
|
||||
((= err errno/intr) (apply syscall args)) ; Retry
|
||||
(else (apply errno-error err syscall args)))))))); Lose
|
||||
|
||||
;;; Process
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -158,7 +137,7 @@
|
|||
(chdir (string directory))
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define-simple-errno-syscall (%chdir dir) %chdir/errno)
|
||||
(define-errno-syscall (%chdir dir) %chdir/errno)
|
||||
|
||||
(define (chdir . maybe-dir)
|
||||
(let ((dir (:optional maybe-dir ".")))
|
||||
|
|
@ -181,7 +160,7 @@
|
|||
(define-foreign set-gid/errno (setgid (gid_t id))
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define-simple-errno-syscall (set-gid gid) set-gid/errno)
|
||||
(define-errno-syscall (set-gid gid) set-gid/errno)
|
||||
|
||||
(define-foreign %num-supplementary-gids/errno (num_supp_groups)
|
||||
(multi-rep (to-scheme integer errno_or_false)
|
||||
|
|
@ -208,7 +187,7 @@
|
|||
(define-foreign set-uid/errno (setuid (uid_t id))
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define-simple-errno-syscall (set-uid uid_t) set-uid/errno)
|
||||
(define-errno-syscall (set-uid uid_t) set-uid/errno)
|
||||
|
||||
(define-foreign %user-login-name (my_username)
|
||||
static-string)
|
||||
|
|
@ -231,7 +210,7 @@
|
|||
(setpgid (pid_t pid) (pid_t groupid))
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define-simple-errno-syscall (%set-process-group pid pgrp)
|
||||
(define-errno-syscall (%set-process-group pid pgrp)
|
||||
%set-process-group/errno)
|
||||
|
||||
|
||||
|
|
@ -302,7 +281,7 @@
|
|||
no-declare ; Workaround for AIX bug.
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define-simple-errno-syscall (set-file-mode thing mode)
|
||||
(define-errno-syscall (set-file-mode thing mode)
|
||||
(lambda (thing mode)
|
||||
(generic-file-op thing
|
||||
(lambda (fd) (set-fdes-mode/errno fd mode))
|
||||
|
|
@ -318,13 +297,13 @@
|
|||
(fchown (integer fd) (uid_t uid) (gid_t gid))
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define-simple-errno-syscall (set-file-owner thing uid)
|
||||
(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-simple-errno-syscall (set-file-group thing gid)
|
||||
(define-errno-syscall (set-file-group thing gid)
|
||||
(lambda (thing gid)
|
||||
(generic-file-op thing
|
||||
(lambda (fd) (set-fdes-uid&gid/errno fd gid -1))
|
||||
|
|
@ -355,7 +334,7 @@
|
|||
(link (string original-name) (string new-name))
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define-simple-errno-syscall (create-hard-link original-name new-name)
|
||||
(define-errno-syscall (create-hard-link original-name new-name)
|
||||
create-hard-link/errno)
|
||||
|
||||
|
||||
|
|
@ -363,7 +342,7 @@
|
|||
no-declare ; integer on SunOS
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define-simple-errno-syscall (create-fifo path mode) create-fifo/errno)
|
||||
(define-errno-syscall (create-fifo path mode) create-fifo/errno)
|
||||
|
||||
|
||||
(define-foreign create-directory/errno
|
||||
|
|
@ -390,7 +369,7 @@
|
|||
(rename (string old-name) (string new-name))
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define-simple-errno-syscall (%rename-file old-name new-name)
|
||||
(define-errno-syscall (%rename-file old-name new-name)
|
||||
%rename-file/errno)
|
||||
|
||||
|
||||
|
|
@ -398,7 +377,7 @@
|
|||
(rmdir (string path))
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define-simple-errno-syscall (delete-directory path) delete-directory/errno)
|
||||
(define-errno-syscall (delete-directory path) delete-directory/errno)
|
||||
|
||||
|
||||
(define-foreign %utime/errno (scm_utime (string path)
|
||||
|
|
@ -423,7 +402,7 @@
|
|||
(hi8 mod-time) (lo24 mod-time)))
|
||||
(%utime-now/errno path)))
|
||||
|
||||
(define-simple-errno-syscall (set-file-times . args) set-file-times/errno)
|
||||
(define-errno-syscall (set-file-times . args) set-file-times/errno)
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -511,7 +490,7 @@
|
|||
(symlink (string old-name) (string new-name)) no-declare
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
;(define-simple-errno-syscall (create-symlink old-name new-name)
|
||||
;(define-errno-syscall (create-symlink old-name new-name)
|
||||
; create-symlink/errno)
|
||||
|
||||
|
||||
|
|
@ -526,7 +505,7 @@
|
|||
(ftruncate (integer fd) (off_t length)) no-declare ; Indigo bogosity.
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define-simple-errno-syscall (truncate-file path length)
|
||||
(define-errno-syscall (truncate-file path length)
|
||||
(lambda (thing length)
|
||||
(generic-file-op thing
|
||||
(lambda (fd) (truncate-fdes/errno fd length))
|
||||
|
|
@ -537,13 +516,13 @@
|
|||
(unlink (string path))
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define-simple-errno-syscall (delete-file path) delete-file/errno)
|
||||
(define-errno-syscall (delete-file path) delete-file/errno)
|
||||
|
||||
|
||||
(define-foreign sync-file/errno (fsync (integer fd))
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define-simple-errno-syscall (sync-file fd/port)
|
||||
(define-errno-syscall (sync-file fd/port)
|
||||
(lambda (fd/port)
|
||||
(if (output-port? fd/port) (force-output fd/port))
|
||||
(call/fdes fd/port sync-file/errno)))
|
||||
|
|
@ -666,7 +645,7 @@
|
|||
(define-foreign write-fdes-char/errno (write_fdes_char (char char) (integer fd))
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define-simple-errno-syscall (write-fdes-char char fd) write-fdes-char/errno)
|
||||
(define-errno-syscall (write-fdes-char char fd) write-fdes-char/errno)
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -696,7 +675,7 @@
|
|||
(kill (pid_t pid) (integer signal))
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define-simple-errno-syscall (signal-pid pid signal) signal-pid/errno)
|
||||
(define-errno-syscall (signal-pid pid signal) signal-pid/errno)
|
||||
|
||||
(define (signal-process proc signal)
|
||||
(signal-pid (cond ((proc? proc) (proc:pid proc))
|
||||
|
|
@ -716,7 +695,7 @@
|
|||
;;; (killpg (integer proc-group) (integer signal))
|
||||
;;; (to-scheme integer errno_or_false))
|
||||
;;;
|
||||
;;; (define-simple-errno-syscall (signal-process-group proc-group signal)
|
||||
;;; (define-errno-syscall (signal-process-group proc-group signal)
|
||||
;;; signal-process-group/errno)
|
||||
|
||||
(define-foreign pause-until-interrupt (pause) no-declare ignore)
|
||||
|
|
@ -914,7 +893,7 @@
|
|||
(install_env (vector-desc env-vec))
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define-simple-errno-syscall (%install-env env-vec) %install-env/errno)
|
||||
(define-errno-syscall (%install-env env-vec) %install-env/errno)
|
||||
|
||||
(define (alist->env alist)
|
||||
(%install-env (alist->env-list alist)))
|
||||
|
|
@ -973,8 +952,11 @@
|
|||
|
||||
(define (%fdport*-read-char data)
|
||||
(let ((c (%fdport*-read-char/errno data)))
|
||||
(if (integer? c) (errno-error c %fdport*-read-char data)
|
||||
(or c eof-object))))
|
||||
(if (integer? c)
|
||||
(if (= c errno/intr)
|
||||
(%fdport*-read-char data) ; Retry
|
||||
(errno-error c %fdport*-read-char data)) ; Lose
|
||||
(or c eof-object)))) ; Win
|
||||
|
||||
|
||||
(define-foreign %fdport*-char-ready?/errno
|
||||
|
|
@ -990,19 +972,19 @@
|
|||
(fdport_putchar (desc data) (char c))
|
||||
(to-scheme integer "False_on_zero")) ; Win: #f, lose: errno
|
||||
|
||||
(define-simple-errno-syscall (%fdport*-write-char desc c)
|
||||
(define-errno-syscall (%fdport*-write-char desc c)
|
||||
%fdport*-write-char/errno)
|
||||
|
||||
|
||||
(define-foreign flush-fdport*/errno (flush_fdport (desc data))
|
||||
(to-scheme integer "False_on_zero")) ; Win: #f, lose: errno
|
||||
|
||||
(define-simple-errno-syscall (flush-fdport* data) flush-fdport*/errno)
|
||||
(define-errno-syscall (flush-fdport* data) flush-fdport*/errno)
|
||||
|
||||
(define-foreign flush-all-ports/errno (flush_all_ports)
|
||||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define-simple-errno-syscall (flush-all-ports)
|
||||
(define-errno-syscall (flush-all-ports)
|
||||
flush-all-ports/errno)
|
||||
|
||||
(define-foreign %fdport*-seek/errno
|
||||
|
|
@ -1027,7 +1009,7 @@
|
|||
(install_port (integer fd) (desc port))
|
||||
(to-scheme integer "False_on_zero")) ; Win: #f, lose: errno
|
||||
|
||||
(define-simple-errno-syscall (%install-port fd port) %install-port/errno)
|
||||
(define-errno-syscall (%install-port fd port) %install-port/errno)
|
||||
|
||||
|
||||
(define-foreign %maybe-fdes->port (maybe_fdes2port (integer fd))
|
||||
|
|
@ -1070,7 +1052,7 @@
|
|||
(to-scheme integer errno_or_false))
|
||||
|
||||
(define-errno-syscall (%fcntl-read fd command) %fcntl-read/errno value)
|
||||
(define-simple-errno-syscall (%fcntl-write fd command val) %fcntl-write/errno)
|
||||
(define-errno-syscall (%fcntl-write fd command val) %fcntl-write/errno)
|
||||
|
||||
(define (i/o-flags fd/port)
|
||||
(call/fdes fd/port
|
||||
|
|
|
|||
18
scsh/tty.scm
18
scsh/tty.scm
|
|
@ -174,14 +174,14 @@
|
|||
(tty-info:time info)))))))
|
||||
|
||||
|
||||
(define-simple-errno-syscall (%set-tty-info fdes option
|
||||
control-chars
|
||||
iflag-hi8 iflag-lo24
|
||||
oflag-hi8 oflag-lo24
|
||||
cflag-hi8 cflag-lo24
|
||||
lflag-hi8 lflag-lo24
|
||||
ispeed-code ospeed-code
|
||||
min time)
|
||||
(define-errno-syscall (%set-tty-info fdes option
|
||||
control-chars
|
||||
iflag-hi8 iflag-lo24
|
||||
oflag-hi8 oflag-lo24
|
||||
cflag-hi8 cflag-lo24
|
||||
lflag-hi8 lflag-lo24
|
||||
ispeed-code ospeed-code
|
||||
min time)
|
||||
%set-tty-info/errno)
|
||||
|
||||
|
||||
|
|
@ -316,7 +316,7 @@
|
|||
proc-group
|
||||
(proc:pid proc-group))))))
|
||||
|
||||
(define-simple-errno-syscall (%set-tty-process-group fdes pid)
|
||||
(define-errno-syscall (%set-tty-process-group fdes pid)
|
||||
%set-tty-process-group/errno)
|
||||
|
||||
(define-foreign %set-tty-process-group/errno (tcsetpgrp (fixnum fdes)
|
||||
|
|
|
|||
Loading…
Reference in New Issue