Rewrote SLEEP (and added SLEEP-UNTIL) so that it doesn't hang up signal
delivery in C code.
This commit is contained in:
parent
101a61082f
commit
2773441f05
|
@ -323,6 +323,9 @@
|
||||||
wait/poll
|
wait/poll
|
||||||
wait/stopped-children
|
wait/stopped-children
|
||||||
|
|
||||||
|
sleep
|
||||||
|
sleep-until
|
||||||
|
|
||||||
call-terminally
|
call-terminally
|
||||||
halts?))
|
halts?))
|
||||||
|
|
||||||
|
@ -390,7 +393,6 @@
|
||||||
(export signal-process
|
(export signal-process
|
||||||
signal-process-group
|
signal-process-group
|
||||||
pause-until-interrupt
|
pause-until-interrupt
|
||||||
sleep
|
|
||||||
itimer))
|
itimer))
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -86,11 +86,7 @@
|
||||||
;;; export the whole scsh enchilada.
|
;;; export the whole scsh enchilada.
|
||||||
|
|
||||||
(define-structures
|
(define-structures
|
||||||
((scsh-regexp-package scsh-regexp-interface)
|
((scsh-level-0
|
||||||
(scsh-level-0-internals (export set-command-line-args!
|
|
||||||
init-scsh-hindbrain
|
|
||||||
init-scsh-vars))
|
|
||||||
(scsh-level-0
|
|
||||||
(compound-interface posix-fdflags-interface
|
(compound-interface posix-fdflags-interface
|
||||||
posix-errno-interface
|
posix-errno-interface
|
||||||
posix-signals-interface
|
posix-signals-interface
|
||||||
|
@ -121,7 +117,11 @@
|
||||||
;; in separate modules, but we'll toss it in for now.
|
;; in separate modules, but we'll toss it in for now.
|
||||||
(interface-of ascii) ; char<->ascii
|
(interface-of ascii) ; char<->ascii
|
||||||
string-ports-interface
|
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))
|
(for-syntax (open scsh-syntax-helpers scheme))
|
||||||
(open externals
|
(open externals
|
||||||
structure-refs
|
structure-refs
|
||||||
|
|
|
@ -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 */
|
||||||
|
}
|
||||||
|
|
|
@ -1154,15 +1154,15 @@ scheme_value df_fcntl_write(long nargs, scheme_value *args)
|
||||||
return ret1;
|
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;
|
scheme_value ret1;
|
||||||
unsigned int r1;
|
scheme_value r1;
|
||||||
|
|
||||||
cig_check_nargs(1, nargs, "sleep");
|
cig_check_nargs(2, nargs, "sleep_until");
|
||||||
r1 = sleep(EXTRACT_FIXNUM(args[0]));
|
r1 = sleep_until(EXTRACT_FIXNUM(args[1]), EXTRACT_FIXNUM(args[0]));
|
||||||
ret1 = ENTER_FIXNUM(r1);
|
ret1 = r1;
|
||||||
return ret1;
|
return ret1;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
|
@ -1116,7 +1116,18 @@
|
||||||
; De-released -- not POSIX and not on SGI systems.
|
; De-released -- not POSIX and not on SGI systems.
|
||||||
; (define-foreign usleep (usleep (integer usecs)) integer)
|
; (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)
|
(define-foreign %gethostname (scm_gethostname)
|
||||||
static-string)
|
static-string)
|
||||||
|
|
Loading…
Reference in New Issue