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

Simplify copy-port

Browse Source 
Simplify copy-port by removing the several `(let loop...` constructs.
This commit is contained in:
Paulo Matos 2018-10-15 15:30:41 +02:00 committed by Matthew Flatt
parent f85810ddb5
commit c78787a259
1 changed files with 30 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
racket/collects/racket/private/port.rkt
View File

@ -1,4 +1,4 @@
#lang racket/base
#lang racket/base
;; A few simple port functions are needed in pretty.rkt, which is
;; used by contract.rkt, which is used by port.rkt --- so we
;; break the cycle with this module.
@ -15,7 +15,7 @@
(define open-output-nowhere
(lambda ([name 'nowhere] [specials-ok? #t])
(make-output-port
(make-output-port
name
always-evt
(lambda (s start end non-block? breakable?) (- end start))
@ -27,7 +27,7 @@
(lambda (x)
(- end start))))
(and specials-ok?
(lambda (special)
(lambda (special)
(wrap-evt always-evt (lambda (x) #t)))))))
(define (transplant-to-relocate transplant p line col pos close? name)
@ -65,7 +65,7 @@
breakable?
(flush-output p)
0)
(let ([v (if nonblock?
(let ([v (if nonblock?
(write-bytes-avail* s p start end)
(if breakable?
(parameterize-break
@ -83,7 +83,7 @@
;; Here's the slow way to redirect:
#;
(lambda (special nonblock? breakable?)
((if nonblock?
((if nonblock?
write-special-avail*
(if breakable?
(lambda (spec p)
@ -110,37 +110,35 @@
[(mode) (file-stream-buffer-mode p mode)]
[() (file-stream-buffer-mode p)]))))
(define (copy-port src dest . dests)
(define (copy-port src dest . dests*)
(unless (input-port? src)
(raise-type-error 'copy-port "input-port" src))
(for-each
(lambda (dest)
(unless (output-port? dest)
(raise-type-error 'copy-port "output-port" dest)))
(cons dest dests))
(let ([s (make-bytes 4096)]
[dests (cons dest dests)])
(let loop ()
(let ([c (read-bytes-avail! s src)])
(cond
[(number? c)
(let loop ([dests dests])
(unless (null? dests)
(let loop ([start 0])
(unless (= start c)
(let ([c2 (write-bytes-avail s (car dests) start c)])
(loop (+ start c2)))))
(loop (cdr dests))))
(loop)]
[(procedure? c)
(let ([v (let-values ([(l col p) (port-next-location src)])
(c (object-name src) l col p))])
(let loop ([dests dests])
(unless (null? dests)
(write-special v (car dests))
(loop (cdr dests)))))
(loop)]
[else
;; Must be EOF
(void)])))))
(cons dest dests*))
(define sz 4096)
(define s (make-bytes sz))
(define dests (cons dest dests*))
(let loop ()
(define c (read-bytes-avail! s src))
(cond
[(number? c)
(for ([dest (in-list dests)])
(let write-loop ([bytes-written 0])
(unless (= bytes-written c)
(define c2 (write-bytes-avail s dest bytes-written c))
(write-loop (+ bytes-written c2)))))
(loop)]
[(procedure? c)
(define-values (l col p) (port-next-location src))
(define v (c (object-name src) l col p))
(for ([dest (in-list dests)])
(write-special v dest))
(loop)]
[else
;; Must be EOF
(void)])))