suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add newline handling to reencode-input/output-port; provide a streamlined path for custom-port buffering (via pipes); fix JIT bug related to updating the runstack pointer after a call that turns out to be a direct-native call

Browse Source 
svn: r8851
This commit is contained in:
Matthew Flatt 2008-03-02 16:00:12 +00:00
parent 28ddd158f6
commit b3476706ec
14 changed files with 636 additions and 171 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

351
collects/mzlib/port.ss
View File

@ -113,13 +113,15 @@
;; Not kill-safe. ;; Not kill-safe.
;; If the `read' proc returns an event, the event must produce ;; If the `read' proc returns an event, the event must produce
;; 0 always ;; 0 always (which implies that the `read' proc must not return
;; a pipe input port).
(define make-input-port/read-to-peek (define make-input-port/read-to-peek
(opt-lambda (name read fast-peek close (opt-lambda (name read fast-peek close
[location-proc #f] [location-proc #f]
[count-lines!-proc void] [count-lines!-proc void]
[init-position 1] [init-position 1]
[buffer-mode-proc #f]) [buffer-mode-proc #f]
[buffering? #f])
(define lock-semaphore (make-semaphore 1)) (define lock-semaphore (make-semaphore 1))
(define commit-semaphore (make-semaphore 1)) (define commit-semaphore (make-semaphore 1))
(define-values (peeked-r peeked-w) (make-pipe)) (define-values (peeked-r peeked-w) (make-pipe))
@ -143,6 +145,11 @@
(thread-resume manager-th (current-thread)) (thread-resume manager-th (current-thread))
(dynamic-wind suspend-manager thunk resume-manager)) (dynamic-wind suspend-manager thunk resume-manager))
(define (make-progress) (define (make-progress)
;; We dont worry about this byte getting picked up directly
;; from peeked-r, because the pipe must have been empty when
;; we grabed the lock, and since we've grabbed the lock,
;; no other thread could have re-returned the pipe behind
;; our back.
(write-byte 0 peeked-w) (write-byte 0 peeked-w)
(read-byte peeked-r)) (read-byte peeked-r))
(define (read-it-with-lock s) (define (read-it-with-lock s)
@ -157,14 +164,25 @@
s)) s))
(define (do-read-it s) (define (do-read-it s)
(if (byte-ready? peeked-r) (if (byte-ready? peeked-r)
(read-bytes-avail!* s peeked-r) peeked-r
;; If nothing is saved from a peeking read, ;; If nothing is saved from a peeking read,
;; dispatch to `read', otherwise return ;; dispatch to `read', otherwise return
;; previously peeked data ;; previously peeked data
(cond (cond
[(null? special-peeked) [(null? special-peeked)
(when progress-requested? (make-progress)) (when progress-requested? (make-progress))
(read s)] (if (and buffering?
((bytes-length s) . < . 10))
;; Buffering is enabled, so read more to move things
;; along:
(let ([r (read buf)])
(if (and (number? r) (positive? r))
(begin
(write-bytes buf peeked-w 0 r)
peeked-r)
r))
;; Just read requested amount:
(read s))]
[else (if (bytes? (mcar special-peeked)) [else (if (bytes? (mcar special-peeked))
(let ([b (mcar special-peeked)]) (let ([b (mcar special-peeked)])
(write-bytes b peeked-w) (write-bytes b peeked-w)
@ -205,13 +223,17 @@
;; Empty special queue, so read through the original proc. ;; Empty special queue, so read through the original proc.
;; We only only need ;; We only only need
;; (- (+ skip (bytes-length s)) (pipe-content-length peeked-w)) ;; (- (+ skip (bytes-length s)) (pipe-content-length peeked-w))
;; bytes, but read more (up to size of buf) to help move ;; bytes, but if buffering is enabled, read more (up to size of
;; things along. ;; buf) to help move things along.
(let* ([r (read buf)]) (let* ([dest (if buffering?
buf
(make-bytes (- (+ skip (bytes-length s))
(pipe-content-length peeked-w))))]
[r (read dest)])
(cond (cond
[(number? r) [(number? r)
;; The nice case --- reading gave us more bytes ;; The nice case --- reading gave us more bytes
(write-bytes buf peeked-w 0 r) (write-bytes dest peeked-w 0 r)
;; Now try again ;; Now try again
(peek-bytes-avail!* s skip #f peeked-r)] (peek-bytes-avail!* s skip #f peeked-r)]
[(evt? r) [(evt? r)
@ -427,7 +449,12 @@
location-proc location-proc
count-lines!-proc count-lines!-proc
init-position init-position
buffer-mode-proc))) (and buffer-mode-proc
(case-lambda
[() (buffer-mode-proc)]
[(mode)
(set! buffering? (eq? mode 'block))
(buffer-mode-proc mode)])))))
(define peeking-input-port (define peeking-input-port
(opt-lambda (orig-in [name (object-name orig-in)] [delta 0]) (opt-lambda (orig-in [name (object-name orig-in)] [delta 0])
@ -1154,9 +1181,123 @@
;; -------------------------------------------------- ;; --------------------------------------------------
;; Helper for reencode-input-port: simulate the composition
;; of a CRLF/CRNEL/NEL/LS -> LF decoding and some other
;; decoding.
;; The "converter" `c' is (mcons converter saved), where
;; saved is #f if no byte is saved, otherwise it's a saved
;; byte. It would be nicer and closer to the `bytes-convert'
;; interface to not consume a trailing CR, but we don't
;; know the inner encoding, and so we can't rewind it.
(define (bytes-convert/post-nl c buf buf-start buf-end dest)
(cond
[(and (mcdr c) (= buf-start buf-end))
;; No more bytes to convert; provide single
;; saved byte if it's not #\return, other report 'aborts
(if (eq? (mcdr c) (char->integer #\return))
(values 0 0 'aborts)
(begin
(bytes-set! dest 0 (mcdr c))
(set-mcdr! c #f)
(values 1 0 'complete)))]
[(and (mcdr c) (= 1 (bytes-length dest)))
;; We have a saved byte, but the destination is only 1 byte.
;; If the saved byte is a return, we need to try decoding more,
;; which means we may end up saving a non-#\return byte:
(if (eq? (mcdr c) (char->integer #\return))
(let-values ([(got-c used-c status)
(bytes-convert (mcar c) buf buf-start buf-end dest)])
(if (positive? got-c)
(cond
[(eq? (bytes-ref dest 0) (char->integer #\newline))
;; Found CRLF, so just produce LF (and nothing to save)
(set-mcdr! c #f)
(values 1 used-c status)]
[else
;; Next char fits in a byte, so it isn't NEL, etc.
;; Save it, and for now return the #\return.
(set-mcdr! c (bytes-ref dest 0))
(bytes-set! dest 0 (char->integer #\newline))
(values 1 used-c 'continues)])
;; Didn't decode any more; ask for bigger input, etc.
(values 0 0 status)))
;; Saved a non-#\return, so use that up now.
(begin
(bytes-set! dest 0 (mcdr c))
(set-mcdr! c #f)
(values 1 0 'continues)))]
[else
;; Normal convert, maybe prefixed:
(let-values ([(got-c used-c status)
(bytes-convert (mcar c) buf buf-start buf-end dest
(if (mcdr c) 1 0))])
(let* ([got-c (if (mcdr c)
;; Insert saved character:
(begin
(bytes-set! dest 0 (char->integer #\return))
(set-mcdr! c #f)
(add1 got-c))
got-c)]
[got-c (if (and (positive? got-c)
(eq? (bytes-ref dest (sub1 got-c)) (char->integer #\return))
(not (eq? status 'error)))
;; Save trailing carriage return:
(begin
(set-mcdr! c (char->integer #\return))
(sub1 got-c))
got-c)])
;; Iterate through the converted bytes to apply the newline conversions:
(let loop ([i 0]
[j 0])
(cond
[(= i got-c)
(values (- got-c (- i j)) used-c (if (and (eq? 'complete status)
(mcdr c))
'aborts
status))]
[(eq? (bytes-ref dest i) (char->integer #\return))
(cond
[(= (add1 i) got-c)
;; Found lone CR:
(bytes-set! dest j (char->integer #\newline))
(loop (add1 i) (add1 j))]
[(eq? (bytes-ref dest (add1 i)) (char->integer #\newline))
;; Found CRLF:
(bytes-set! dest j (char->integer #\newline))
(loop (+ i 2) (add1 j))]
[(and (eq? (bytes-ref dest (add1 i)) #o302)
(eq? (bytes-ref dest (+ i 2)) #o205))
;; Found CRNEL:
(bytes-set! dest j (char->integer #\newline))
(loop (+ i 3) (add1 j))]
[else
;; Found lone CR:
(bytes-set! dest j (char->integer #\newline))
(loop (add1 i) (add1 j))])]
[(and (eq? (bytes-ref dest i) #o302)
(eq? (bytes-ref dest (+ i 1)) #o205))
;; Found NEL:
(bytes-set! dest j (char->integer #\newline))
(loop (+ i 2) (add1 j))]
[(and (eq? (bytes-ref dest i) #o342)
(eq? (bytes-ref dest (+ i 1)) #o200)
(eq? (bytes-ref dest (+ i 2)) #o250))
;; Found LS:
(bytes-set! dest j (char->integer #\newline))
(loop (+ i 3) (add1 j))]
[else
;; Anything else:
(unless (= i j)
(bytes-set! dest j (bytes-ref dest i)))
(loop (add1 i) (add1 j))]))))]))
(define reencode-input-port (define reencode-input-port
(opt-lambda (port encoding [error-bytes #f] [close? #f] [name (object-name port)]) (opt-lambda (port encoding [error-bytes #f] [close? #f] [name (object-name port)]
(let ([c (bytes-open-converter encoding "UTF-8")] [newline-convert? #f])
(let ([c (let ([c (bytes-open-converter encoding "UTF-8")])
(if newline-convert?
(mcons c #f)
c))]
[ready-bytes (make-bytes 1024)] [ready-bytes (make-bytes 1024)]
[ready-start 0] [ready-start 0]
[ready-end 0] [ready-end 0]
@ -1181,20 +1322,33 @@
;; Try converting already-read bytes: ;; Try converting already-read bytes:
(let-values ([(got-c used-c status) (if (= buf-start buf-end) (let-values ([(got-c used-c status) (if (= buf-start buf-end)
(values 0 0 'aborts) (values 0 0 'aborts)
(bytes-convert c buf buf-start buf-end s))]) ((if newline-convert?
bytes-convert/post-nl
bytes-convert)
c buf buf-start buf-end s))])
(when (positive? used-c)
(set! buf-start (+ used-c buf-start)))
(cond (cond
[(positive? got-c) [(positive? got-c)
;; We converted some bytes into s. ;; We converted some bytes into s.
(set! buf-start (+ used-c buf-start))
got-c] got-c]
[(eq? status 'aborts) [(eq? status 'aborts)
(if buf-eof? (if buf-eof?
;; Had an EOF or special in the stream. ;; Had an EOF or special in the stream.
(if (= buf-start buf-end) (if (= buf-start buf-end)
(if (and newline-convert? (mcdr c)) ; should be bytes-convert-end
;; Have leftover CR:
(begin
(bytes-set! s 0 (if (eq? (mcdr c) (char->integer #\return))
(char->integer #\newline)
(mcdr c)))
(set-mcdr! c #f)
1)
;; Return EOF:
(begin0 (begin0
buf-eof-result buf-eof-result
(set! buf-eof? #f) (set! buf-eof? #f)
(set! buf-eof-result #f)) (set! buf-eof-result #f)))
(handle-error s)) (handle-error s))
;; Need more bytes. ;; Need more bytes.
(begin (begin
@ -1227,7 +1381,10 @@
[(eq? status 'continues) [(eq? status 'continues)
;; Need more room to make progress at all. ;; Need more room to make progress at all.
;; Decode into ready-bytes. ;; Decode into ready-bytes.
(let-values ([(got-c used-c status) (bytes-convert c buf buf-start buf-end ready-bytes)]) (let-values ([(got-c used-c status) ((if newline-convert?
bytes-convert/post-nl
bytes-convert)
c buf buf-start buf-end ready-bytes)])
(unless (memq status '(continues complete)) (unless (memq status '(continues complete))
(error 'reencode-input-port-read (error 'reencode-input-port-read
"unable to make decoding progress: ~e" "unable to make decoding progress: ~e"
@ -1267,16 +1424,20 @@
(lambda () (lambda ()
(when close? (when close?
(close-input-port port)) (close-input-port port))
(bytes-close-converter c)) (bytes-close-converter (if newline-convert?
(mcar c)
c)))
#f void 1 #f void 1
(case-lambda (case-lambda
[() buffer-mode] [() buffer-mode]
[(mode) (set! buffer-mode mode)]))))) [(mode) (set! buffer-mode mode)])
(eq? buffer-mode 'block)))))
;; -------------------------------------------------- ;; --------------------------------------------------
(define reencode-output-port (define reencode-output-port
(opt-lambda (port encoding [error-bytes #f] [close? #f] [name (object-name port)]) (opt-lambda (port encoding [error-bytes #f] [close? #f] [name (object-name port)]
[convert-newlines-to #f])
(let ([c (bytes-open-converter "UTF-8" encoding)] (let ([c (bytes-open-converter "UTF-8" encoding)]
[ready-bytes (make-bytes 1024)] [ready-bytes (make-bytes 1024)]
[ready-start 0] [ready-start 0]
@ -1285,7 +1446,10 @@
[out-start 0] [out-start 0]
[out-end 0] [out-end 0]
[buffer-mode (or (file-stream-buffer-mode port) [buffer-mode (or (file-stream-buffer-mode port)
'block)]) 'block)]
[debuffer-buf #f]
[newline-buffer #f])
(define-values (buffered-r buffered-w) (make-pipe 4096))
;; The main writing entry point: ;; The main writing entry point:
(define (write-it s start end no-buffer&block? enable-break?) (define (write-it s start end no-buffer&block? enable-break?)
@ -1294,6 +1458,7 @@
;; This is a flush request; no-buffer&block? must be #f ;; This is a flush request; no-buffer&block? must be #f
;; Note: we could get stuck because only half an encoding ;; Note: we could get stuck because only half an encoding
;; is available in out-bytes. ;; is available in out-bytes.
(flush-buffer-pipe #f enable-break?)
(flush-some #f enable-break?) (flush-some #f enable-break?)
(if (buffer-flushed?) (if (buffer-flushed?)
0 0
@ -1317,32 +1482,98 @@
(set! out-start 0) (set! out-start 0)
(set! out-end 0) (set! out-end 0)
(- c out-len)))))])] (- c out-len)))))])]
[(and (eq? buffer-mode 'block)
(zero? (pipe-content-length buffered-r)))
;; The port system can buffer to a pipe faster, so give it a pipe.
buffered-w]
[else [else
(when (or (> ready-end ready-start) ;; Flush/buffer from pipe, first:
(< (- (bytes-length out-bytes) out-end) 100)) (flush-buffer-pipe #f enable-break?)
;; Make room for conversion. ;; Flush as needed to make room in the buffer:
(flush-some #f enable-break?) ;; convert some (make-buffer-room #f enable-break?)
(flush-some #f enable-break?)) ;; write converted
;; Make room in buffer
(when (positive? out-start)
(bytes-copy! out-bytes 0 out-bytes out-start out-end)
(set! out-end (- out-end out-start))
(set! out-start 0))
;; Buffer some bytes: ;; Buffer some bytes:
(let ([cnt (min (- end start) (let-values ([(s2 start2 cnt2 used) (convert-newlines s start
(- end start)
(- (bytes-length out-bytes) out-end))]) (- (bytes-length out-bytes) out-end))])
(if (zero? cnt) (if (zero? used)
;; No room --- try flushing again: ;; No room --- try flushing again:
(write-it s start end #f enable-break?) (write-it s start end #f enable-break?)
;; Buffer and report success: ;; Buffer and report success:
(begin (begin
(bytes-copy! out-bytes out-end s start (+ start cnt)) (bytes-copy! out-bytes out-end s2 start2 (+ start2 cnt2))
(set! out-end (+ cnt out-end)) (set! out-end (+ cnt2 out-end))
(case buffer-mode (case buffer-mode
[(none) (flush-all-now enable-break?)] [(none) (flush-all-now enable-break?)]
[(line) (when (regexp-match-positions #rx#"[\r\n]" s start (+ start cnt)) [(line) (when (regexp-match-positions #rx#"[\r\n]" s start (+ start used))
(flush-all-now enable-break?))]) (flush-all-now enable-break?))])
cnt)))])) used)))]))
(define (convert-newlines s start cnt avail)
;; If newline converting is on, try convert up to cnt
;; bytes to produce a result that fits in avail bytes.
(if convert-newlines-to
;; Conversion:
(let ([end (+ start cnt)]
[avail (min avail 1024)])
(unless newline-buffer
(set! newline-buffer (make-bytes 1024)))
(let loop ([i start][j 0])
(cond
[(or (= j avail) (= i end)) (values newline-buffer 0 j i)]
[(eq? (char->integer #\newline) (bytes-ref s i))
;; Newline conversion
(let ([len (bytes-length convert-newlines-to)])
(if ((+ j len) . > . avail)
;; No room
(values newline-buffer 0 j i)
;; Room
(begin
(bytes-copy! newline-buffer j convert-newlines-to)
(loop (add1 i) (+ j len)))))]
[else
(bytes-set! newline-buffer j (bytes-ref s i))
(loop (add1 i) (add1 j))])))
;; No conversion:
(let ([cnt (min cnt avail)])
(values s start cnt cnt))))
(define (make-buffer-room non-block? enable-break?)
(when (or (> ready-end ready-start)
(< (- (bytes-length out-bytes) out-end) 100))
;; Make room for conversion.
(flush-some non-block? enable-break?) ;; convert some
(flush-some non-block? enable-break?)) ;; write converted
;; Make room in buffer
(when (positive? out-start)
(bytes-copy! out-bytes 0 out-bytes out-start out-end)
(set! out-end (- out-end out-start))
(set! out-start 0)))
(define (flush-buffer-pipe non-block? enable-break?)
(let loop ()
(if (zero? (pipe-content-length buffered-r))
'done
(begin
(unless debuffer-buf
(set! debuffer-buf (make-bytes 4096)))
(make-buffer-room non-block? enable-break?)
(let ([amt (- (bytes-length out-bytes) out-end)])
(if (zero? amt)
'stuck
(if convert-newlines-to
;; Peek, convert newlines, write, then read converted amount:
(let ([cnt (peek-bytes-avail! debuffer-buf 0 #f buffered-r 0 amt)])
(let-values ([(s2 start2 cnt2 used)
(convert-newlines debuffer-buf 0 cnt amt)])
(bytes-copy! out-bytes out-end s2 start2 cnt2)
(set! out-end (+ cnt2 out-end))
(read-bytes-avail! debuffer-buf buffered-r 0 used)
(loop)))
;; Skip an indirection: read directly and write:
(let ([cnt (read-bytes-avail! debuffer-buf buffered-r 0 amt)])
(bytes-copy! out-bytes out-end debuffer-buf 0 cnt)
(set! out-end (+ cnt out-end))
(loop)))))))))
(define (non-blocking-write s start end) (define (non-blocking-write s start end)
;; For now, everything that we can flushed is flushed. ;; For now, everything that we can flushed is flushed.
@ -1351,23 +1582,32 @@
;; everyone is happy enough. If some of the bytes get written, ;; everyone is happy enough. If some of the bytes get written,
;; the we will have buffered bytes when we shouldn't have. ;; the we will have buffered bytes when we shouldn't have.
;; That probably won't happen, but we can't guarantee it. ;; That probably won't happen, but we can't guarantee it.
(if (sync/timeout 0.0 port)
;; We should be able to write one byte...
(let loop ([len 1]) (let loop ([len 1])
(let-values ([(got-c used-c status) (bytes-convert c s start (+ start len) ready-bytes)]) (let*-values ([(s2 start2 len2 used) (convert-newlines s start (- end start) len)]
[(got-c used-c status) (bytes-convert c s2 start2 (+ start2 len2) ready-bytes)])
(cond (cond
[(positive? got-c) [(positive? got-c)
(try-flush-ready got-c used-c)] (try-flush-ready got-c used-c)
;; If used-c < len2, then we converted only partially --- which
;; is strange, because we kept adding bytes one at a time.
;; we will just guess is that the unused bytes were not converted
;; bytes, and generally hope that this sort of encoding doesn't
;; show up.
(- used (- len2 used-c))]
[(eq? status 'aborts) [(eq? status 'aborts)
(if (< len (- end start)) (if (< len (- end start))
;; Try converting a bigger chunk ;; Try converting a bigger chunk
(loop (add1 len)) (loop (add1 len))
;; We can't flush half an encoding, so just buffer it. ;; We can't flush half an encoding, so just buffer it.
(let ([cnt (- start end)]) (begin
(when (> (- end start) (bytes-length out-bytes)) (when (> len2 (bytes-length out-bytes))
(raise-insane-decoding-length)) (raise-insane-decoding-length))
(bytes-copy out-bytes 0 s start end) (bytes-copy out-bytes 0 s2 start2 (+ start2 len2))
(set! out-start 0) (set! out-start 0)
(set! out-end cnt) (set! out-end len2)
cnt))] used))]
[(eq? status 'continues) [(eq? status 'continues)
;; Not enough room in ready-bytes!? We give up. ;; Not enough room in ready-bytes!? We give up.
(raise-insane-decoding-length)] (raise-insane-decoding-length)]
@ -1375,7 +1615,10 @@
;; Encoding error. Try to flush error bytes. ;; Encoding error. Try to flush error bytes.
(let ([cnt (bytes-length error-bytes)]) (let ([cnt (bytes-length error-bytes)])
(bytes-copy! ready-bytes 0 error-bytes) (bytes-copy! ready-bytes 0 error-bytes)
(try-flush-ready cnt 1))])))) (try-flush-ready cnt 1)
used)])))
;; Port is not ready for writing:
#f))
(define (write-special-it v no-buffer&block? enable-break?) (define (write-special-it v no-buffer&block? enable-break?)
(cond (cond
@ -1390,6 +1633,7 @@
[else [else
;; Note: we could get stuck because only half an encoding ;; Note: we could get stuck because only half an encoding
;; is available in out-bytes. ;; is available in out-bytes.
(flush-buffer-pipe no-buffer&block? enable-break?)
(flush-some no-buffer&block? enable-break?) (flush-some no-buffer&block? enable-break?)
(if (or (buffer-flushed?) (if (or (buffer-flushed?)
(not no-buffer&block?)) (not no-buffer&block?))
@ -1398,6 +1642,7 @@
;; flush-all : -> 'done, 'not-done, or 'stuck ;; flush-all : -> 'done, 'not-done, or 'stuck
(define (flush-all non-block? enable-break?) (define (flush-all non-block? enable-break?)
(if (eq? (flush-buffer-pipe non-block? enable-break?) 'done)
(let ([orig-none-ready? (= ready-start ready-end)] (let ([orig-none-ready? (= ready-start ready-end)]
[orig-out-start out-start] [orig-out-start out-start]
[orig-out-end out-end]) [orig-out-end out-end])
@ -1411,7 +1656,8 @@
(= orig-out-start out-start) (= orig-out-start out-start)
(= orig-out-end out-end)) (= orig-out-end out-end))
'stuck 'stuck
'not-done)))) 'not-done)))
'stuck))
(define (flush-all-now enable-break?) (define (flush-all-now enable-break?)
(case (flush-all #f enable-break?) (case (flush-all #f enable-break?)
@ -1419,20 +1665,17 @@
(define (buffer-flushed?) (define (buffer-flushed?)
(and (= ready-start ready-end) (and (= ready-start ready-end)
(= out-start out-end))) (= out-start out-end)
(zero? (pipe-content-length buffered-r))))
;; Try to flush immediately a certain number of bytes ;; Try to flush immediately a certain number of bytes.
;; we've already converted them, so we have to keep
;; the bytes in any case.
(define (try-flush-ready got-c used-c) (define (try-flush-ready got-c used-c)
(let ([c (write-bytes-avail* ready-bytes port 0 got-c)]) (let ([c (write-bytes-avail* ready-bytes port 0 got-c)])
(if (zero? c) (unless (= c got-c)
;; Didn't flush any - give up:
#f
;; Hopefully, we flushed them all, but set ready-start and ready-end,
;; just in case.
(begin
(set! ready-start c) (set! ready-start c)
(set! ready-end got-c) (set! ready-end got-c))))
used-c))))
;; Try to make progress flushing buffered bytes ;; Try to make progress flushing buffered bytes
(define (flush-some non-block? enable-break?) (define (flush-some non-block? enable-break?)

24
collects/rnrs/io/ports-6.ss
View File

@ -305,7 +305,7 @@
(define (no-op-transcoder? t) (define (no-op-transcoder? t)
(or (eq? t utf8-transcoder) (or (eq? t utf8-transcoder)
(and (eq? utf-8 (transcoder-codec t)) (and (eq? utf-8 (transcoder-codec t))
(memq (transcoder-eol-style t) '(lf none)) (eq? (transcoder-eol-style t) 'none)
(eq? 'replace (transcoder-error-handling-mode t))))) (eq? 'replace (transcoder-error-handling-mode t)))))
(define (transcode-input p t) (define (transcode-input p t)
@ -320,7 +320,9 @@
[(raise) #f] [(raise) #f]
[(ignore) #""] [(ignore) #""]
[(replace) (string->bytes/utf-8 "\uFFFD")]) [(replace) (string->bytes/utf-8 "\uFFFD")])
#t)))) #t
(object-name p)
(not (eq? (transcoder-eol-style t) 'none))))))
(define (transcode-output p t) (define (transcode-output p t)
(let ([p (cond (let ([p (cond
@ -329,7 +331,7 @@
[(binary-input/output-port? p) [(binary-input/output-port? p)
((binary-input/output-port-out-disconnect p))] ((binary-input/output-port-out-disconnect p))]
[else p])]) [else p])])
(if (eq? t utf8-transcoder) (if (no-op-transcoder? t)
p p
(reencode-output-port p (reencode-output-port p
(codec-enc (transcoder-codec t)) (codec-enc (transcoder-codec t))
@ -337,7 +339,17 @@
[(raise) #f] [(raise) #f]
[(ignore) #""] [(ignore) #""]
[(replace) (string->bytes/utf-8 "\uFFFD")]) [(replace) (string->bytes/utf-8 "\uFFFD")])
#t)))) #t
(object-name p)
(case (transcoder-eol-style t)
[(lf none) #f]
[(cr) #"\r"]
[(crlf) #"\r\n"]
[(nel) (string->bytes/utf-8 "\u85")]
[(crnel) (string->bytes/utf-8 "\r\u85")]
[(ls) (string->bytes/utf-8 "\u2028")]
[else (error 'transcoded-port "unknown eol style: ~e"
(transcoder-eol-style t))])))))
(define (transcoded-port p t) (define (transcoded-port p t)
(unless (and (port? p) (unless (and (port? p)
@ -868,10 +880,10 @@
(for ([c (in-string v)]) (for ([c (in-string v)])
(cond (cond
[(eq? c #\") (display "\\\"" p)] [(eq? c #\") (display "\\\"" p)]
[(eq? c #\\) (display "\\n" p)] [(eq? c #\\) (display "\\\\" p)]
[(char-graphic? c) (write-char c p)] [(char-graphic? c) (write-char c p)]
[(char-blank? c) (write-char c p)] [(char-blank? c) (write-char c p)]
[(eq? c #\newline) (display "\\\\" p)] [(eq? c #\newline) (display "\\n" p)]
[(eq? c #\return) (display "\\r" p)] [(eq? c #\return) (display "\\r" p)]
[else [else
(display "\\x" p) (display "\\x" p)

33
collects/rnrs/io/simple-6.ss
View File

@ -17,13 +17,13 @@
[r6rs:open-output-file open-output-file]) [r6rs:open-output-file open-output-file])
close-input-port close-input-port
close-output-port close-output-port
read-char (rename-out [r6rs:read-char read-char]
(rename-out [r6rs:peek-char peek-char] [r6rs:peek-char peek-char]
[r6rs:read read]) [r6rs:read read]
write-char [r6rs:write-char write-char]
newline [r6rs:newline newline]
display [r6rs:display display]
(rename-out [r6rs:write write])) [r6rs:write write]))
(define (r6rs:call-with-input-file file proc) (define (r6rs:call-with-input-file file proc)
(r6rs:call-with-port (r6rs:call-with-port
@ -55,12 +55,25 @@
(define (r6rs:open-output-file file) (define (r6rs:open-output-file file)
(r6rs:transcoded-port (r6rs:open-file-output-port file) (r6rs:native-transcoder))) (r6rs:transcoded-port (r6rs:open-file-output-port file) (r6rs:native-transcoder)))
(define (r6rs:peek-char [in (current-input-port)]) (define (r6rs:read-char [in (r6rs:current-input-port)])
(peek-char in)) (r6rs:get-char in))
(define (r6rs:peek-char [in (r6rs:current-input-port)])
(r6rs:lookahead-char in))
(define (r6rs:read [in (r6rs:current-input-port)]) (define (r6rs:read [in (r6rs:current-input-port)])
(r6rs:get-datum in)) (r6rs:get-datum in))
(define (r6rs:write-char ch [out (r6rs:current-output-port)])
(r6rs:put-char out ch))
(define (r6rs:newline [out (r6rs:current-output-port)])
(r6rs:put-char out #\newline))
(define (r6rs:display v [out (r6rs:current-output-port)])
(unless (r6rs:textual-port? out)
(raise-type-error 'display "textual port" out))
(display v out))
(define (r6rs:write v [out (r6rs:current-output-port)]) (define (r6rs:write v [out (r6rs:current-output-port)])
(r6rs:put-datum out v)) (r6rs:put-datum out v))

70
collects/scribblings/reference/custom-ports.scrbl
View File

@ -65,13 +65,19 @@ The arguments implement the port as follows:
@item{a procedure of arity four (representing a ``special'' @item{a procedure of arity four (representing a ``special''
result, as discussed further below) and optionally of arity zero, result, as discussed further below) and optionally of arity zero,
but a procedure result is allowed only when but a procedure result is allowed only when
@scheme[peek] is not @scheme[#f]; or} @scheme[peek] is not @scheme[#f];}
@item{a @tech{synchronizable event} (see @secref["sync"]) @item{a @techlink{pipe} input port that supplies bytes to be
that becomes ready when the read is complete (roughly): the used as long as the pipe has content (see
event's value can one of the above three results or another @scheme[pipe-content-length]) or until @scheme[read-in] or
event like itself; in the last case, a reading process loops @scheme[peek] is called again; or}
with @scheme[sync] until it gets a non-event result.}
@item{a @tech{synchronizable event} (see @secref["sync"]) other
than a pipe input port that becomes ready when the read is
complete (roughly): the event's value can one of the above three
results or another event like itself; in the last case, a
reading process loops with @scheme[sync] until it gets a
non-event result.}
} }
@ -103,6 +109,18 @@ The arguments implement the port as follows:
synchronization mechanisms might cause a non-blocking read synchronization mechanisms might cause a non-blocking read
procedure to block indefinitely. procedure to block indefinitely.
If the result is a pipe input port, then previous
@scheme[get-progress-evt] calls whose event is not yet ready must
have been the pipe input port itself. Furthermore,
@scheme[get-progress-evt] must continue to return the pipe as long
as it contains data, or until the @scheme[read-in] or
@scheme[peek-in] procedure is called again (instead of using the
pipe, for whatever reason). If @scheme[read-in] or
@scheme[peek-in] is called, any previously associated pipe (as
returned by a previous call) will have been disassociated from the
port, and is not in use by any other thread as a result of the
previous association.
If @scheme[peek], @scheme[get-progress-evt], and If @scheme[peek], @scheme[get-progress-evt], and
@scheme[commit] are all provided and @scheme[commit] are all provided and
non-@scheme[#f], then the following is an acceptable implementation non-@scheme[#f], then the following is an acceptable implementation
@ -155,7 +173,7 @@ The arguments implement the port as follows:
any values. In particular, @scheme[peek] must not peek any values. In particular, @scheme[peek] must not peek
any values if the progress event is initially ready. any values if the progress event is initially ready.
Unlike @scheme[read-proc], @scheme[peek] should produce Unlike @scheme[read-in], @scheme[peek] should produce
@scheme[#f] (or an event whose value is @scheme[#f]) if no bytes @scheme[#f] (or an event whose value is @scheme[#f]) if no bytes
were peeked because the progress event became ready. Like were peeked because the progress event became ready. Like
@scheme[read-in], a @scheme[0] result indicates that another @scheme[read-in], a @scheme[0] result indicates that another
@ -175,17 +193,18 @@ The arguments implement the port as follows:
The system does not check that multiple peeks return consistent The system does not check that multiple peeks return consistent
results, or that peeking and reading produce consistent results. results, or that peeking and reading produce consistent results.
If @scheme[peek] is @scheme[#f], then peeking for the If @scheme[peek] is @scheme[#f], then peeking for the port is
port is implemented automatically in terms of reads, but with implemented automatically in terms of reads, but with several
several limitations. First, the automatic implementation is not limitations. First, the automatic implementation is not
thread-safe. Second, the automatic implementation cannot handle thread-safe. Second, the automatic implementation cannot handle
special results (non-byte and non-eof), so @scheme[read-in] cannot special results (non-byte and non-eof), so @scheme[read-in] cannot
return a procedure for a special when @scheme[peek] is return a procedure for a special when @scheme[peek] is
@scheme[#f]. Finally, the automatic peek implementation is @scheme[#f]. Finally, the automatic peek implementation is
incompatible with progress events, so if @scheme[peek] incompatible with progress events, so if @scheme[peek] is
is @scheme[#f], then @scheme[progress-evt] and @scheme[#f], then @scheme[progress-evt] and @scheme[commit] must
@scheme[commit] must be @scheme[#f]. See also be @scheme[#f]. See also @scheme[make-input-port/peek-to-read],
@scheme[make-input-port/peek-to-read].} which implements peeking in terms of @scheme[read-in] without
these constraints.}
@item{@scheme[close] --- a procedure of zero arguments that is @item{@scheme[close] --- a procedure of zero arguments that is
called to close the port. The port is not considered closed until called to close the port. The port is not considered closed until
@ -201,7 +220,11 @@ The arguments implement the port as follows:
default), or a procedure that takes no arguments and returns an default), or a procedure that takes no arguments and returns an
event. The event must become ready only after data is next read event. The event must become ready only after data is next read
from the port or the port is closed. After the event becomes from the port or the port is closed. After the event becomes
ready, it must remain so. (See also @scheme[semaphore-peek-evt].) ready, it must remain so. See the description of @scheme[read-in]
for information about the allowed results of this function when
@scheme[read-in] returns a pipe input port. See also
@scheme[semaphore-peek-evt], which is sometimes useful for
implementing @scheme[get-progress-evt].
If @scheme[get-progress-evt] is @scheme[#f], then If @scheme[get-progress-evt] is @scheme[#f], then
@scheme[port-provides-progress-evts?] applied to the port will @scheme[port-provides-progress-evts?] applied to the port will
@ -732,9 +755,14 @@ procedures.
@item{@scheme[#f] if no bytes could be written, perhaps because @item{@scheme[#f] if no bytes could be written, perhaps because
the internal buffer could not be completely flushed;} the internal buffer could not be completely flushed;}
@item{a synchronizable event (see @secref["sync"]) that acts like @item{a @techlink{pipe} output port (when buffering is allowed
the result of @scheme[write-bytes-avail-evt] to complete the and not when flushing) for buffering bytes as long as the pipe is
write.} not full and until @scheme[write-out] or
@scheme[write-out-special] is called; or}
@item{a synchronizable event (see @secref["sync"]) other than a
pipe output port that acts like the result of
@scheme[write-bytes-avail-evt] to complete the write.}
} }
@ -761,8 +789,10 @@ procedures.
The result should never be @scheme[0] if the start and end indices The result should never be @scheme[0] if the start and end indices
are different, otherwise the @exnraise[exn:fail:contract]. are different, otherwise the @exnraise[exn:fail:contract].
If a returned integer is larger than the supplied byte-string Similarly, the @exnraise[exn:fail:contract] if @scheme[write-out]
range, the @exnraise[exn:fail:contract]. returns a pipe output port when buffering is disallowed or when it
is called for flushing. If a returned integer is larger than the
supplied byte-string range, the @exnraise[exn:fail:contract].
The @scheme[#f] result should be avoided, unless the next write The @scheme[#f] result should be avoided, unless the next write
attempt is likely to work. Otherwise, if data cannot be written, attempt is likely to work. Otherwise, if data cannot be written,

80
collects/scribblings/reference/port-lib.scrbl
View File

@ -44,7 +44,22 @@ input ports as it becomes available.}
procedure? procedure?
evt? evt?
false/c)))] false/c)))]
[close (-> any)]) [close (-> any)]
[get-location (or/c
(()
. ->* .
((or/c positive-exact-integer? false/c)
(or/c nonnegative-exact-integer? false/c)
(or/c positive-exact-integer? false/c)))
false/c)
#f]
[count-lines! (-> any) void]
[init-position positive-exact-integer? 1]
[buffer-mode (or/c (case-> ((one-of/c 'block 'none) . -> . any)
(-> (one-of/c 'block 'none #f)))
false/c)
#f]
[buffering? any/c #f])
input-port?]{ input-port?]{
Similar to @scheme[make-input-port], but if the given @scheme[read-in] Similar to @scheme[make-input-port], but if the given @scheme[read-in]
@ -56,14 +71,24 @@ automatically. The resulting port is thread-safe, but not kill-safe
(i.e., if a thread is terminated or suspended while using the port, (i.e., if a thread is terminated or suspended while using the port,
the port may become damaged). the port may become damaged).
The @scheme[read-in] and @scheme[close] procedures are the same as for The @scheme[read-in], @scheme[close], @scheme[get-lcoation],
@scheme[make-input-port]. The @scheme[fast-peek] argument can be @scheme[count-lines!], @scheme[init-position], and
either @scheme[#f] or a procedure of three arguments: a byte string to @scheme[buffer-mode] procedures are the same as for
receive a peek, a skip count, and a procedure of two arguments. The @scheme[make-input-port].
@scheme[fast-peek] procedure can either implement the requested peek,
or it can dispatch to its third argument to implement the peek. The The @scheme[fast-peek] argument can be either @scheme[#f] or a
@scheme[fast-peek] is not used when a peek request has an associated procedure of three arguments: a byte string to receive a peek, a skip
progress event.} count, and a procedure of two arguments. The @scheme[fast-peek]
procedure can either implement the requested peek, or it can dispatch
to its third argument to implement the peek. The @scheme[fast-peek] is
not used when a peek request has an associated progress event.
The @scheme[buffering?] argument determines whether @scheme[read-in]
can be called to read more characters than are immediately demanded by
the user of the new port. If @scheme[buffer] mode is not @scheme[#f],
then @scheme[buffering?] determines the initial buffer mode, and
@scheme[buffering?] is enabled after a buffering change only if the
new mode is @scheme['block].}
@defproc[(make-limited-input-port [in input-port?] @defproc[(make-limited-input-port [in input-port?]
@ -162,12 +187,16 @@ it defaults to @scheme[0].}
[encoding string?] [encoding string?]
[error-bytes (or/c false/c bytes?)] [error-bytes (or/c false/c bytes?)]
[close? any/c #t] [close? any/c #t]
[name any/c (object-name in)]) [name any/c (object-name in)]
[convert-newlines? any/c #f])
input-port?]{ input-port?]{
Produces an input port that draws bytes from @scheme[in], but converts Produces an input port that draws bytes from @scheme[in], but converts
the byte stream using @scheme[(bytes-open-converter encoding-str the byte stream using @scheme[(bytes-open-converter encoding-str
"UTF-8")]. "UTF-8")]. In addition, if @scheme[convert-newlines?] is true, then
decoded sequences that correspond to UTF-8 encodings of @scheme["\r\n"],
@scheme["\r\x85"], @scheme["\r"], @scheme["\x85"], and @scheme["\u2028"]
are all converted to the UTF-8 encoding of @scheme["\n"].
If @scheme[error-bytes] is provided and not @scheme[#f], then the If @scheme[error-bytes] is provided and not @scheme[#f], then the
given byte sequence is used in place of bytes from @scheme[in] that given byte sequence is used in place of bytes from @scheme[in] that
@ -191,15 +220,16 @@ incomplete encoding sequence.)}
[error-bytes (or/c false/c bytes?)] [error-bytes (or/c false/c bytes?)]
[close? any/c #t] [close? any/c #t]
[name any/c (object-name out)] [name any/c (object-name out)]
[buffer (one-of/c 'block 'line 'none) [newline-bytes (or/c false/c bytes?) #f])
(if (file-stream-port? out)
(file-stream-buffer-mode out)
'block)])
output-port?]{ output-port?]{
Produces an output port that directs bytes to @scheme[out], but Produces an output port that directs bytes to @scheme[out], but
converts its byte stream using @scheme[(bytes-open-converter converts its byte stream using @scheme[(bytes-open-converter "UTF-8"
encoding-str "UTF-8")]. encoding-str)]. In addition, if @scheme[newline-bytes] is not
@scheme[#f], then byets written to the port that are the UTF-8
encoding of @scheme["\n"] are first converted to
@scheme[newline-bytes] (before applying the convert from UTF-8 to
@scheme[encoding-str]).
If @scheme[error-bytes] is provided and not @scheme[#f], then the If @scheme[error-bytes] is provided and not @scheme[#f], then the
given byte sequence is used in place of bytes send to the output port given byte sequence is used in place of bytes send to the output port
@ -210,14 +240,14 @@ If @scheme[close?] is true, then closing the result output port also
closes @scheme[out]. The @scheme[name] argument is used as the name of closes @scheme[out]. The @scheme[name] argument is used as the name of
the result output port. the result output port.
The @scheme[buffer] argument determines the buffer mode of the output The resulting port supports buffering, and the initial buffer mode is
port. In @scheme['block] mode, the port's buffer is flushed only when @scheme[(or (file-stream-buffer-mode out) 'block)]. In @scheme['block]
it is full or a flush is requested explicitly. In @scheme['line] mode, mode, the port's buffer is flushed only when it is full or a flush is
the buffer is flushed whenever a newline or carriage-return byte is requested explicitly. In @scheme['line] mode, the buffer is flushed
written to the port. In @scheme['none] mode, the port's buffer is whenever a newline or carriage-return byte is written to the port. In
flushed after every write. Implicit flushes for @scheme['line] or @scheme['none] mode, the port's buffer is flushed after every write.
@scheme['none] leave bytes in the buffer when they are part of an Implicit flushes for @scheme['line] or @scheme['none] leave bytes in
incomplete encoding sequence. the buffer when they are part of an incomplete encoding sequence.
The resulting output port does not support atomic writes. An explicit The resulting output port does not support atomic writes. An explicit
flush or special-write to the output port can hang if the most flush or special-write to the output port can hang if the most

33
collects/tests/mzscheme/portlib.ss
View File

@ -530,6 +530,37 @@
(try-eip-seq "UTF-8" #f #"ap\251ple" `((#t 3 #"ap.") (#f 1 #"p") (#t 4 #"!le") (#t 5 ,eof))) (try-eip-seq "UTF-8" #f #"ap\251ple" `((#t 3 #"ap.") (#f 1 #"p") (#t 4 #"!le") (#t 5 ,eof)))
(try-eip-seq "UTF-8" #f #"ap\251ple" `((#t 4 #"ap.!") (#f 1 #"l") (#t 4 #"pe") (#t 5 ,eof))) (try-eip-seq "UTF-8" #f #"ap\251ple" `((#t 4 #"ap.!") (#f 1 #"l") (#t 4 #"pe") (#t 5 ,eof)))
(let ([try (lambda (s s2)
(let ([mk (lambda ()
(reencode-input-port (open-input-string s) "UTF-8" #f #f 'test #t))])
(let ([p (mk)])
(for ([c (in-string s2)])
(test c read-char p))
(test eof read-char p))
(let ([p (mk)])
(test s2 read-string (add1 (string-length s2)) p))
(when ((string-length s2) . > . 2)
(test (substring s2 0 2) read-string 2 (mk)))
(let-values ([(r w) (make-pipe-with-specials)])
(display s w)
(write-special 'x w)
(display s w)
(close-output-port w)
(let ([p (reencode-input-port r "UTF-8" #f #f 'test #t)])
(test s2 read-string (string-length s2) p)
(test 'x read-char-or-special p)
(test s2 read-string (string-length s2) p)
(test eof read-char-or-special p)))))])
(for-each (lambda (cr)
(try cr "\n")
(try (format "a~a" cr) "a\n")
(try (format "a~a12" cr) "a\n12")
(try (format "~a12" cr) "\n12")
(try (format "a\n~a12" cr) "a\n\n12")
(try (format "a~a\r12" cr) "a\n\n12"))
'("\n" "\r" "\r\n" "\x85" "\r\x85" "\u2028"))
(try "a\u2028\r\n12" "a\n\n12"))
(let-values ([(in out) (make-pipe-with-specials)]) (let-values ([(in out) (make-pipe-with-specials)])
(display "ok" out) (display "ok" out)
(write-special 'special! out) (write-special 'special! out)
@ -549,7 +580,7 @@
(test 3 write-bytes #"abc" w2) (test 3 write-bytes #"abc" w2)
(test 0 read-bytes-avail!* (make-bytes 10) r) (test 0 read-bytes-avail!* (make-bytes 10) r)
(test 1 write-bytes-avail #"wx" w2) (test 1 write-bytes-avail #"wx" w2) ; implementation converts minimal prefix
(test #"abcw" read-bytes 4 r) (test #"abcw" read-bytes 4 r)
;; Check encoding error ;; Check encoding error

16
src/mzscheme/src/jit.c
View File

@ -2456,14 +2456,20 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
(void)jit_calli(code); (void)jit_calli(code);
/* Whether we call a prim, a native, or something else, if (direct_prim) {
scheme_current_runstack is up-to-date --- unless if (num_rands == 1) {
it was a direct-prim call with 1 argument. */ /* Popped single argument after return of prim: */
if (direct_prim && (num_rands == 1))
jitter->need_set_rs = 1; jitter->need_set_rs = 1;
else } else {
/* Runstack is up-to-date: */
jitter->need_set_rs = 0; jitter->need_set_rs = 0;
} }
} else {
/* Otherwise, we may have called native code, which may have left
the runstack register out of sync with scheme_current_runstack. */
jitter->need_set_rs = 1;
}
}
} }
END_JIT_DATA(need_non_tail ? 22 : 4); END_JIT_DATA(need_non_tail ? 22 : 4);

4
src/mzscheme/src/mzmark.c
View File

@ -3155,6 +3155,7 @@ static int mark_user_input_MARK(void *p) {
gcMARK(uip->close_proc); gcMARK(uip->close_proc);
gcMARK(uip->reuse_str); gcMARK(uip->reuse_str);
gcMARK(uip->peeked); gcMARK(uip->peeked);
gcMARK(uip->prefix_pipe);
return return
gcBYTES_TO_WORDS(sizeof(User_Input_Port)); gcBYTES_TO_WORDS(sizeof(User_Input_Port));
} }
@ -3172,6 +3173,7 @@ static int mark_user_input_FIXUP(void *p) {
gcFIXUP(uip->close_proc); gcFIXUP(uip->close_proc);
gcFIXUP(uip->reuse_str); gcFIXUP(uip->reuse_str);
gcFIXUP(uip->peeked); gcFIXUP(uip->peeked);
gcFIXUP(uip->prefix_pipe);
return return
gcBYTES_TO_WORDS(sizeof(User_Input_Port)); gcBYTES_TO_WORDS(sizeof(User_Input_Port));
} }
@ -3197,6 +3199,7 @@ static int mark_user_output_MARK(void *p) {
gcMARK(uop->count_lines_proc); gcMARK(uop->count_lines_proc);
gcMARK(uop->buffer_mode_proc); gcMARK(uop->buffer_mode_proc);
gcMARK(uop->close_proc); gcMARK(uop->close_proc);
gcMARK(uop->buffer_pipe);
return return
gcBYTES_TO_WORDS(sizeof(User_Output_Port)); gcBYTES_TO_WORDS(sizeof(User_Output_Port));
} }
@ -3213,6 +3216,7 @@ static int mark_user_output_FIXUP(void *p) {
gcFIXUP(uop->count_lines_proc); gcFIXUP(uop->count_lines_proc);
gcFIXUP(uop->buffer_mode_proc); gcFIXUP(uop->buffer_mode_proc);
gcFIXUP(uop->close_proc); gcFIXUP(uop->close_proc);
gcFIXUP(uop->buffer_pipe);
return return
gcBYTES_TO_WORDS(sizeof(User_Output_Port)); gcBYTES_TO_WORDS(sizeof(User_Output_Port));
} }

2
src/mzscheme/src/mzmarksrc.c
View File

@ -1277,6 +1277,7 @@ mark_user_input {
gcMARK(uip->close_proc); gcMARK(uip->close_proc);
gcMARK(uip->reuse_str); gcMARK(uip->reuse_str);
gcMARK(uip->peeked); gcMARK(uip->peeked);
gcMARK(uip->prefix_pipe);
size: size:
gcBYTES_TO_WORDS(sizeof(User_Input_Port)); gcBYTES_TO_WORDS(sizeof(User_Input_Port));
} }
@ -1294,6 +1295,7 @@ mark_user_output {
gcMARK(uop->count_lines_proc); gcMARK(uop->count_lines_proc);
gcMARK(uop->buffer_mode_proc); gcMARK(uop->buffer_mode_proc);
gcMARK(uop->close_proc); gcMARK(uop->close_proc);
gcMARK(uop->buffer_pipe);
size: size:
gcBYTES_TO_WORDS(sizeof(User_Output_Port)); gcBYTES_TO_WORDS(sizeof(User_Output_Port));
} }

5
src/mzscheme/src/port.c
View File

@ -1225,6 +1225,11 @@ XFORM_NONGCING static int pipe_char_count(Scheme_Object *p)
return 0; return 0;
} }
int scheme_pipe_char_count(Scheme_Object *p)
{
return pipe_char_count(p);
}
/****************************** main input reader ******************************/ /****************************** main input reader ******************************/
static void post_progress(Scheme_Input_Port *ip) static void post_progress(Scheme_Input_Port *ip)

103
src/mzscheme/src/portfun.c
View File

@ -130,6 +130,10 @@ static Scheme_Object *sch_default_write_handler(int argc, Scheme_Object *argv[])
static Scheme_Object *sch_default_print_handler(int argc, Scheme_Object *argv[]); static Scheme_Object *sch_default_print_handler(int argc, Scheme_Object *argv[]);
static Scheme_Object *sch_default_global_port_print_handler(int argc, Scheme_Object *argv[]); static Scheme_Object *sch_default_global_port_print_handler(int argc, Scheme_Object *argv[]);
static int pipe_input_p(Scheme_Object *o);
static int pipe_output_p(Scheme_Object *o);
static int pipe_out_ready(Scheme_Output_Port *p);
#ifdef MZ_PRECISE_GC #ifdef MZ_PRECISE_GC
static void register_traversers(void); static void register_traversers(void);
#endif #endif
@ -1155,6 +1159,7 @@ typedef struct User_Input_Port {
Scheme_Object *buffer_mode_proc; Scheme_Object *buffer_mode_proc;
Scheme_Object *reuse_str; Scheme_Object *reuse_str;
Scheme_Object *peeked; Scheme_Object *peeked;
Scheme_Object *prefix_pipe;
} User_Input_Port; } User_Input_Port;
#define MAX_USER_INPUT_REUSE_SIZE 1024 #define MAX_USER_INPUT_REUSE_SIZE 1024
@ -1208,6 +1213,9 @@ static long user_read_result(const char *who, Scheme_Input_Port *port,
} else } else
val = NULL; val = NULL;
n = 0; n = 0;
} else if (evt_ok && pipe_input_p(val)) {
((User_Input_Port *)port->port_data)->prefix_pipe = val;
return 0;
} else if (evt_ok && scheme_is_evt(val)) { } else if (evt_ok && scheme_is_evt(val)) {
/* A peek/read failed, and we were given a evt that unblocks /* A peek/read failed, and we were given a evt that unblocks
when the read/peek (at some offset) succeeds. */ when the read/peek (at some offset) succeeds. */
@ -1256,13 +1264,13 @@ static long user_read_result(const char *who, Scheme_Input_Port *port,
(peek (peek
? (evt_ok ? (evt_ok
? (special_ok ? (special_ok
? "non-negative exact integer, eof, evt, #f, or procedure for special" ? "non-negative exact integer, eof, evt, pipe input port, #f, or procedure for special"
: "non-negative exact integer, eof, evt, or #f") : "non-negative exact integer, eof, evt, pipe input port, or #f")
: "non-negative exact integer, eof, #f, or procedure for special") : "non-negative exact integer, eof, #f, or procedure for special")
: (evt_ok : (evt_ok
? (special_ok ? (special_ok
? "non-negative exact integer, eof, evt, or procedure for special" ? "non-negative exact integer, eof, evt, pipe input port, or procedure for special"
: "non-negative exact integer, eof, or evt") : "non-negative exact integer, eof, evt, or pipe input port")
: "non-negative exact integer, eof, or procedure for special")), : "non-negative exact integer, eof, or procedure for special")),
-1, -1, a); -1, -1, a);
return 0; return 0;
@ -1326,6 +1334,30 @@ user_get_or_peek_bytes(Scheme_Input_Port *port,
while (1) { while (1) {
int nb; int nb;
if (uip->prefix_pipe) {
/* Guarantee: if we call into a client, then we're not using the
pipe anywhere. */
r = scheme_pipe_char_count(uip->prefix_pipe);
if (r && (!peek || (SCHEME_INTP(peek_skip) && (SCHEME_INT_VAL(peek_skip) < r)))) {
/* Need atomic to ensure the guarantee: this thread shouldn't get
swapped out while it's using the pipe, because another thread might
somehow arrive at the port's procedures. (Pipe reading is probably atomic,
anyway, due to the way that pipes are implemented.) */
scheme_start_atomic();
r = scheme_get_byte_string_unless("custom-port-pipe-read", uip->prefix_pipe,
buffer, offset, size,
2, peek, peek_skip,
unless);
scheme_end_atomic_no_swap();
return r;
} else {
/* Setting the pipe to NULL ensures that we don't start using it while
we're in the call that we just started. If another thread returns
a pipe before the user's code returns, though, all bets are off. */
uip->prefix_pipe = NULL;
}
}
if (uip->reuse_str && (size == SCHEME_BYTE_STRLEN_VAL(uip->reuse_str))) { if (uip->reuse_str && (size == SCHEME_BYTE_STRLEN_VAL(uip->reuse_str))) {
bstr = uip->reuse_str; bstr = uip->reuse_str;
uip->reuse_str = NULL; uip->reuse_str = NULL;
@ -1609,6 +1641,7 @@ typedef struct User_Output_Port {
Scheme_Object *location_proc; Scheme_Object *location_proc;
Scheme_Object *count_lines_proc; Scheme_Object *count_lines_proc;
Scheme_Object *buffer_mode_proc; Scheme_Object *buffer_mode_proc;
Scheme_Object *buffer_pipe;
} User_Output_Port; } User_Output_Port;
int scheme_user_port_write_probably_ready(Scheme_Output_Port *port, Scheme_Schedule_Info *sinfo) int scheme_user_port_write_probably_ready(Scheme_Output_Port *port, Scheme_Schedule_Info *sinfo)
@ -1672,6 +1705,18 @@ user_write_result(const char *who, Scheme_Output_Port *port, int evt_ok,
return 1; /* turn 0 into 1 to indicate a successful blocking flush */ return 1; /* turn 0 into 1 to indicate a successful blocking flush */
else else
return n; return n;
} else if (evt_ok && pipe_output_p(val)) {
if (rarely_block || !len) {
scheme_arg_mismatch(who,
(rarely_block
? "bad result for a non-blocking write: "
: "bad result for a flushing write: "),
val);
}
((User_Output_Port *)port->port_data)->buffer_pipe = val;
return 0;
} else if (evt_ok && scheme_is_evt(val)) { } else if (evt_ok && scheme_is_evt(val)) {
/* A write failed, and we were given a evt that unblocks when /* A write failed, and we were given a evt that unblocks when
the write succeeds. */ the write succeeds. */
@ -1732,6 +1777,21 @@ user_write_bytes(Scheme_Output_Port *port, const char *str, long offset, long le
while (1) { while (1) {
if (uop->buffer_pipe) {
if (!rarely_block && len) {
if (pipe_out_ready((Scheme_Output_Port *)uop->buffer_pipe)) {
/* Need atomic for same reason as using prefix_pipe for input. */
scheme_start_atomic();
n = scheme_put_byte_string("user output pipe buffer", uop->buffer_pipe,
str, offset, len,
1);
scheme_end_atomic_no_swap();
return n;
}
}
uop->buffer_pipe = NULL;
}
/* Disable breaks while calling the port's function: */ /* Disable breaks while calling the port's function: */
scheme_push_break_enable(&cframe, 0, 0); scheme_push_break_enable(&cframe, 0, 0);
@ -1750,7 +1810,9 @@ user_write_bytes(Scheme_Output_Port *port, const char *str, long offset, long le
return 0; /* n == 1 for success, but caller wants 0 */ return 0; /* n == 1 for success, but caller wants 0 */
return n; return n;
} }
/* else rarely_block == 1, and we haven't written anything. */ /* else rarely_block == 1, and we haven't written anything,
or rarely_block == 0 and we haven't written anything but we
received a pipe. */
} }
scheme_thread_block(0.0); scheme_thread_block(0.0);
@ -1847,6 +1909,9 @@ user_write_special (Scheme_Output_Port *port, Scheme_Object *v, int nonblock)
v = scheme_apply(uop->write_special_proc, 3, a); v = scheme_apply(uop->write_special_proc, 3, a);
while (1) { while (1) {
if (uop->buffer_pipe)
uop->buffer_pipe = NULL;
if (scheme_is_evt(v)) { if (scheme_is_evt(v)) {
if (!nonblock) { if (!nonblock) {
a[0] = v; a[0] = v;
@ -2452,6 +2517,34 @@ static Scheme_Object *pipe_length(int argc, Scheme_Object **argv)
return scheme_make_integer(avail); return scheme_make_integer(avail);
} }
static int pipe_input_p(Scheme_Object *o)
{
/* Need an immediate pipe: */
if (SAME_TYPE(SCHEME_TYPE(o), scheme_input_port_type)) {
Scheme_Input_Port *ip;
ip = scheme_input_port_record(o);
if (ip->sub_type == scheme_pipe_read_port_type) {
return 1;
}
}
return 0;
}
static int pipe_output_p(Scheme_Object *o)
{
/* Need an immediate pipe: */
if (SAME_TYPE(SCHEME_TYPE(o), scheme_output_port_type)) {
Scheme_Output_Port *op;
op = scheme_output_port_record(o);
if (op->sub_type == scheme_pipe_write_port_type) {
return 1;
}
}
return 0;
}
/*========================================================================*/ /*========================================================================*/
/* Scheme functions and helpers */ /* Scheme functions and helpers */
/*========================================================================*/ /*========================================================================*/

6
src/mzscheme/src/schmap.inc
View File

@ -108,12 +108,6 @@ DO_MAP(int argc, Scheme_Object *argv[])
v = _scheme_apply(argv[0], argc, args); v = _scheme_apply(argv[0], argc, args);
#else #else
# ifdef FOR_EACH_MODE # ifdef FOR_EACH_MODE
# if 0
/* Last in tail position (currently disabled): */
if (pos + 1 == size) {
return _scheme_tail_apply(argv[0], argc, args);
}
# endif
_scheme_apply_multi(argv[0], argc, args); _scheme_apply_multi(argv[0], argc, args);
# else # else
if (pos + 1 == size) { if (pos + 1 == size) {

2
src/mzscheme/src/schpriv.h
View File

@ -2842,6 +2842,8 @@ int scheme_is_user_port(Scheme_Object *port);
int scheme_byte_ready_or_user_port_ready(Scheme_Object *p, Scheme_Schedule_Info *sinfo); int scheme_byte_ready_or_user_port_ready(Scheme_Object *p, Scheme_Schedule_Info *sinfo);
int scheme_pipe_char_count(Scheme_Object *p);
#define CURRENT_INPUT_PORT(config) scheme_get_param(config, MZCONFIG_INPUT_PORT) #define CURRENT_INPUT_PORT(config) scheme_get_param(config, MZCONFIG_INPUT_PORT)
#define CURRENT_OUTPUT_PORT(config) scheme_get_param(config, MZCONFIG_OUTPUT_PORT) #define CURRENT_OUTPUT_PORT(config) scheme_get_param(config, MZCONFIG_OUTPUT_PORT)
#define CHECK_PORT_CLOSED(who, kind, port, closed) if (closed) scheme_raise_exn(MZEXN_FAIL, "%s: " kind " port is closed", who); #define CHECK_PORT_CLOSED(who, kind, port, closed) if (closed) scheme_raise_exn(MZEXN_FAIL, "%s: " kind " port is closed", who);