~ chicken-core (chicken-5) 9d2dc48f52afa26f77a20c849377a831504767df

commit 9d2dc48f52afa26f77a20c849377a831504767df
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Sun Oct 5 19:48:45 2025 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Sun Oct 5 19:48:45 2025 +0200

    overhaul copy-port to default to bytevector-oriented I/O

diff --git a/port.scm b/port.scm
index 83e49fef..8cad547f 100644
--- a/port.scm
+++ b/port.scm
@@ -190,51 +190,66 @@ char *ttyname(int fd) {
 
 (define copy-port
   (let ((read-char read-char)
-	(write-char write-char))
-    (define (read-buf port writer)
-      (let ((buf (make-string +buf-size+)))
-	(let loop ()
-	  (let ((n (read-string! +buf-size+ buf port)))
-	    (unless (eq? n 0)
-	      (writer buf n)
-	      (loop))))))
-    (define (write-buf buf n port writer)
-      (do ((i 0 (fx+ i 1)))
-	  ((fx>= i n))
-	(writer (string-ref buf i) port)))
-    (define (read-and-write reader writer)
+        (write-char write-char))
+    (define (read-and-write src dest)
+      (##sys#check-port src 'copy-port)
+      (##sys#check-port dest 'copy-port)
+      (let ((buf (##sys#make-bytevector +buf-size+)))
+        (let loop ()
+          (let ((n (chicken.io#read-bytevector!/port +buf-size+
+                     buf src 0)))
+            (unless (eq? n 0)
+              (chicken.io#write-bytevector buf dest 0 n)
+              (loop))))))
+    (define (read-and-delegate src dest writer)
+      (##sys#check-port src 'copy-port)
+      (let ((buf (##sys#make-bytevector +buf-size+)))
+        (let loop ((p 0))
+          (let* ((n (chicken.io#read-bytevector!/port
+                      (fx- +buf-size+ p)
+                      buf src p))
+                 (fc (##core#inline "C_utf_fragment_counts" buf 0 n))
+                 (full (fxshr fc 4))
+                 (part (fxand fc 7))
+                 (str (##sys#buffer->string buf 0 (fx- n part))))
+            (unless (eq? n 0)
+              (do ((i 0 (fx+ i 1)))
+                      ((fx>= i full))
+                (writer (string-ref str i) dest))
+              ;; overlaps, buf source will be at end of buffer
+              (##core#inline "C_copy_memory_with_offset"
+                buf buf
+                (fx- (fx- (##sys#size (##sys#slot str 0)) 1) part)
+                0 part)
+              (loop part))))))
+    (define (delegate src reader dest writer)
       (let loop ()
-	(let ((x (reader)))
-	  (unless (eof-object? x)
-	    (writer x)
-	    (loop)))))
-    (define (read-and-write-buf src dest reader)
-      (let ((buf (make-string +buf-size+)))
-	(let loop ((n 0))
-	  (when (fx>= n +buf-size+)
-	    (scheme#write-string buf dest 0 +buf-size+)
-	    (set! n 0))
-	  (let ((c (reader src)))
-	    (cond ((eof-object? c)
-		   (when (fx>= n 0)
-		     (scheme#write-string buf dest 0 n)))
-		  (else
-		   (string-set! buf n c)
-		   (loop (fx+ n 1))))))))
+        (let ((x (reader src)))
+          (unless (eof-object? x)
+            (writer x dest)
+            (loop)))))
+    (define (delegate-and-write src reader dest)
+      (##sys#check-port dest 'copy-port)
+      (let ((buf (##sys#make-bytevector (fx+ 4 +buf-size+))))
+        (let loop ((n 0))
+          (when (fx>= n +buf-size+)
+            (chicken.io#write-bytevector buf dest 0 n)
+            (set! n 0))
+          (let ((c (reader src)))
+            (cond ((eof-object? c)
+                   (when (fx>= n 0)
+                     (chicken.io#write-bytevector buf dest 0 n)))
+                  (else
+                   (loop (##core#inline "C_utf_insert" buf n c))))))))
     (lambda (src dest #!optional (read read-char) (write write-char))
       ;; does not check port args intentionally
       (cond ((eq? read read-char)
-	     (read-buf
-	      src
-	      (if (eq? write write-char)
-		  (lambda (buf n) (scheme#write-string buf dest 0 n))
-		  (lambda (buf n) (write-buf buf n dest write)))))
-	    ((eq? write write-char)
-	     (read-and-write-buf src dest read))
-	    (else
-	     (read-and-write
-	      (lambda () (read src))
-	      (lambda (x) (write x dest))))))))
+                  (if (eq? write write-char)
+                      (read-and-write src dest)
+                  (read-and-delegate src dest write)))
+            ((eq? write write-char)
+             (delegate-and-write src read dest))
+            (else (delegate src read dest write))))))
 
 
 ;;;; funky-ports