diff --git a/scheme/rts/port.scm b/scheme/rts/port.scm index 3eb7c50..9d581a7 100644 --- a/scheme/rts/port.scm +++ b/scheme/rts/port.scm @@ -226,7 +226,7 @@ (define (real-char-ready? port) (if (not (open-input-port? port)) (call-error "invalid argument" char-ready? port) - ((port-handler-ready? (port-handler port)) (port-data port)))) + ((port-handler-ready? (port-handler port)) port))) ;---------------- @@ -338,7 +338,7 @@ (call-error "invalid argument" output-port-ready? port)) (else (let ((val ((port-handler-ready? (port-handler port)) - (port-data port)))) + port))) (release-port-lock port) val)))) diff --git a/scsh/newports.scm b/scsh/newports.scm index de4f090..3af1538 100644 --- a/scsh/newports.scm +++ b/scsh/newports.scm @@ -49,8 +49,8 @@ ;;; Support for channel-ready? ;;; This applies to input- and output-ports -(define (fdport-channel-ready? fdport*) - (channel-ready? (fdport-data:channel fdport*))) +(define (fdport-channel-ready? fdport) + (channel-ready? (fdport-data:channel (port-data fdport)))) ;Arbitrary, for now. (define buffer-size 255) @@ -177,6 +177,10 @@ (define fdport-data port-data) ; That was easy. +(define (guess-output-policy port) + (if (= 0 (port-limit port)) + bufpol/none + bufpol/block)) (define (set-port-buffering port policy . maybe-size) (cond ((and (fdport? port) (open-input-port? port)) @@ -518,14 +522,17 @@ (set-fdport-data:revealed fdport* new-revealed) (vector-set! fdports old-fd #f) (close-channel ch) - (set-fdport-data:channel + (set-fdport-data:channel fdport* - ((if (input-port? port) make-input-fdchannel make-output-fdchannel) fd)) + (make-fd-channel port fd)) (vector-set! fdports fd old-vector-ref) (%set-cloexec fd (not new-revealed))) (release-port-lock port) #f) ; JMG: It used to return #f on succes in 0.5.1, so we do the same +(define (make-fd-channel port fd) + ((if (input-port? port) make-input-fdchannel make-output-fdchannel) fd)) + (define (close-fdes fd) (evict-ports fd) (%close-fdes fd)) @@ -674,3 +681,63 @@ (let-fluid $current-output-port port thunk)))) ;;; replace rts/channel-port.scm end + + + +(define (nselect rvec wvec evec timeout) + (let ((rlist (vector->list rvec)) + (wlist (vector->list wvec))) + (let ((imm-r (filter char-ready? rlist)) + (imm-w (filter output-port-ready? wlist))) + (if (and (null? imm-r) + (null? imm-w)) + (select-threaded rlist wlist timeout) + (values (list->vector imm-r) + (list->vector imm-w) + '#()))))) + +(define (timeout-thread result-lock timeout) + (lambda () + ((structure-ref threads sleep) timeout) + (release-lock result-lock))) + +(define (select-threaded rlist wlist timeout) + (let ((result-lock (make-lock)) + (ready-lock (make-lock)) + (read-ready (cons 'cell '())) + (write-ready (cons 'cell '())) + (are-we-ready? #f)) + (let* ((port-waiter + (lambda (ready? ready-list) + (lambda (port) + (lambda () +; ((structure-ref interrupts disable-interrupts!)) +; (if (ready? port) +; ((structure-ref interrupts enable-interrupts!)) +; (wait-for-channel ; enables interrupts +; (fdport-data:channel +; (fdport-data port)))) + (let lp () + (if (ready? port) + (begin + (obtain-lock ready-lock) + (set-cdr! ready-list (cons port (cdr ready-list))) + (release-lock ready-lock) + (release-lock result-lock)) + (if (not are-we-ready?) + (begin ((structure-ref threads sleep) 20) + (lp))))))))) + (read-waiter (port-waiter char-ready? read-ready)) + (write-waiter (port-waiter output-port-ready? write-ready))) + (obtain-lock result-lock) + (for-each spawn (map read-waiter rlist)) + (for-each spawn (map write-waiter wlist)) + (if timeout (spawn (timeout-thread result-lock timeout))) + (obtain-lock result-lock) + (set! are-we-ready? #t) +; (relinquish-timeslice) + (values (cdr read-ready) + (cdr write-ready) + '#())))) + + \ No newline at end of file