Update of /cvsroot/scsh/scsh-0.6/scsh
In directory usw-pr-cvs1:/tmp/cvs-serv28215/scsh
Modified Files:
newports.scm
Log Message:
Adapted some of Richard's changes for char-ready? and output-port-ready?.
Index: newports.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/newports.scm,v
retrieving revision 1.6
retrieving revision 1.7
diff -C2 -r1.6 -r1.7
*** newports.scm 2000/06/28 10:27:34 1.6
--- newports.scm 2001/03/23 10:59:07 1.7
***************
*** 31,35 ****
(ch (fdport-data:channel fdport*))
(ch-number (channel-os-index ch)))
! (if (fdport-data:revealed fdport*)
(vector-set! fdports ch-number fdport)
(weak-vector-set! fdports ch-number fdport))))
--- 31,35 ----
(ch (fdport-data:channel fdport*))
(ch-number (channel-os-index ch)))
! (if (not (= (fdport-data:revealed fdport*) 0))
(vector-set! fdports ch-number fdport)
(weak-vector-set! fdports ch-number fdport))))
***************
*** 47,50 ****
--- 47,56 ----
(enum channel-status-option closed)))
+ ;;; Support for channel-ready?
+ ;;; This applies to input- and output-ports
+
+ (define (fdport-channel-ready? fdport*)
+ (channel-ready? (fdport-data: channel fdport*)))
+
;Arbitrary, for now.
(define buffer-size 255)
***************
*** 60,65 ****
;The two following routines are to build ports from stdin and stdout channels.
(define (channel-port->input-fdport channel-port)
! (let ((p (make-input-port input-fdport-handler
! (make-fdport-data (channel-cell-ref (port-data
channel-port)) 1)
(make-byte-vector buffer-size 0) 0 0)))
(obtain-port-lock channel-port)
--- 66,72 ----
;The two following routines are to build ports from stdin and stdout channels.
(define (channel-port->input-fdport channel-port)
! (let ((p (make-buffered-input-port input-fdport-handler
! (make-fdport-data
! (channel-cell-ref (port-data channel-port)) 1)
(make-byte-vector buffer-size 0) 0 0)))
(obtain-port-lock channel-port)
***************
*** 71,77 ****
(define (channel-port->output-fdport channel-port)
! (let ((p (make-output-port output-fdport-handler
! (make-fdport-data (channel-cell-ref(port-data
channel-port)) 1)
! (make-byte-vector buffer-size 0) 0 buffer-size)))
(obtain-port-lock channel-port)
(set-port-lock! p (port-lock channel-port))
--- 78,85 ----
(define (channel-port->output-fdport channel-port)
! (let ((p (make-buffered-output-port
! output-fdport-handler
! (make-fdport-data (channel-cell-ref(port-data channel-port)) 1)
! (make-byte-vector buffer-size 0) 0 buffer-size)))
(obtain-port-lock channel-port)
(set-port-lock! p (port-lock channel-port))
***************
*** 84,103 ****
(define (channel-port->unbuffered-output-fdport channel-port)
(let ((p (make-unbuffered-output-port unbuffered-output-fdport-handler
! (make-fdport-data (channel-cell-ref(port-data
channel-port)) 1))))
(obtain-port-lock channel-port)
(set-port-lock! p (port-lock channel-port))
(set-port-locked?! p (port-locked? channel-port))
(install-fdport p)
! ; (periodically-force-output! p)
(release-port-lock channel-port)
p))
(define (alloc-input-fdport fd revealed)
! (make-input-port input-fdport-handler
(make-fdport-data (make-input-fdchannel fd) revealed)
(make-byte-vector buffer-size 0) 0 0))
(define (alloc-output-fdport fd revealed)
! (make-output-port output-fdport-handler
(make-fdport-data (make-output-fdchannel fd) revealed)
(make-byte-vector buffer-size 0) 0 buffer-size))
--- 92,112 ----
(define (channel-port->unbuffered-output-fdport channel-port)
(let ((p (make-unbuffered-output-port unbuffered-output-fdport-handler
! (make-fdport-data
! (channel-cell-ref (port-data channel-port)) 1))))
(obtain-port-lock channel-port)
(set-port-lock! p (port-lock channel-port))
(set-port-locked?! p (port-locked? channel-port))
(install-fdport p)
! (periodically-force-output! p)
(release-port-lock channel-port)
p))
(define (alloc-input-fdport fd revealed)
! (make-buffered-input-port input-fdport-handler
(make-fdport-data (make-input-fdchannel fd) revealed)
(make-byte-vector buffer-size 0) 0 0))
(define (alloc-output-fdport fd revealed)
! (make-buffered-output-port output-fdport-handler
(make-fdport-data (make-output-fdchannel fd) revealed)
(make-byte-vector buffer-size 0) 0 buffer-size))
***************
*** 110,114 ****
(define (make-output-fdport fd revealed)
(let ((p (alloc-output-fdport fd revealed)))
! ;(periodically-force-output! p)
(install-fdport p)
p))
--- 119,123 ----
(define (make-output-fdport fd revealed)
(let ((p (alloc-output-fdport fd revealed)))
! (periodically-force-output! p)
(install-fdport p)
p))
***************
*** 130,138 ****
;The handlers drop straight through to the convenient channel routines.
(define (make-input-fdport-handler bufferproc)
! (make-port-handler
(lambda (fdport*)
(list 'input-fdport (fdport-data:channel fdport*)))
close-fdport*
bufferproc
(lambda (fdport* owner)
(steal-channel! (fdport-data:channel fdport*) owner))))
--- 139,148 ----
;The handlers drop straight through to the convenient channel routines.
(define (make-input-fdport-handler bufferproc)
! (make-buffered-input-port-handler
(lambda (fdport*)
(list 'input-fdport (fdport-data:channel fdport*)))
close-fdport*
bufferproc
+ fdport-channel-ready?
(lambda (fdport* owner)
(steal-channel! (fdport-data:channel fdport*) owner))))
***************
*** 144,152 ****
(define (make-output-fdport-handler bufferproc)
! (make-port-handler
(lambda (fdport*)
(list 'output-fdport (fdport-data:channel fdport*)))
close-fdport*
bufferproc
(lambda (fdport* owner)
(steal-channel! (fdport-data:channel fdport*) owner))))
--- 154,163 ----
(define (make-output-fdport-handler bufferproc)
! (make-buffered-output-port-handler
(lambda (fdport*)
(list 'output-fdport (fdport-data:channel fdport*)))
close-fdport*
bufferproc
+ fdport-channel-ready?
(lambda (fdport* owner)
(steal-channel! (fdport-data:channel fdport*) owner))))
***************
*** 168,186 ****
- (define (06-policy policy)
- (case policy
- ((0) 'bufpol/block)
- ((1) 'bufpol/line)
- ((2) 'bufpol/none)
- (else policy)))
-
- (define (guess-output-policy port)
- (if (= 0 (port-limit port))
- 'bufpol/none
- 'bufpol/block))
-
-
(define (set-port-buffering port policy . maybe-size)
- (let ((policy (06-policy policy)))
(cond ((and (fdport? port) (open-input-port? port))
(let ((size (if (pair? maybe-size) (car maybe-size) 255)))
--- 179,183 ----
***************
*** 191,200 ****
(set-output-port-buffering port policy size)))
(else
! (warn "port-type not supported" port)))))
(define (set-output-port-buffering port policy size)
! (cond ((eq? policy 'bufpol/none)
(install-nullbuffer port unbuffered-output-fdport-handler))
! ((eq? policy 'bufpol/block)
(let ((old-size (byte-vector-length (port-buffer port)))
(new-buffer (make-byte-vector size 0)))
--- 188,197 ----
(set-output-port-buffering port policy size)))
(else
! (warn "port-type not supported" port))))
(define (set-output-port-buffering port policy size)
! (cond ((eq? policy bufpol/none)
(install-nullbuffer port unbuffered-output-fdport-handler))
! ((eq? policy bufpol/block)
(let ((old-size (byte-vector-length (port-buffer port)))
(new-buffer (make-byte-vector size 0)))
***************
*** 209,213 ****
(install-buffer port new-buffer size)
(release-port-lock port)))
! ((eq? policy 'bufpol/line)
(install-nullbuffer port (make-line-output-proc size)))
(else (warn "policy not supported " policy))))
--- 206,210 ----
(install-buffer port new-buffer size)
(release-port-lock port)))
! ((eq? policy bufpol/line)
(install-nullbuffer port (make-line-output-proc size)))
(else (warn "policy not supported " policy))))
***************
*** 223,227 ****
(define (install-buffer port new-buffer size)
! (if (eq? 'bufpol/none (guess-output-policy port))
(set-port-handler! port output-fdport-handler))
(set-port-limit! port size)
--- 220,224 ----
(define (install-buffer port new-buffer size)
! (if (eq? bufpol/none (guess-output-policy port))
(set-port-handler! port output-fdport-handler))
(set-port-limit! port size)
***************
*** 235,239 ****
(let ((proc-buffer (make-byte-vector size 0))
(proc-buffer-index 0))
! (make-port-handler
(lambda (fdport*)
(list 'output-fdport (fdport-data:channel fdport*)))
--- 232,236 ----
(let ((proc-buffer (make-byte-vector size 0))
(proc-buffer-index 0))
! (make-buffered-output-port-handler
(lambda (fdport*)
(list 'output-fdport (fdport-data:channel fdport*)))
***************
*** 253,256 ****
--- 250,254 ----
(fdport-data:channel fdport*))
(set! proc-buffer-index 0))))
+ fdport-channel-ready?
(lambda (fdport* owner)
(steal-channel! (fdport-data:channel fdport*) owner)))))
***************
*** 258,267 ****
(define (set-input-port-buffering port policy size)
! (cond ((eq? policy 'bufpol/none)
! (set-input-port-buffering port 'bufpol/block 1))
! ((eq? policy 'bufpol/block)
(if (<= size 0) (error "size must be at least 1"))
(install-input-handler port input-fdport-handler size #t))
! ((eq? policy 'bufpol/line)
(error "bufpol/line not allowed on input"))
(else (warn "policy not supported " policy))))
--- 256,265 ----
(define (set-input-port-buffering port policy size)
! (cond ((eq? policy bufpol/none)
! (set-input-port-buffering port bufpol/block 1))
! ((eq? policy bufpol/block)
(if (<= size 0) (error "size must be at least 1"))
(install-input-handler port input-fdport-handler size #t))
! ((eq? policy bufpol/line)
(error "bufpol/line not allowed on input"))
(else (warn "policy not supported " policy))))
***************
*** 477,484 ****
(if (not (fdport? (current-error-port)))
(set! old-errport (current-error-port)))
! (set-fluid! $current-input-port (channel-port->input-fdport
(current-input-port)))
! (set-fluid! $current-output-port (channel-port->output-fdport
(current-output-port)))
! (set-fluid! $current-error-port (channel-port->unbuffered-output-fdport
(current-error-port)))
(set-fluid! $current-noise-port (make-null-output-port)))
--- 475,485 ----
(if (not (fdport? (current-error-port)))
(set! old-errport (current-error-port)))
! (set-fluid! $current-input-port
! (channel-port->input-fdport (current-input-port)))
! (set-fluid! $current-output-port
! (channel-port->output-fdport (current-output-port)))
! (set-fluid! $current-error-port
! (channel-port->unbuffered-output-fdport (current-error-port)))
(set-fluid! $current-noise-port (make-null-output-port)))
***************
*** 673,675 ****
(let-fluid $current-output-port port thunk))))
! ;;; replace rts/channel-port.scm end
\ No newline at end of file
--- 674,676 ----
(let-fluid $current-output-port port thunk))))
! ;;; replace rts/channel-port.scm end
|