Rewrote SLEEP (and added SLEEP-UNTIL) so that it doesn't hang up signal

delivery in C code.

scsh/scsh-interfaces.scm

@@ -323,6 +323,9 @@
 	  wait/poll
 	  wait/stopped-children
 
+	  sleep
+	  sleep-until
+
 	  call-terminally
 	  halts?))
 
@@ -390,7 +393,6 @@
   (export signal-process
 	  signal-process-group
 	  pause-until-interrupt
-	  sleep
 	  itimer))
 
 

scsh/scsh-package.scm

@@ -86,11 +86,7 @@
 ;;; export the whole scsh enchilada.
 
 (define-structures
-  ((scsh-regexp-package scsh-regexp-interface)
-   (scsh-level-0-internals (export set-command-line-args!
-				   init-scsh-hindbrain
-				   init-scsh-vars))
-   (scsh-level-0
+  ((scsh-level-0
     (compound-interface posix-fdflags-interface
 			posix-errno-interface
 			posix-signals-interface
@@ -121,7 +117,11 @@
 			;; in separate modules, but we'll toss it in for now.
 			(interface-of ascii) ; char<->ascii
 			string-ports-interface
-			)))
+			))
+   (scsh-level-0-internals (export set-command-line-args!
+				   init-scsh-hindbrain
+				   init-scsh-vars))
+   (scsh-regexp-package scsh-regexp-interface))
   (for-syntax (open scsh-syntax-helpers scheme))
   (open externals
 	structure-refs

scsh/sleep1.c

@@ -0,0 +1,38 @@
+#include <sys/types.h>
+#include <sys/time.h>
+#include <unistd.h>
+#include <time.h>
+#include "../scheme48.h"
+
+/* Sux because it's dependent on 32-bitness. */
+#define hi8(i)  (((i)>>24) & 0xff)
+#define lo24(i) ((i) & 0xffffff)
+#define comp8_24(hi, lo) (((hi)<<24) + (lo))
+
+/* Sleep until time hisecs/losecs (return #t),
+** or until interrupted (return #f).
+**
+** We make you pass in an absolute time so that if you have to loop
+** making multiple tries to sleep due to interrupts, you don't get
+** drift.
+**
+** Posix sleep() is not too well defined. This one uses select(),
+** and is pretty straightforward.
+*/
+
+scheme_value sleep_until(int hisecs, int losecs)
+{
+  time_t when = comp8_24(hisecs, losecs);
+  time_t now = time(0);
+  int delta = when - now;
+  if( delta > 0 ) {
+    fd_set r, w, e;
+    struct timeval tv = { delta, 0 };
+    FD_ZERO(&r);
+    FD_ZERO(&w);
+    FD_ZERO(&e);
+    if( select(0, &r, &w, &e, &tv) ) return SCHFALSE;	/* Lose */
+    }
+  return SCHTRUE; /* Win */
+  }
+  

scsh/syscalls.c

@@ -1154,15 +1154,15 @@ scheme_value df_fcntl_write(long nargs, scheme_value *args)
     return ret1;
     }
 
-scheme_value df_sleep(long nargs, scheme_value *args)
+scheme_value df_sleep_until(long nargs, scheme_value *args)
 {
-    extern unsigned int sleep(unsigned int );
+    extern scheme_value sleep_until(int , int );
     scheme_value ret1;
-    unsigned int r1;
+    scheme_value r1;
 
-    cig_check_nargs(1, nargs, "sleep");
-    r1 = sleep(EXTRACT_FIXNUM(args[0]));
-    ret1 = ENTER_FIXNUM(r1);
+    cig_check_nargs(2, nargs, "sleep_until");
+    r1 = sleep_until(EXTRACT_FIXNUM(args[1]), EXTRACT_FIXNUM(args[0]));
+    ret1 = r1;
     return ret1;
     }
 

scsh/syscalls.scm

@@ -1116,7 +1116,18 @@
 ; De-released -- not POSIX and not on SGI systems.
 ; (define-foreign usleep (usleep (integer usecs)) integer)
 
-(define-foreign sleep (sleep (uint_t secs)) uint_t)
+(define (sleep secs) (sleep-until (+ secs (time))))
+
+(define (sleep-until when)
+  (let* ((when (floor when))	; Painful to do real->int in Scheme.
+	 (when (if (exact? when) when (inexact->exact when)))
+	 (h (hi8 when)) (l (lo24 when)))
+    (let lp ()
+      (or (%sleep-until h l) (lp)))))
+
+(define-foreign %sleep-until (sleep_until (fixnum hi)
+					  (fixnum lo))
+  desc)
 
 (define-foreign %gethostname (scm_gethostname)
   static-string)