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

Merge revision 1.41.2.1 from r0-6-stable. 

Original log message:

date: 2004/01/16 21:42:17;  author: sperber;  state: Exp;  lines: +33 -27
Fix the various SELECT-like procedures for 0 timeouts.
This commit is contained in:
sperber 2004-01-17 16:12:38 +00:00
parent 507a10137b
commit 6bd1809b57
1 changed files with 33 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
scsh/newports.scm
View File

@ -756,30 +756,28 @@
(let ((port (port/fdes->output-port port/fd)))
((port-handler-ready? (port-handler port)) port)))
(define (make-any-ready input?)
(let ((port/fdes-ready?
(if input?
input-port/fdes-ready?
output-port/fdes-ready?)))
(lambda (port/fds)
(let loop ((port/fds port/fds))
(if (null? port/fds)
'()
(let ((port/fd (car port/fds)))
(if (port/fdes-ready? port/fd)
;; one is ready, get them all
(let loop ((rest (cdr port/fds))
(ready (list port/fd)))
(cond
((null? rest) (reverse ready))
((port/fdes-ready? (car rest))
(loop (cdr rest) (cons (car rest) ready)))
(else
(loop (cdr rest) ready))))
(loop (cdr port/fds)))))))))
(define (make-any-ready port/fdes-ready?)
(lambda (port/fds)
(let loop ((port/fds port/fds))
(if (null? port/fds)
'()
(let ((port/fd (car port/fds)))
(if (port/fdes-ready? port/fd)
;; one is ready, get them all
(let loop ((rest (cdr port/fds))
(ready (list port/fd)))
(cond
((null? rest) (reverse ready))
((port/fdes-ready? (car rest))
(loop (cdr rest) (cons (car rest) ready)))
(else
(loop (cdr rest) ready))))
(loop (cdr port/fds))))))))
(define any-input-ready (make-any-ready #t))
(define any-output-ready (make-any-ready #f))
(define any-input-ready (make-any-ready input-port/fdes-ready?))
(define any-output-ready (make-any-ready output-port/fdes-ready?))
(define any-channel-ready (make-any-ready fdport-channel-ready?))
(define (make-port/fdes-check-unlocked input?)
(let ((port/fdes->port
@ -819,7 +817,7 @@
(let ((any-read (any-input-ready (filter input-port? read-list)))
(any-write (any-output-ready (filter output-port? write-list))))
(if (or (pair? any-read) (pair? any-write))
(if (or (eqv? timeout 0) (pair? any-read) (pair? any-write))
(begin
((structure-ref interrupts enable-interrupts!))
(values (list->vector any-read)
@ -873,7 +871,7 @@
(let ((any-read (any-input-ready (filter input-port? read-list)))
(any-write (any-output-ready (filter output-port? write-list))))
(if (or (pair? any-read) (pair? any-write))
(if (or (eqv? timeout 0) (pair? any-read) (pair? any-write))
(begin
((structure-ref interrupts enable-interrupts!))
(let ((n-read-ready
@ -986,7 +984,7 @@
(let ((any-read (any-input-ready read-list))
(any-write (any-output-ready write-list)))
(if (or (pair? any-read) (pair? any-write))
(if (or (eqv? timeout 0) (pair? any-read) (pair? any-write))
(begin
((structure-ref interrupts enable-interrupts!))
(append any-read any-write))
@ -1003,7 +1001,15 @@
(for-each input-port/fdes-check-unlocked read-list)
(for-each output-port/fdes-check-unlocked write-list)
(really-select-port-channels timeout read-list write-list)))
(let ((any-read (any-channel-ready read-list))
(any-write (any-channel-ready write-list)))
(if (or (eqv? timeout 0) (pair? any-read) (pair? any-write))
(begin
((structure-ref interrupts enable-interrupts!))
(append any-read any-write))
(really-select-port-channels timeout read-list write-list)))))
;; assumes interrupts are disabled and that ports aren't locked