removed bufpol/line for input, replaced code-vector by byte-vector

This commit is contained in:
marting 1999-11-02 22:41:05 +00:00
parent 582d032c53
commit 68138a2b58
1 changed files with 18 additions and 50 deletions

View File

@ -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
;;; ------------