scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Really fixed the bug in sleep. The previous fix was totally broken.

This commit is contained in:
mainzelm 2001-06-07 16:14:29 +00:00
parent f91b93f16a
commit 8b44999d55
1 changed files with 26 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
scheme/rts/sleep.scm
View File

@ -2,17 +2,32 @@
; Sleeping for N milliseconds. ; Sleeping for N milliseconds.
(define (sleep n) (define (sleep user-n)
(let ((queue (make-thread-queue))) ; only one entry, but it must be a queue (let ((n (coerce-to-nonnegative-integer user-n)))
(disable-interrupts!) (cond ((not n)
(enqueue-thread! queue (current-thread)) (call-error "wrong type argument" sleep user-n))
(set! *dozers* ((< 0 n)
(insert (cons (+ (real-time) (inexact->exact (round n))) (let ((queue (make-thread-queue))) ; only one entry, but it must be a queue
queue) (disable-interrupts!)
*dozers* (enqueue-thread! queue (current-thread))
(lambda (frob1 frob2) (set! *dozers*
(< (car frob1) (car frob2))))) (insert (cons (+ (real-time) n)
(block))) queue)
*dozers*
(lambda (frob1 frob2)
(< (car frob1) (car frob2)))))
(block))))))
(define (coerce-to-nonnegative-integer n)
(if (real? n)
(let* ((n (round n))
(n (if (exact? n)
n
(inexact->exact n))))
(if (<= 0 n)
n
#f))
#f))
(define *dozers* '()) ; List of (wakeup-time . queue) (define *dozers* '()) ; List of (wakeup-time . queue)