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
svn: r8851
This commit is contained in:
Matthew Flatt
parent
28ddd158f6
commit
b3476706ec
|
|
@ -346,7 +346,7 @@
|
|||
(if (zero? n)
|
||||
(let ([lifted-lambdas (compiler:get-lifted-lambdas)]
|
||||
[once-closures (compiler:get-once-closures-list)])
|
||||
|
||||
|
||||
(let ([naya (append lifted-lambdas once-closures)])
|
||||
(set-block-magics! s:file-block (append (map (lambda (x) #f) naya)
|
||||
(block-magics s:file-block)))
|
||||
|
|
|
|||
|
|
@ -113,13 +113,15 @@
|
|||
|
||||
;; Not kill-safe.
|
||||
;; 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
|
||||
(opt-lambda (name read fast-peek close
|
||||
[location-proc #f]
|
||||
[count-lines!-proc void]
|
||||
[init-position 1]
|
||||
[buffer-mode-proc #f])
|
||||
[buffer-mode-proc #f]
|
||||
[buffering? #f])
|
||||
(define lock-semaphore (make-semaphore 1))
|
||||
(define commit-semaphore (make-semaphore 1))
|
||||
(define-values (peeked-r peeked-w) (make-pipe))
|
||||
|
|
@ -143,6 +145,11 @@
|
|||
(thread-resume manager-th (current-thread))
|
||||
(dynamic-wind suspend-manager thunk resume-manager))
|
||||
(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)
|
||||
(read-byte peeked-r))
|
||||
(define (read-it-with-lock s)
|
||||
|
|
@ -157,14 +164,25 @@
|
|||
s))
|
||||
(define (do-read-it s)
|
||||
(if (byte-ready? peeked-r)
|
||||
(read-bytes-avail!* s peeked-r)
|
||||
peeked-r
|
||||
;; If nothing is saved from a peeking read,
|
||||
;; dispatch to `read', otherwise return
|
||||
;; previously peeked data
|
||||
(cond
|
||||
[(null? special-peeked)
|
||||
(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))
|
||||
(let ([b (mcar special-peeked)])
|
||||
(write-bytes b peeked-w)
|
||||
|
|
@ -205,13 +223,17 @@
|
|||
;; Empty special queue, so read through the original proc.
|
||||
;; We only only need
|
||||
;; (- (+ skip (bytes-length s)) (pipe-content-length peeked-w))
|
||||
;; bytes, but read more (up to size of buf) to help move
|
||||
;; things along.
|
||||
(let* ([r (read buf)])
|
||||
;; bytes, but if buffering is enabled, read more (up to size of
|
||||
;; buf) to help move things along.
|
||||
(let* ([dest (if buffering?
|
||||
buf
|
||||
(make-bytes (- (+ skip (bytes-length s))
|
||||
(pipe-content-length peeked-w))))]
|
||||
[r (read dest)])
|
||||
(cond
|
||||
[(number? r)
|
||||
;; 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
|
||||
(peek-bytes-avail!* s skip #f peeked-r)]
|
||||
[(evt? r)
|
||||
|
|
@ -427,7 +449,12 @@
|
|||
location-proc
|
||||
count-lines!-proc
|
||||
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
|
||||
(opt-lambda (orig-in [name (object-name orig-in)] [delta 0])
|
||||
|
|
@ -1153,10 +1180,124 @@
|
|||
eof)))
|
||||
|
||||
;; --------------------------------------------------
|
||||
|
||||
;; 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
|
||||
(opt-lambda (port encoding [error-bytes #f] [close? #f] [name (object-name port)])
|
||||
(let ([c (bytes-open-converter encoding "UTF-8")]
|
||||
(opt-lambda (port encoding [error-bytes #f] [close? #f] [name (object-name port)]
|
||||
[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-start 0]
|
||||
[ready-end 0]
|
||||
|
|
@ -1181,20 +1322,33 @@
|
|||
;; Try converting already-read bytes:
|
||||
(let-values ([(got-c used-c status) (if (= buf-start buf-end)
|
||||
(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
|
||||
[(positive? got-c)
|
||||
;; We converted some bytes into s.
|
||||
(set! buf-start (+ used-c buf-start))
|
||||
got-c]
|
||||
[(eq? status 'aborts)
|
||||
(if buf-eof?
|
||||
;; Had an EOF or special in the stream.
|
||||
(if (= buf-start buf-end)
|
||||
(begin0
|
||||
buf-eof-result
|
||||
(set! buf-eof? #f)
|
||||
(set! buf-eof-result #f))
|
||||
(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
|
||||
buf-eof-result
|
||||
(set! buf-eof? #f)
|
||||
(set! buf-eof-result #f)))
|
||||
(handle-error s))
|
||||
;; Need more bytes.
|
||||
(begin
|
||||
|
|
@ -1227,8 +1381,11 @@
|
|||
[(eq? status 'continues)
|
||||
;; Need more room to make progress at all.
|
||||
;; Decode into ready-bytes.
|
||||
(let-values ([(got-c used-c status) (bytes-convert c buf buf-start buf-end ready-bytes)])
|
||||
(unless (memq status '(continues complete))
|
||||
(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))
|
||||
(error 'reencode-input-port-read
|
||||
"unable to make decoding progress: ~e"
|
||||
port))
|
||||
|
|
@ -1267,16 +1424,20 @@
|
|||
(lambda ()
|
||||
(when close?
|
||||
(close-input-port port))
|
||||
(bytes-close-converter c))
|
||||
(bytes-close-converter (if newline-convert?
|
||||
(mcar c)
|
||||
c)))
|
||||
#f void 1
|
||||
(case-lambda
|
||||
[() buffer-mode]
|
||||
[(mode) (set! buffer-mode mode)])))))
|
||||
[(mode) (set! buffer-mode mode)])
|
||||
(eq? buffer-mode 'block)))))
|
||||
|
||||
;; --------------------------------------------------
|
||||
|
||||
(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)]
|
||||
[ready-bytes (make-bytes 1024)]
|
||||
[ready-start 0]
|
||||
|
|
@ -1285,7 +1446,10 @@
|
|||
[out-start 0]
|
||||
[out-end 0]
|
||||
[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:
|
||||
(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
|
||||
;; Note: we could get stuck because only half an encoding
|
||||
;; is available in out-bytes.
|
||||
(flush-buffer-pipe #f enable-break?)
|
||||
(flush-some #f enable-break?)
|
||||
(if (buffer-flushed?)
|
||||
0
|
||||
|
|
@ -1317,33 +1482,99 @@
|
|||
(set! out-start 0)
|
||||
(set! out-end 0)
|
||||
(- 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
|
||||
(when (or (> ready-end ready-start)
|
||||
(< (- (bytes-length out-bytes) out-end) 100))
|
||||
;; Make room for conversion.
|
||||
(flush-some #f enable-break?) ;; convert some
|
||||
(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))
|
||||
;; Flush/buffer from pipe, first:
|
||||
(flush-buffer-pipe #f enable-break?)
|
||||
;; Flush as needed to make room in the buffer:
|
||||
(make-buffer-room #f enable-break?)
|
||||
;; Buffer some bytes:
|
||||
(let ([cnt (min (- end start)
|
||||
(- (bytes-length out-bytes) out-end))])
|
||||
(if (zero? cnt)
|
||||
(let-values ([(s2 start2 cnt2 used) (convert-newlines s start
|
||||
(- end start)
|
||||
(- (bytes-length out-bytes) out-end))])
|
||||
(if (zero? used)
|
||||
;; No room --- try flushing again:
|
||||
(write-it s start end #f enable-break?)
|
||||
;; Buffer and report success:
|
||||
(begin
|
||||
(bytes-copy! out-bytes out-end s start (+ start cnt))
|
||||
(set! out-end (+ cnt out-end))
|
||||
(bytes-copy! out-bytes out-end s2 start2 (+ start2 cnt2))
|
||||
(set! out-end (+ cnt2 out-end))
|
||||
(case buffer-mode
|
||||
[(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?))])
|
||||
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)
|
||||
;; For now, everything that we can flushed is flushed.
|
||||
;; Try to write the minimal number of bytes, and hope for the
|
||||
|
|
@ -1351,31 +1582,43 @@
|
|||
;; everyone is happy enough. If some of the bytes get written,
|
||||
;; the we will have buffered bytes when we shouldn't have.
|
||||
;; That probably won't happen, but we can't guarantee it.
|
||||
(let loop ([len 1])
|
||||
(let-values ([(got-c used-c status) (bytes-convert c s start (+ start len) ready-bytes)])
|
||||
(cond
|
||||
[(positive? got-c)
|
||||
(try-flush-ready got-c used-c)]
|
||||
[(eq? status 'aborts)
|
||||
(if (< len (- end start))
|
||||
;; Try converting a bigger chunk
|
||||
(loop (add1 len))
|
||||
;; We can't flush half an encoding, so just buffer it.
|
||||
(let ([cnt (- start end)])
|
||||
(when (> (- end start) (bytes-length out-bytes))
|
||||
(raise-insane-decoding-length))
|
||||
(bytes-copy out-bytes 0 s start end)
|
||||
(set! out-start 0)
|
||||
(set! out-end cnt)
|
||||
cnt))]
|
||||
[(eq? status 'continues)
|
||||
;; Not enough room in ready-bytes!? We give up.
|
||||
(raise-insane-decoding-length)]
|
||||
[else
|
||||
;; Encoding error. Try to flush error bytes.
|
||||
(let ([cnt (bytes-length error-bytes)])
|
||||
(bytes-copy! ready-bytes 0 error-bytes)
|
||||
(try-flush-ready cnt 1))]))))
|
||||
(if (sync/timeout 0.0 port)
|
||||
;; We should be able to write one byte...
|
||||
(let loop ([len 1])
|
||||
(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
|
||||
[(positive? got-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)
|
||||
(if (< len (- end start))
|
||||
;; Try converting a bigger chunk
|
||||
(loop (add1 len))
|
||||
;; We can't flush half an encoding, so just buffer it.
|
||||
(begin
|
||||
(when (> len2 (bytes-length out-bytes))
|
||||
(raise-insane-decoding-length))
|
||||
(bytes-copy out-bytes 0 s2 start2 (+ start2 len2))
|
||||
(set! out-start 0)
|
||||
(set! out-end len2)
|
||||
used))]
|
||||
[(eq? status 'continues)
|
||||
;; Not enough room in ready-bytes!? We give up.
|
||||
(raise-insane-decoding-length)]
|
||||
[else
|
||||
;; Encoding error. Try to flush error bytes.
|
||||
(let ([cnt (bytes-length error-bytes)])
|
||||
(bytes-copy! ready-bytes 0 error-bytes)
|
||||
(try-flush-ready cnt 1)
|
||||
used)])))
|
||||
;; Port is not ready for writing:
|
||||
#f))
|
||||
|
||||
(define (write-special-it v no-buffer&block? enable-break?)
|
||||
(cond
|
||||
|
|
@ -1390,6 +1633,7 @@
|
|||
[else
|
||||
;; Note: we could get stuck because only half an encoding
|
||||
;; is available in out-bytes.
|
||||
(flush-buffer-pipe no-buffer&block? enable-break?)
|
||||
(flush-some no-buffer&block? enable-break?)
|
||||
(if (or (buffer-flushed?)
|
||||
(not no-buffer&block?))
|
||||
|
|
@ -1398,20 +1642,22 @@
|
|||
|
||||
;; flush-all : -> 'done, 'not-done, or 'stuck
|
||||
(define (flush-all non-block? enable-break?)
|
||||
(let ([orig-none-ready? (= ready-start ready-end)]
|
||||
[orig-out-start out-start]
|
||||
[orig-out-end out-end])
|
||||
(flush-some non-block? enable-break?)
|
||||
(if (buffer-flushed?)
|
||||
'done
|
||||
;; Couldn't flush everything. One possibility is that we need
|
||||
;; more bytes to convert before a flush.
|
||||
(if (and orig-none-ready?
|
||||
(= ready-start ready-end)
|
||||
(= orig-out-start out-start)
|
||||
(= orig-out-end out-end))
|
||||
'stuck
|
||||
'not-done))))
|
||||
(if (eq? (flush-buffer-pipe non-block? enable-break?) 'done)
|
||||
(let ([orig-none-ready? (= ready-start ready-end)]
|
||||
[orig-out-start out-start]
|
||||
[orig-out-end out-end])
|
||||
(flush-some non-block? enable-break?)
|
||||
(if (buffer-flushed?)
|
||||
'done
|
||||
;; Couldn't flush everything. One possibility is that we need
|
||||
;; more bytes to convert before a flush.
|
||||
(if (and orig-none-ready?
|
||||
(= ready-start ready-end)
|
||||
(= orig-out-start out-start)
|
||||
(= orig-out-end out-end))
|
||||
'stuck
|
||||
'not-done)))
|
||||
'stuck))
|
||||
|
||||
(define (flush-all-now enable-break?)
|
||||
(case (flush-all #f enable-break?)
|
||||
|
|
@ -1419,20 +1665,17 @@
|
|||
|
||||
(define (buffer-flushed?)
|
||||
(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)
|
||||
(let ([c (write-bytes-avail* ready-bytes port 0 got-c)])
|
||||
(if (zero? 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-end got-c)
|
||||
used-c))))
|
||||
(unless (= c got-c)
|
||||
(set! ready-start c)
|
||||
(set! ready-end got-c))))
|
||||
|
||||
;; Try to make progress flushing buffered bytes
|
||||
(define (flush-some non-block? enable-break?)
|
||||
|
|
|
|||
|
|
@ -305,7 +305,7 @@
|
|||
(define (no-op-transcoder? t)
|
||||
(or (eq? t utf8-transcoder)
|
||||
(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)))))
|
||||
|
||||
(define (transcode-input p t)
|
||||
|
|
@ -320,7 +320,9 @@
|
|||
[(raise) #f]
|
||||
[(ignore) #""]
|
||||
[(replace) (string->bytes/utf-8 "\uFFFD")])
|
||||
#t))))
|
||||
#t
|
||||
(object-name p)
|
||||
(not (eq? (transcoder-eol-style t) 'none))))))
|
||||
|
||||
(define (transcode-output p t)
|
||||
(let ([p (cond
|
||||
|
|
@ -329,7 +331,7 @@
|
|||
[(binary-input/output-port? p)
|
||||
((binary-input/output-port-out-disconnect p))]
|
||||
[else p])])
|
||||
(if (eq? t utf8-transcoder)
|
||||
(if (no-op-transcoder? t)
|
||||
p
|
||||
(reencode-output-port p
|
||||
(codec-enc (transcoder-codec t))
|
||||
|
|
@ -337,7 +339,17 @@
|
|||
[(raise) #f]
|
||||
[(ignore) #""]
|
||||
[(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)
|
||||
(unless (and (port? p)
|
||||
|
|
@ -868,10 +880,10 @@
|
|||
(for ([c (in-string v)])
|
||||
(cond
|
||||
[(eq? c #\") (display "\\\"" p)]
|
||||
[(eq? c #\\) (display "\\n" p)]
|
||||
[(eq? c #\\) (display "\\\\" p)]
|
||||
[(char-graphic? 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)]
|
||||
[else
|
||||
(display "\\x" p)
|
||||
|
|
|
|||
|
|
@ -17,13 +17,13 @@
|
|||
[r6rs:open-output-file open-output-file])
|
||||
close-input-port
|
||||
close-output-port
|
||||
read-char
|
||||
(rename-out [r6rs:peek-char peek-char]
|
||||
[r6rs:read read])
|
||||
write-char
|
||||
newline
|
||||
display
|
||||
(rename-out [r6rs:write write]))
|
||||
(rename-out [r6rs:read-char read-char]
|
||||
[r6rs:peek-char peek-char]
|
||||
[r6rs:read read]
|
||||
[r6rs:write-char write-char]
|
||||
[r6rs:newline newline]
|
||||
[r6rs:display display]
|
||||
[r6rs:write write]))
|
||||
|
||||
(define (r6rs:call-with-input-file file proc)
|
||||
(r6rs:call-with-port
|
||||
|
|
@ -55,12 +55,25 @@
|
|||
(define (r6rs:open-output-file file)
|
||||
(r6rs:transcoded-port (r6rs:open-file-output-port file) (r6rs:native-transcoder)))
|
||||
|
||||
(define (r6rs:peek-char [in (current-input-port)])
|
||||
(peek-char in))
|
||||
(define (r6rs:read-char [in (r6rs:current-input-port)])
|
||||
(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)])
|
||||
(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)])
|
||||
(r6rs:put-datum out v))
|
||||
|
||||
|
|
|
|||
|
|
@ -65,13 +65,19 @@ The arguments implement the port as follows:
|
|||
@item{a procedure of arity four (representing a ``special''
|
||||
result, as discussed further below) and optionally of arity zero,
|
||||
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"])
|
||||
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.}
|
||||
@item{a @techlink{pipe} input port that supplies bytes to be
|
||||
used as long as the pipe has content (see
|
||||
@scheme[pipe-content-length]) or until @scheme[read-in] or
|
||||
@scheme[peek] is called again; or}
|
||||
|
||||
@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
|
||||
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
|
||||
@scheme[commit] are all provided and
|
||||
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 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
|
||||
were peeked because the progress event became ready. Like
|
||||
@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
|
||||
results, or that peeking and reading produce consistent results.
|
||||
|
||||
If @scheme[peek] is @scheme[#f], then peeking for the
|
||||
port is implemented automatically in terms of reads, but with
|
||||
several limitations. First, the automatic implementation is not
|
||||
If @scheme[peek] is @scheme[#f], then peeking for the port is
|
||||
implemented automatically in terms of reads, but with several
|
||||
limitations. First, the automatic implementation is not
|
||||
thread-safe. Second, the automatic implementation cannot handle
|
||||
special results (non-byte and non-eof), so @scheme[read-in] cannot
|
||||
return a procedure for a special when @scheme[peek] is
|
||||
@scheme[#f]. Finally, the automatic peek implementation is
|
||||
incompatible with progress events, so if @scheme[peek]
|
||||
is @scheme[#f], then @scheme[progress-evt] and
|
||||
@scheme[commit] must be @scheme[#f]. See also
|
||||
@scheme[make-input-port/peek-to-read].}
|
||||
incompatible with progress events, so if @scheme[peek] is
|
||||
@scheme[#f], then @scheme[progress-evt] and @scheme[commit] must
|
||||
be @scheme[#f]. See also @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
|
||||
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
|
||||
event. The event must become ready only after data is next read
|
||||
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
|
||||
@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
|
||||
the internal buffer could not be completely flushed;}
|
||||
|
||||
@item{a synchronizable event (see @secref["sync"]) that acts like
|
||||
the result of @scheme[write-bytes-avail-evt] to complete the
|
||||
write.}
|
||||
@item{a @techlink{pipe} output port (when buffering is allowed
|
||||
and not when flushing) for buffering bytes as long as the pipe is
|
||||
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
|
||||
are different, otherwise the @exnraise[exn:fail:contract].
|
||||
If a returned integer is larger than the supplied byte-string
|
||||
range, the @exnraise[exn:fail:contract].
|
||||
Similarly, the @exnraise[exn:fail:contract] if @scheme[write-out]
|
||||
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
|
||||
attempt is likely to work. Otherwise, if data cannot be written,
|
||||
|
|
|
|||
|
|
@ -44,7 +44,22 @@ input ports as it becomes available.}
|
|||
procedure?
|
||||
evt?
|
||||
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?]{
|
||||
|
||||
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,
|
||||
the port may become damaged).
|
||||
|
||||
The @scheme[read-in] and @scheme[close] procedures are the same as for
|
||||
@scheme[make-input-port]. The @scheme[fast-peek] argument can be
|
||||
either @scheme[#f] or a procedure of three arguments: a byte string to
|
||||
receive a peek, a skip 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[read-in], @scheme[close], @scheme[get-lcoation],
|
||||
@scheme[count-lines!], @scheme[init-position], and
|
||||
@scheme[buffer-mode] procedures are the same as for
|
||||
@scheme[make-input-port].
|
||||
|
||||
The @scheme[fast-peek] argument can be either @scheme[#f] or a
|
||||
procedure of three arguments: a byte string to receive a peek, a skip
|
||||
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?]
|
||||
|
|
@ -162,12 +187,16 @@ it defaults to @scheme[0].}
|
|||
[encoding string?]
|
||||
[error-bytes (or/c false/c bytes?)]
|
||||
[close? any/c #t]
|
||||
[name any/c (object-name in)])
|
||||
[name any/c (object-name in)]
|
||||
[convert-newlines? any/c #f])
|
||||
input-port?]{
|
||||
|
||||
Produces an input port that draws bytes from @scheme[in], but converts
|
||||
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
|
||||
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?)]
|
||||
[close? any/c #t]
|
||||
[name any/c (object-name out)]
|
||||
[buffer (one-of/c 'block 'line 'none)
|
||||
(if (file-stream-port? out)
|
||||
(file-stream-buffer-mode out)
|
||||
'block)])
|
||||
[newline-bytes (or/c false/c bytes?) #f])
|
||||
output-port?]{
|
||||
|
||||
Produces an output port that directs bytes to @scheme[out], but
|
||||
converts its byte stream using @scheme[(bytes-open-converter
|
||||
encoding-str "UTF-8")].
|
||||
converts its byte stream using @scheme[(bytes-open-converter "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
|
||||
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
|
||||
the result output port.
|
||||
|
||||
The @scheme[buffer] argument determines the buffer mode of the output
|
||||
port. In @scheme['block] mode, the port's buffer is flushed only when
|
||||
it is full or a flush is requested explicitly. In @scheme['line] mode,
|
||||
the buffer is flushed whenever a newline or carriage-return byte is
|
||||
written to the port. In @scheme['none] mode, the port's buffer is
|
||||
flushed after every write. Implicit flushes for @scheme['line] or
|
||||
@scheme['none] leave bytes in the buffer when they are part of an
|
||||
incomplete encoding sequence.
|
||||
The resulting port supports buffering, and the initial buffer mode is
|
||||
@scheme[(or (file-stream-buffer-mode out) 'block)]. In @scheme['block]
|
||||
mode, the port's buffer is flushed only when it is full or a flush is
|
||||
requested explicitly. In @scheme['line] mode, the buffer is flushed
|
||||
whenever a newline or carriage-return byte is written to the port. In
|
||||
@scheme['none] mode, the port's buffer is flushed after every write.
|
||||
Implicit flushes for @scheme['line] or @scheme['none] leave bytes in
|
||||
the buffer when they are part of an incomplete encoding sequence.
|
||||
|
||||
The resulting output port does not support atomic writes. An explicit
|
||||
flush or special-write to the output port can hang if the most
|
||||
|
|
|
|||
|
|
@ -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 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)])
|
||||
(display "ok" out)
|
||||
(write-special 'special! out)
|
||||
|
|
@ -549,7 +580,7 @@
|
|||
|
||||
(test 3 write-bytes #"abc" w2)
|
||||
(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)
|
||||
|
||||
;; Check encoding error
|
||||
|
|
|
|||
|
|
@ -2456,13 +2456,19 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
|
|||
|
||||
(void)jit_calli(code);
|
||||
|
||||
/* Whether we call a prim, a native, or something else,
|
||||
scheme_current_runstack is up-to-date --- unless
|
||||
it was a direct-prim call with 1 argument. */
|
||||
if (direct_prim && (num_rands == 1))
|
||||
if (direct_prim) {
|
||||
if (num_rands == 1) {
|
||||
/* Popped single argument after return of prim: */
|
||||
jitter->need_set_rs = 1;
|
||||
} else {
|
||||
/* Runstack is up-to-date: */
|
||||
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;
|
||||
else
|
||||
jitter->need_set_rs = 0;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -3155,6 +3155,7 @@ static int mark_user_input_MARK(void *p) {
|
|||
gcMARK(uip->close_proc);
|
||||
gcMARK(uip->reuse_str);
|
||||
gcMARK(uip->peeked);
|
||||
gcMARK(uip->prefix_pipe);
|
||||
return
|
||||
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->reuse_str);
|
||||
gcFIXUP(uip->peeked);
|
||||
gcFIXUP(uip->prefix_pipe);
|
||||
return
|
||||
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->buffer_mode_proc);
|
||||
gcMARK(uop->close_proc);
|
||||
gcMARK(uop->buffer_pipe);
|
||||
return
|
||||
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->buffer_mode_proc);
|
||||
gcFIXUP(uop->close_proc);
|
||||
gcFIXUP(uop->buffer_pipe);
|
||||
return
|
||||
gcBYTES_TO_WORDS(sizeof(User_Output_Port));
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1277,6 +1277,7 @@ mark_user_input {
|
|||
gcMARK(uip->close_proc);
|
||||
gcMARK(uip->reuse_str);
|
||||
gcMARK(uip->peeked);
|
||||
gcMARK(uip->prefix_pipe);
|
||||
size:
|
||||
gcBYTES_TO_WORDS(sizeof(User_Input_Port));
|
||||
}
|
||||
|
|
@ -1294,6 +1295,7 @@ mark_user_output {
|
|||
gcMARK(uop->count_lines_proc);
|
||||
gcMARK(uop->buffer_mode_proc);
|
||||
gcMARK(uop->close_proc);
|
||||
gcMARK(uop->buffer_pipe);
|
||||
size:
|
||||
gcBYTES_TO_WORDS(sizeof(User_Output_Port));
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1225,6 +1225,11 @@ XFORM_NONGCING static int pipe_char_count(Scheme_Object *p)
|
|||
return 0;
|
||||
}
|
||||
|
||||
int scheme_pipe_char_count(Scheme_Object *p)
|
||||
{
|
||||
return pipe_char_count(p);
|
||||
}
|
||||
|
||||
/****************************** main input reader ******************************/
|
||||
|
||||
static void post_progress(Scheme_Input_Port *ip)
|
||||
|
|
|
|||
|
|
@ -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_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
|
||||
static void register_traversers(void);
|
||||
#endif
|
||||
|
|
@ -1155,6 +1159,7 @@ typedef struct User_Input_Port {
|
|||
Scheme_Object *buffer_mode_proc;
|
||||
Scheme_Object *reuse_str;
|
||||
Scheme_Object *peeked;
|
||||
Scheme_Object *prefix_pipe;
|
||||
} User_Input_Port;
|
||||
|
||||
#define MAX_USER_INPUT_REUSE_SIZE 1024
|
||||
|
|
@ -1208,6 +1213,9 @@ static long user_read_result(const char *who, Scheme_Input_Port *port,
|
|||
} else
|
||||
val = NULL;
|
||||
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)) {
|
||||
/* A peek/read failed, and we were given a evt that unblocks
|
||||
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
|
||||
? (evt_ok
|
||||
? (special_ok
|
||||
? "non-negative exact integer, eof, evt, #f, or procedure for special"
|
||||
: "non-negative exact integer, eof, evt, or #f")
|
||||
? "non-negative exact integer, eof, evt, pipe input port, #f, or procedure for special"
|
||||
: "non-negative exact integer, eof, evt, pipe input port, or #f")
|
||||
: "non-negative exact integer, eof, #f, or procedure for special")
|
||||
: (evt_ok
|
||||
? (special_ok
|
||||
? "non-negative exact integer, eof, evt, or procedure for special"
|
||||
: "non-negative exact integer, eof, or evt")
|
||||
? "non-negative exact integer, eof, evt, pipe input port, or procedure for special"
|
||||
: "non-negative exact integer, eof, evt, or pipe input port")
|
||||
: "non-negative exact integer, eof, or procedure for special")),
|
||||
-1, -1, a);
|
||||
return 0;
|
||||
|
|
@ -1326,6 +1334,30 @@ user_get_or_peek_bytes(Scheme_Input_Port *port,
|
|||
while (1) {
|
||||
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))) {
|
||||
bstr = uip->reuse_str;
|
||||
uip->reuse_str = NULL;
|
||||
|
|
@ -1609,6 +1641,7 @@ typedef struct User_Output_Port {
|
|||
Scheme_Object *location_proc;
|
||||
Scheme_Object *count_lines_proc;
|
||||
Scheme_Object *buffer_mode_proc;
|
||||
Scheme_Object *buffer_pipe;
|
||||
} User_Output_Port;
|
||||
|
||||
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 */
|
||||
else
|
||||
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)) {
|
||||
/* A write failed, and we were given a evt that unblocks when
|
||||
the write succeeds. */
|
||||
|
|
@ -1732,6 +1777,21 @@ user_write_bytes(Scheme_Output_Port *port, const char *str, long offset, long le
|
|||
|
||||
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: */
|
||||
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 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);
|
||||
|
|
@ -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);
|
||||
|
||||
while (1) {
|
||||
if (uop->buffer_pipe)
|
||||
uop->buffer_pipe = NULL;
|
||||
|
||||
if (scheme_is_evt(v)) {
|
||||
if (!nonblock) {
|
||||
a[0] = v;
|
||||
|
|
@ -2452,6 +2517,34 @@ static Scheme_Object *pipe_length(int argc, Scheme_Object **argv)
|
|||
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 */
|
||||
/*========================================================================*/
|
||||
|
|
|
|||
|
|
@ -108,12 +108,6 @@ DO_MAP(int argc, Scheme_Object *argv[])
|
|||
v = _scheme_apply(argv[0], argc, args);
|
||||
#else
|
||||
# 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);
|
||||
# else
|
||||
if (pos + 1 == size) {
|
||||
|
|
|
|||
|
|
@ -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_pipe_char_count(Scheme_Object *p);
|
||||
|
||||
#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 CHECK_PORT_CLOSED(who, kind, port, closed) if (closed) scheme_raise_exn(MZEXN_FAIL, "%s: " kind " port is closed", who);
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user