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

support progress evts in result of `make-limited-input-port'

Browse Source 
and also adjust initial position in various port constructions
 to use `file-position' instead of `port-next-location'
This commit is contained in:
Matthew Flatt 2011-06-16 09:18:47 -06:00
parent 83d002a9aa
commit a919062143
2 changed files with 41 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/mzlib/port.rkt
View File

@ -529,8 +529,7 @@
(lambda (n evt target-evt) (port-commit-peeked n evt target-evt p))) (lambda (n evt target-evt) (port-commit-peeked n evt target-evt p)))
(lambda () (port-next-location p)) (lambda () (port-next-location p))
(lambda () (port-count-lines! p)) (lambda () (port-count-lines! p))
(let-values ([(line col pos) (port-next-location p)]) (add1 (file-position p)))))
(or pos (file-position p))))))
;; Not kill-safe. ;; Not kill-safe.
(define make-pipe-with-specials (define make-pipe-with-specials
@ -891,9 +890,14 @@
n))))) n)))))
(lambda () (lambda ()
(when close-orig? (when close-orig?
(close-input-port port))))))) (close-input-port port)))
(and (port-provides-progress-evts? port)
(lambda () (port-progress-evt port)))
(and (port-provides-progress-evts? port)
(lambda (n evt target-evt) (port-commit-peeked n evt target-evt port)))
(lambda () (port-next-location port))
(lambda () (port-count-lines! port))
(add1 (file-position port))))))
(define special-filter-input-port (define special-filter-input-port
(lambda (p filter [close? #t]) (lambda (p filter [close? #t])
@ -927,8 +931,7 @@
(lambda (n evt target-evt) (port-commit-peeked n evt target-evt p))) (lambda (n evt target-evt) (port-commit-peeked n evt target-evt p)))
(lambda () (port-next-location p)) (lambda () (port-next-location p))
(lambda () (port-count-lines! p)) (lambda () (port-count-lines! p))
(let-values ([(l c p) (port-next-location p)]) (add1 (file-position p)))))
p))))
;; ---------------------------------------- ;; ----------------------------------------
@ -1758,8 +1761,7 @@
(let ([new (transplant-output-port (let ([new (transplant-output-port
p p
(lambda () (port-next-location p)) (lambda () (port-next-location p))
(let-values ([(line col pos) (port-next-location p)]) (add1 (file-position p))
(or pos (file-position p)))
close? close?
(lambda () (port-count-lines! p)))]) (lambda () (port-count-lines! p)))])
(port-display-handler new (port-display-handler p)) (port-display-handler new (port-display-handler p))
@ -1771,8 +1773,7 @@
(let ([new (transplant-input-port (let ([new (transplant-input-port
p p
(lambda () (port-next-location p)) (lambda () (port-next-location p))
(let-values ([(line col pos) (port-next-location p)]) (add1 (file-position p))
(or pos (file-position p)))
close? close?
(lambda () (port-count-lines! p)))]) (lambda () (port-count-lines! p)))])
(port-read-handler new (port-read-handler p)) (port-read-handler new (port-read-handler p))

50
collects/tests/racket/portlib.rktl
View File

@ -540,8 +540,13 @@
(test #"12345" peek-bytes 6 0 s2) (test #"12345" peek-bytes 6 0 s2)
(test #"12" read-bytes 2 s2) (test #"12" read-bytes 2 s2)
(test #"345" read-bytes 6 s2) (test #"345" read-bytes 6 s2)
(test eof read-bytes 6 s2) (test eof read-bytes 6 s2))
(test #f port-provides-progress-evts? s2)) (let* ([s (open-input-string "123456789")]
[s2 (make-limited-input-port s 5)])
(test #t port-provides-progress-evts? s2)
(test #"123" peek-bytes 3 0 s2)
(test #t port-commit-peeked 3 (port-progress-evt s2) always-evt s2)
(test #"45" read-bytes 2 s2))
(let-values ([(i o) (make-pipe)]) (let-values ([(i o) (make-pipe)])
(let ([s (make-limited-input-port i 5)]) (let ([s (make-limited-input-port i 5)])
(test #f char-ready? s) (test #f char-ready? s)
@ -763,29 +768,32 @@
(define (check-all count-lines!) (define (check-all count-lines!)
(define (check-made first-three-bytes char-len (define (check-made first-three-bytes char-len
[get-loc #f] [on-consume void] [get-loc #f] [on-consume void]
[init-pos 1]) [init-pos 1]
#:wrap [wrap values])
(define stream (append first-three-bytes (list (char->integer #\4)))) (define stream (append first-three-bytes (list (char->integer #\4))))
(define p (make-input-port/read-to-peek (define p (wrap
'made (make-input-port/read-to-peek
(lambda (bstr) 'made
(let ([b (car stream)]) (lambda (bstr)
(set! stream (cdr stream)) (let ([b (car stream)])
(if (byte? b) (set! stream (cdr stream))
(begin (if (byte? b)
(bytes-set! bstr 0 b) (begin
1) (bytes-set! bstr 0 b)
(lambda (srcloc line col pos) b)))) 1)
#f (lambda (srcloc line col pos) b))))
void #f
get-loc void
void get-loc
init-pos void
#f init-pos
#f #f
on-consume)) #f
on-consume)))
(count-lines! p) (count-lines! p)
(check p (sub1 init-pos) first-three-bytes char-len)) (check p (sub1 init-pos) first-three-bytes char-len))
(check-made (bytes->list #"123") 3) (check-made (bytes->list #"123") 3)
(check-made (bytes->list #"123") 3 #:wrap (lambda (in) (make-limited-input-port in 5)))
(check-made (list (char->integer #\1) 'special (char->integer #\3)) 3) (check-made (list (char->integer #\1) 'special (char->integer #\3)) 3)
(check-made (bytes->list (string->bytes/utf-8 "1\u3BB")) 2) (check-made (bytes->list (string->bytes/utf-8 "1\u3BB")) 2)
(let () (let ()