From c78787a2596c911a446837d2a8fd6bbf166869c7 Mon Sep 17 00:00:00 2001
From: Paulo Matos <pmatos@linki.tools>
Date: Mon, 15 Oct 2018 15:30:41 +0200
Subject: [PATCH] Simplify copy-port

Simplify copy-port by removing the several `(let loop...` constructs.
---
 racket/collects/racket/private/port.rkt | 62 ++++++++++++-------------
 1 file changed, 30 insertions(+), 32 deletions(-)

diff --git a/racket/collects/racket/private/port.rkt b/racket/collects/racket/private/port.rkt
index 711a811300..2a34ed8fb9 100644
--- a/racket/collects/racket/private/port.rkt
+++ b/racket/collects/racket/private/port.rkt
@@ -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)])))