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