New signal-handler code.

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

scsh/sighandlers.c

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

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)

scsh/sighandlers1.c

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

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)
+;;;     (cond ((not err) (values . RET-VALS))		; Win
-;;;     	(values . RET-VALS))))
+;;;           ((= 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 ...)
+         (cond ((not err) (values ret-val ...))			; Win
-             (values ret-val ...)))))
+	       ((= 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)
+       (receive (err ret-val ...) (apply syscall/errno args)
-         (if err (apply errno-error err syscall args)
+         (cond ((not err) (values ret-val ...))			; Win
-             (values ret-val ...)))))))
+	       ((= err errno/intr) (apply syscall args))	; Retry
-
+	       (else (apply errno-error err syscall args)))))))); Lose
-;;; 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))))))))
-
 
 ;;; 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)
+    (if (integer? c)
-	(or c eof-object))))
+	(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

scsh/tty.scm

@@ -174,14 +174,14 @@
 			 (tty-info:time info)))))))
 
 
-(define-simple-errno-syscall (%set-tty-info fdes      option
+(define-errno-syscall (%set-tty-info fdes      option
-					    control-chars
+				     control-chars
-					    iflag-hi8 iflag-lo24
+				     iflag-hi8 iflag-lo24
-					    oflag-hi8 oflag-lo24
+				     oflag-hi8 oflag-lo24
-					    cflag-hi8 cflag-lo24
+				     cflag-hi8 cflag-lo24
-					    lflag-hi8 lflag-lo24
+				     lflag-hi8 lflag-lo24
-					    ispeed-code ospeed-code
+				     ispeed-code ospeed-code
-					    min	      time)
+				     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)