removed bufpol/line for input, replaced code-vector by byte-vector
This commit is contained in:
parent
582d032c53
commit
68138a2b58
|
@ -61,7 +61,7 @@
|
|||
(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-code-vector buffer-size 0) 0 0)))
|
||||
(make-byte-vector buffer-size 0) 0 0)))
|
||||
(obtain-port-lock channel-port)
|
||||
(set-port-lock! p (port-lock channel-port))
|
||||
(set-port-locked?! p (port-locked? channel-port))
|
||||
|
@ -72,7 +72,7 @@
|
|||
(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-code-vector buffer-size 0) 0 buffer-size)))
|
||||
(make-byte-vector buffer-size 0) 0 buffer-size)))
|
||||
(obtain-port-lock channel-port)
|
||||
(set-port-lock! p (port-lock channel-port))
|
||||
(set-port-locked?! p (port-locked? channel-port))
|
||||
|
@ -95,12 +95,12 @@
|
|||
(define (alloc-input-fdport fd revealed)
|
||||
(make-input-port input-fdport-handler
|
||||
(make-fdport-data (make-input-fdchannel fd) revealed)
|
||||
(make-code-vector buffer-size 0) 0 0))
|
||||
(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-code-vector buffer-size 0) 0 buffer-size))
|
||||
(make-byte-vector buffer-size 0) 0 buffer-size))
|
||||
|
||||
(define (make-input-fdport fd revealed)
|
||||
(let ((p (alloc-input-fdport fd revealed)))
|
||||
|
@ -157,10 +157,10 @@
|
|||
(channel-write buffer start count (fdport-data:channel fdport*)))))
|
||||
|
||||
(define unbuffered-output-fdport-handler
|
||||
(let ((buffer (make-code-vector 1 0)))
|
||||
(let ((buffer (make-byte-vector 1 0)))
|
||||
(make-output-fdport-handler
|
||||
(lambda (fdport* char)
|
||||
(code-vector-set! buffer 0 (char->ascii char))
|
||||
(byte-vector-set! buffer 0 (char->ascii char))
|
||||
(channel-write buffer 0 1 (fdport-data:channel fdport*))))))
|
||||
|
||||
(define fdport-data port-data)
|
||||
|
@ -196,8 +196,8 @@
|
|||
(cond ((eq? policy 'bufpol/none)
|
||||
(install-nullbuffer port unbuffered-output-fdport-handler))
|
||||
((eq? policy 'bufpol/block)
|
||||
(let ((old-size (code-vector-length (port-buffer port)))
|
||||
(new-buffer (make-code-vector size 0)))
|
||||
(let ((old-size (byte-vector-length (port-buffer port)))
|
||||
(new-buffer (make-byte-vector size 0)))
|
||||
(if (< size old-size)
|
||||
(begin
|
||||
(really-force-output port)
|
||||
|
@ -217,7 +217,7 @@
|
|||
(obtain-port-lock port)
|
||||
(set-port-limit! port 0)
|
||||
(set-port-index! port 0)
|
||||
(set-port-buffer! port (make-code-vector 0 0))
|
||||
(set-port-buffer! port (make-byte-vector 0 0))
|
||||
(set-port-handler! port handler)
|
||||
(release-port-lock port))
|
||||
|
||||
|
@ -231,7 +231,7 @@
|
|||
;;; This port can ONLY be flushed with a newline or a close-output
|
||||
;;; flush-output won't help
|
||||
(define (make-line-output-proc size)
|
||||
(let ((proc-buffer (make-code-vector size 0))
|
||||
(let ((proc-buffer (make-byte-vector size 0))
|
||||
(proc-buffer-index 0))
|
||||
(make-port-handler
|
||||
(lambda (fdport*)
|
||||
|
@ -243,7 +243,7 @@
|
|||
(fdport-data:channel fdport*))
|
||||
(close-fdport* fdport*))
|
||||
(lambda (fdport* char)
|
||||
(code-vector-set! proc-buffer proc-buffer-index (char->ascii char))
|
||||
(byte-vector-set! proc-buffer proc-buffer-index (char->ascii char))
|
||||
(set! proc-buffer-index (+ proc-buffer-index 1))
|
||||
(cond ((or (eq? char #\newline) (= proc-buffer-index size))
|
||||
(channel-write proc-buffer
|
||||
|
@ -262,8 +262,7 @@
|
|||
(if (<= size 0) (error "size must be at least 1"))
|
||||
(install-input-handler port input-fdport-handler size #t))
|
||||
((eq? policy 'bufpol/line)
|
||||
(if (<= size 0) (error "size must be at least 1"))
|
||||
(install-input-handler port line-input-handler size #t))
|
||||
(error "bufpol/line not allowed on input"))
|
||||
(else (warn "policy not supported " policy))))
|
||||
|
||||
(define (install-input-handler port new-handler size gentle?)
|
||||
|
@ -274,11 +273,11 @@
|
|||
(old-unread (- old-limit old-index))
|
||||
(new-unread (min old-unread size))
|
||||
(throw-away (max 0 (- old-unread new-unread)))
|
||||
(new-buffer (make-code-vector size 0)))
|
||||
(new-buffer (make-byte-vector size 0)))
|
||||
(if (not gentle?)
|
||||
(let ((ret (if (> throw-away 0)
|
||||
(let ((return-buffer
|
||||
(make-code-vector throw-away 0)))
|
||||
(make-byte-vector throw-away 0)))
|
||||
(copy-bytes! old-buffer old-index
|
||||
return-buffer 0
|
||||
throw-away) return-buffer)
|
||||
|
@ -313,19 +312,19 @@
|
|||
;;; TODO: This reference to port will prevent gc !!!
|
||||
(define (make-drain-port-handler
|
||||
very-old-buffer old-start old-limit port new-handler)
|
||||
(let ((old-buffer (make-code-vector old-limit 0)))
|
||||
(let ((old-buffer (make-byte-vector old-limit 0)))
|
||||
(copy-bytes! very-old-buffer 0 old-buffer 0 old-limit)
|
||||
(make-input-fdport-handler
|
||||
(lambda (data buffer start needed)
|
||||
(let ((old-left (- (code-vector-length old-buffer) old-start)))
|
||||
(let ((old-left (- (byte-vector-length old-buffer) old-start)))
|
||||
(let ((size (cond ((or (eq? needed 'any) (eq? needed 'immediate))
|
||||
(min old-left
|
||||
(code-vector-length buffer)))
|
||||
(byte-vector-length buffer)))
|
||||
(else (min needed old-left)))))
|
||||
(copy-bytes! old-buffer old-start buffer start size)
|
||||
(set! old-start (+ size old-start))
|
||||
|
||||
(if (= old-start (code-vector-length old-buffer)) ;buffer drained ?
|
||||
(if (= old-start (byte-vector-length old-buffer)) ;buffer drained ?
|
||||
(begin
|
||||
(set-port-handler! port new-handler)
|
||||
(if (and (integer? needed) (> needed size))
|
||||
|
@ -334,38 +333,7 @@
|
|||
size))
|
||||
size)))))))
|
||||
|
||||
(define line-input-handler
|
||||
(make-input-fdport-handler
|
||||
(lambda (fdport* buffer start needed)
|
||||
(read-until-newline fdport* buffer start needed 0))))
|
||||
|
||||
(define newline-ascii (char->ascii #\newline))
|
||||
|
||||
(define (read-until-newline fdport* buffer start needed counter)
|
||||
(let ((channel-needed (if (eq? needed 'immediate) needed 1)))
|
||||
(let ((read (channel-read buffer
|
||||
start
|
||||
channel-needed
|
||||
(fdport-data:channel fdport*))))
|
||||
(if (= 0 read)
|
||||
counter
|
||||
(begin
|
||||
(set! counter (+ counter 1))
|
||||
(if (or (and (code-vector? buffer)
|
||||
(= newline-ascii (code-vector-ref buffer start)))
|
||||
(and (string? buffer)
|
||||
(eq? #\newline (string-ref buffer start)))
|
||||
(and (number? needed) (= needed counter))
|
||||
(and (eq? needed 'any) (= (+ start 1) (buffer-length buffer))))
|
||||
counter
|
||||
(read-until-newline fdport* buffer
|
||||
(+ start 1)
|
||||
needed
|
||||
counter)))))))
|
||||
(define (buffer-length buffer)
|
||||
(if (string? buffer)
|
||||
(string-length buffer)
|
||||
(code-vector-length buffer)))
|
||||
;;; Open & Close
|
||||
;;; ------------
|
||||
|
||||
|
|
Loading…
Reference in New Issue