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

cs: send immutable byte strings to custom output ports

Browse Source 
Related to #2726
This commit is contained in:
Matthew Flatt 2020-05-18 16:35:49 -06:00
parent 61b365f4be
commit 2988917f03
2 changed files with 49 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
pkgs/racket-test-core/tests/racket/port.rktl
View File

@ -560,6 +560,35 @@
(test 3 sync (write-bytes-avail-evt #"Bye" cap-port)) (test 3 sync (write-bytes-avail-evt #"Bye" cap-port))
(test "HELLOBYE" get-output-string orig-port) (test "HELLOBYE" get-output-string orig-port)
;; Make sure output ports get immutable byte strings
(let ()
(define i? #f)
(define p (make-output-port
'test
always-evt
(lambda (bstr start end buffer? enable-break?)
(set! i? (immutable? bstr))
(- end start))
void
(lambda (v buffer? enable-break?)
1)
(lambda (bstr start end)
(set! i? (immutable? bstr))
(wrap-evt always-evt (lambda (v) (- end start))))
(lambda (v)
(wrap-evt always-evt (lambda (v) 1)))))
(test 5 write-bytes (bytes-copy #"hello") p)
(test #t values i?)
(set! i? #f)
(test 5 write-bytes #"hello" p)
(test #t values i?)
(set! i? #f)
(test #t evt? (write-bytes-avail-evt #"hello" p))
(test #t values i?)
(set! i? #f)
(test #t evt? (write-bytes-avail-evt (bytes-copy #"hello") p))
(test #t values i?))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Peeking in a limited pipe extends the limit: ;; Peeking in a limited pipe extends the limit:

29
racket/src/io/port/custom-output-port.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base #lang racket/base
(require "../common/check.rkt" (require (only-in racket/unsafe/ops unsafe-bytes->immutable-bytes!)
"../common/check.rkt"
"../common/class.rkt" "../common/class.rkt"
"../host/thread.rkt" "../host/thread.rkt"
"port.rkt" "port.rkt"
@ -116,30 +117,40 @@
[else [else
(send core-output-port output-pipe write-out bstr start end non-block/buffer? enable-break? copy?)])] (send core-output-port output-pipe write-out bstr start end non-block/buffer? enable-break? copy?)])]
[else [else
(define-values (imm-bstr imm-start imm-end)
;; If `copy?` is false, we're allowed to do anything with the string,
;; so it's ok to destroy it and get an immutable string. If `copy?`
;; is true, then we allocate a fresh string, anyway:
(let ([immutable! unsafe-bytes->immutable-bytes!])
(if (and copy? (not (immutable? bstr)))
(values (immutable! (subbytes bstr start end)) 0 (- end start))
(values (immutable! bstr) start end))))
(define r (define r
;; Always tell user port to re-enable breaks if it blocks, since ;; Always tell user port to re-enable breaks if it blocks, since
;; we always disable breaks: ;; we always disable breaks:
(let ([enable-break? (and (not non-block/buffer?) (break-enabled))]) (let ([enable-break? (and (not non-block/buffer?) (break-enabled))])
(parameterize-break #f (parameterize-break #f
(non-atomically (non-atomically
(if copy? (user-write-out imm-bstr imm-start imm-end non-block/buffer? enable-break?)))))
(user-write-out (subbytes bstr start end) 0 (- end start) non-block/buffer? enable-break?) (check-write-result '|user port write| r imm-start imm-end non-block/buffer?)
(user-write-out bstr start end non-block/buffer? enable-break?))))))
(check-write-result '|user port write| r start end non-block/buffer?)
(cond (cond
[(pipe-output-port? r) [(pipe-output-port? r)
(write-out self bstr start end non-block/buffer? enable-break? copy?)] (write-out self imm-bstr imm-start imm-end non-block/buffer? enable-break? copy?)]
[(evt? r) [(evt? r)
(wrap-check-write-evt-result '|user port write| r start end non-block/buffer?)] (wrap-check-write-evt-result '|user port write| r imm-start imm-end non-block/buffer?)]
[else r])])) [else r])]))
(define (get-write-evt self bstr start end) (define (get-write-evt self bstr start end)
(define-values (imm-bstr imm-start imm-end)
(if (immutable? bstr)
(values bstr start end)
(values (unsafe-bytes->immutable-bytes! (subbytes bstr start end)) 0 (- end start))))
(end-atomic) (end-atomic)
(define r (user-get-write-evt bstr start end)) (define r (user-get-write-evt imm-bstr imm-start imm-end))
(unless (evt? r) (unless (evt? r)
(raise-result-error '|user port get-write-evt| "evt?" r)) (raise-result-error '|user port get-write-evt| "evt?" r))
(start-atomic) (start-atomic)
(wrap-check-write-evt-result '|user port write-evt| r start end #t)) (wrap-check-write-evt-result '|user port write-evt| r imm-start imm-end #t))
(define (write-out-special self v non-block/buffer? enable-break?) (define (write-out-special self v non-block/buffer? enable-break?)
(let ([enable-break? (and (not non-block/buffer?) (break-enabled))]) (let ([enable-break? (and (not non-block/buffer?) (break-enabled))])