Hand out the port and not just port-data to the handler.

This commit is contained in:
mainzelm 2001-04-09 07:55:50 +00:00
parent ba159080c8
commit 384c28fab4
2 changed files with 73 additions and 6 deletions

View File

@ -226,7 +226,7 @@
(define (real-char-ready? port) (define (real-char-ready? port)
(if (not (open-input-port? port)) (if (not (open-input-port? port))
(call-error "invalid argument" char-ready? 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)) (call-error "invalid argument" output-port-ready? port))
(else (else
(let ((val ((port-handler-ready? (port-handler port)) (let ((val ((port-handler-ready? (port-handler port))
(port-data port)))) port)))
(release-port-lock port) (release-port-lock port)
val)))) val))))

View File

@ -49,8 +49,8 @@
;;; Support for channel-ready? ;;; Support for channel-ready?
;;; This applies to input- and output-ports ;;; This applies to input- and output-ports
(define (fdport-channel-ready? fdport*) (define (fdport-channel-ready? fdport)
(channel-ready? (fdport-data:channel fdport*))) (channel-ready? (fdport-data:channel (port-data fdport))))
;Arbitrary, for now. ;Arbitrary, for now.
(define buffer-size 255) (define buffer-size 255)
@ -177,6 +177,10 @@
(define fdport-data port-data) (define fdport-data port-data)
; That was easy. ; 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) (define (set-port-buffering port policy . maybe-size)
(cond ((and (fdport? port) (open-input-port? port)) (cond ((and (fdport? port) (open-input-port? port))
@ -518,14 +522,17 @@
(set-fdport-data:revealed fdport* new-revealed) (set-fdport-data:revealed fdport* new-revealed)
(vector-set! fdports old-fd #f) (vector-set! fdports old-fd #f)
(close-channel ch) (close-channel ch)
(set-fdport-data:channel (set-fdport-data:channel
fdport* fdport*
((if (input-port? port) make-input-fdchannel make-output-fdchannel) fd)) (make-fd-channel port fd))
(vector-set! fdports fd old-vector-ref) (vector-set! fdports fd old-vector-ref)
(%set-cloexec fd (not new-revealed))) (%set-cloexec fd (not new-revealed)))
(release-port-lock port) (release-port-lock port)
#f) ; JMG: It used to return #f on succes in 0.5.1, so we do the same #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) (define (close-fdes fd)
(evict-ports fd) (evict-ports fd)
(%close-fdes fd)) (%close-fdes fd))
@ -674,3 +681,63 @@
(let-fluid $current-output-port port thunk)))) (let-fluid $current-output-port port thunk))))
;;; replace rts/channel-port.scm end ;;; 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)
'#()))))