diff --git a/scsh/network.scm b/scsh/network.scm index 62053e8..b2dbe15 100644 --- a/scsh/network.scm +++ b/scsh/network.scm @@ -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) ;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=- diff --git a/scsh/sighandlers.c b/scsh/sighandlers.c new file mode 100644 index 0000000..8b2bf35 --- /dev/null +++ b/scsh/sighandlers.c @@ -0,0 +1,91 @@ +/* This is an Scheme48/C interface file, +** automatically generated by cig. +*/ + +#include +#include /* 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; + } + diff --git a/scsh/sighandlers.scm b/scsh/sighandlers.scm new file mode 100644 index 0000000..c30df4c --- /dev/null +++ b/scsh/sighandlers.scm @@ -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) diff --git a/scsh/sighandlers1.c b/scsh/sighandlers1.c new file mode 100644 index 0000000..3d0ef34 --- /dev/null +++ b/scsh/sighandlers1.c @@ -0,0 +1,292 @@ +/* Need to define sig2interrupt vector. +** Interrupt-system mutators should probably hold interrupts while they +** operate. +*/ + +#include +#include +#include +#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<= 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; + } diff --git a/scsh/syscalls.scm b/scsh/syscalls.scm index 43114bc..4360354 100644 --- a/scsh/syscalls.scm +++ b/scsh/syscalls.scm @@ -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 diff --git a/scsh/tty.scm b/scsh/tty.scm index f0584c8..8d1d4cf 100644 --- a/scsh/tty.scm +++ b/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)