LilyPond-Ruby 0.0.2.1 → 0.1.2

data/share/guile/2.2/ice-9/suspendable-ports.scm

@@ -0,0 +1,788 @@
+;;; Ports, implemented in Scheme
+;;; Copyright (C) 2016, 2019 Free Software Foundation, Inc.
+;;;
+;;; This library is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU Lesser General Public License as
+;;; published by the Free Software Foundation, either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;;
+;;; We would like to be able to implement green threads using delimited
+;;; continuations.  When a green thread would block on I/O, it should
+;;; suspend and arrange to be resumed when it can make progress.
+;;;
+;;; The problem is that the ports code is written in C.  A delimited
+;;; continuation that captures a C activation can't be resumed, because
+;;; Guile doesn't know about the internal structure of the C activation
+;;; (stack frame) and so can't compose it with the current continuation.
+;;; For that reason, to implement this desired future, we have to
+;;; implement ports in Scheme.
+;;;
+;;; If Scheme were fast enough, we would just implement ports in Scheme
+;;; early in Guile's boot, and that would be that.  However currently
+;;; that's not the case: character-by-character I/O is about three or
+;;; four times slower in Scheme than in C.  This is mostly bytecode
+;;; overhead, though there are some ways that compiler improvements
+;;; could help us too.
+;;;
+;;; Note that the difference between Scheme and C is much less for
+;;; batched operations, like read-bytes or read-line.
+;;;
+;;; So the upshot is that we need to keep the C I/O routines around for
+;;; performance reasons.  We can still have our Scheme routines
+;;; available as a module, though, for use by people working with green
+;;; threads.  That's this module.  People that want green threads can
+;;; even replace the core bindings, which enables green threading over
+;;; other generic routines like the HTTP server.
+;;;
+;;; Code:
+
+
+(define-module (ice-9 suspendable-ports)
+  #:use-module (rnrs bytevectors)
+  #:use-module (ice-9 ports internal)
+  #:use-module (ice-9 match)
+  #:export (current-read-waiter
+            current-write-waiter
+
+            install-suspendable-ports!
+            uninstall-suspendable-ports!))
+
+(define (default-read-waiter port) (port-poll port "r"))
+(define (default-write-waiter port) (port-poll port "w"))
+
+(define current-read-waiter  (make-parameter default-read-waiter))
+(define current-write-waiter (make-parameter default-write-waiter))
+
+(define (wait-for-readable port) ((current-read-waiter) port))
+(define (wait-for-writable port) ((current-write-waiter) port))
+
+(define (read-bytes port dst start count)
+  (cond
+   (((port-read port) port dst start count)
+    => (lambda (read)
+         (unless (<= 0 read count)
+           (error "bad return from port read function" read))
+         read))
+   (else
+    (wait-for-readable port)
+    (read-bytes port dst start count))))
+
+(define (write-bytes port src start count)
+  (cond
+   (((port-write port) port src start count)
+    => (lambda (written)
+         (unless (<= 0 written count)
+           (error "bad return from port write function" written))
+         (when (< written count)
+           (write-bytes port src (+ start written) (- count written)))))
+   (else
+    (wait-for-writable port)
+    (write-bytes port src start count))))
+
+(define (flush-input port)
+  (let* ((buf (port-read-buffer port))
+         (cur (port-buffer-cur buf))
+         (end (port-buffer-end buf)))
+    (when (< cur end)
+      (set-port-buffer-cur! buf 0)
+      (set-port-buffer-end! buf 0)
+      (seek port (- cur end) SEEK_CUR))))
+
+(define (flush-output port)
+  (let* ((buf (port-write-buffer port))
+         (cur (port-buffer-cur buf))
+         (end (port-buffer-end buf)))
+    (when (< cur end)
+      ;; Update cursors before attempting to write, assuming that I/O
+      ;; errors are sticky.  That way if the write throws an error,
+      ;; causing the computation to abort, and possibly causing the port
+      ;; to be collected by GC when it's open, any subsequent close-port
+      ;; or force-output won't signal *another* error.
+      (set-port-buffer-cur! buf 0)
+      (set-port-buffer-end! buf 0)
+      (write-bytes port (port-buffer-bytevector buf) cur (- end cur)))))
+
+(define utf8-bom #vu8(#xEF #xBB #xBF))
+(define utf16be-bom #vu8(#xFE #xFF))
+(define utf16le-bom #vu8(#xFF #xFE))
+(define utf32be-bom #vu8(#x00 #x00 #xFE #xFF))
+(define utf32le-bom #vu8(#xFF #xFE #x00 #x00))
+
+(define (clear-stream-start-for-bom-read port io-mode)
+  (define (maybe-consume-bom bom)
+    (and (eq? (peek-byte port) (bytevector-u8-ref bom 0))
+         (call-with-values (lambda ()
+                             (fill-input port (bytevector-length bom)))
+           (lambda (buf cur buffered)
+             (and (<= (bytevector-length bom) buffered)
+                  (let ((bv (port-buffer-bytevector buf)))
+                    (let lp ((i 1))
+                      (if (= i (bytevector-length bom))
+                          (begin
+                            (set-port-buffer-cur! buf (+ cur i))
+                            #t)
+                          (and (eq? (bytevector-u8-ref bv (+ cur i))
+                                    (bytevector-u8-ref bom i))
+                               (lp (1+ i)))))))))))
+  (when (and (port-clear-stream-start-for-bom-read port)
+             (eq? io-mode 'text))
+    (case (%port-encoding port)
+      ((UTF-8)
+       (maybe-consume-bom utf8-bom))
+      ((UTF-16)
+       (cond
+        ((maybe-consume-bom utf16le-bom)
+         (specialize-port-encoding! port 'UTF-16LE))
+        (else
+         (maybe-consume-bom utf16be-bom)
+         (specialize-port-encoding! port 'UTF-16BE))))
+      ((UTF-32)
+       (cond
+        ((maybe-consume-bom utf32le-bom)
+         (specialize-port-encoding! port 'UTF-32LE))
+        (else
+         (maybe-consume-bom utf32be-bom)
+         (specialize-port-encoding! port 'UTF-32BE)))))))
+
+(define* (fill-input port #:optional (minimum-buffering 1) (io-mode 'text))
+  (clear-stream-start-for-bom-read port io-mode)
+  (let* ((buf (port-read-buffer port))
+         (cur (port-buffer-cur buf))
+         (buffered (max (- (port-buffer-end buf) cur) 0)))
+    (cond
+     ((or (<= minimum-buffering buffered) (port-buffer-has-eof? buf))
+      (values buf cur buffered))
+     (else
+      (unless (input-port? port)
+        (error "not an input port" port))
+      (when (port-random-access? port)
+        (flush-output port))
+      (let ((bv (port-buffer-bytevector buf)))
+        (cond
+         ((< (bytevector-length bv) minimum-buffering)
+          (expand-port-read-buffer! port minimum-buffering)
+          (fill-input port minimum-buffering))
+         (else
+          (when (< 0 cur)
+            (bytevector-copy! bv cur bv 0 buffered)
+            (set-port-buffer-cur! buf 0)
+            (set-port-buffer-end! buf buffered))
+          (let ((buffering (max (port-read-buffering port) minimum-buffering)))
+            (let lp ((buffered buffered))
+              (let* ((count (- buffering buffered))
+                     (read (read-bytes port bv buffered count)))
+                (cond
+                 ((zero? read)
+                  (set-port-buffer-has-eof?! buf #t)
+                  (values buf 0 buffered))
+                 (else
+                  (let ((buffered (+ buffered read)))
+                    (set-port-buffer-end! buf buffered)
+                    (if (< buffered minimum-buffering)
+                        (lp buffered)
+                        (values buf 0 buffered)))))))))))))))
+
+(define* (force-output #:optional (port (current-output-port)))
+  (unless (and (output-port? port) (not (port-closed? port)))
+    (error "not an open output port" port))
+  (flush-output port))
+
+(define close-port
+  (let ((%close-port (@ (guile) close-port)))
+    (lambda (port)
+      (cond
+       ((port-closed? port) #f)
+       (else
+        (when (output-port? port) (flush-output port))
+        (%close-port port))))))
+
+(define-inlinable (peek-bytes port count kfast kslow)
+  (let* ((buf (port-read-buffer port))
+         (cur (port-buffer-cur buf))
+         (buffered (- (port-buffer-end buf) cur)))
+    (if (<= count buffered)
+        (kfast buf (port-buffer-bytevector buf) cur buffered)
+        (call-with-values (lambda () (fill-input port count))
+          (lambda (buf cur buffered)
+            (kslow buf (port-buffer-bytevector buf) cur buffered))))))
+
+(define (peek-byte port)
+  (peek-bytes port 1
+              (lambda (buf bv cur buffered)
+                (bytevector-u8-ref bv cur))
+              (lambda (buf bv cur buffered)
+                (and (> buffered 0)
+                     (bytevector-u8-ref bv cur)))))
+
+(define* (lookahead-u8 port)
+  (define (fast-path buf bv cur buffered)
+    (bytevector-u8-ref bv cur))
+  (define (slow-path buf bv cur buffered)
+    (if (zero? buffered)
+        the-eof-object
+        (fast-path buf bv cur buffered)))
+  (peek-bytes port 1 fast-path slow-path))
+
+(define* (get-u8 port)
+  (define (fast-path buf bv cur buffered)
+    (set-port-buffer-cur! buf (1+ cur))
+    (bytevector-u8-ref bv cur))
+  (define (slow-path buf bv cur buffered)
+    (if (zero? buffered)
+        (begin
+          (set-port-buffer-has-eof?! buf #f)
+          the-eof-object)
+        (fast-path buf bv cur buffered)))
+  (peek-bytes port 1 fast-path slow-path))
+
+(define (get-bytevector-n! port bv start count)
+  (define (port-buffer-take! pos buf cur to-copy)
+    (bytevector-copy! (port-buffer-bytevector buf) cur
+                      bv pos to-copy)
+    (set-port-buffer-cur! buf (+ cur to-copy))
+    (+ pos to-copy))
+  (define (take-already-buffered)
+    (let* ((buf (port-read-buffer port))
+           (cur (port-buffer-cur buf))
+           (buffered (max (- (port-buffer-end buf) cur) 0)))
+      (port-buffer-take! start buf cur (min count buffered))))
+  (define (buffer-and-fill pos)
+    (call-with-values (lambda () (fill-input port 1 'binary))
+      (lambda (buf cur buffered)
+        (if (zero? buffered)
+            ;; We found EOF, which is marked in the port read buffer.
+            ;; If we haven't read any bytes yet, clear the EOF from the
+            ;; buffer and return it.  Otherwise return the number of
+            ;; bytes that we have read.
+            (if (= pos start)
+                (begin
+                  (set-port-buffer-has-eof?! buf #f)
+                  the-eof-object)
+                (- pos start))
+            (let ((pos (port-buffer-take! pos buf cur
+                                          (min (- (+ start count) pos)
+                                               buffered))))
+              (if (= pos (+ start count))
+                  count
+                  (buffer-and-fill pos)))))))
+  (define (fill-directly pos)
+    (when (port-random-access? port)
+      (flush-output port))
+    (port-clear-stream-start-for-bom-read port)
+    (let lp ((pos pos))
+      (let ((read (read-bytes port bv pos (- (+ start count) pos))))
+        (cond
+         ((= (+ pos read) (+ start count))
+          count)
+         ((zero? read)
+          ;; We found EOF.  If we haven't read any bytes yet, return
+          ;; EOF.  Otherwise save the EOF in the port read buffer.
+          (if (= pos start)
+              the-eof-object
+              (begin
+                (set-port-buffer-has-eof?! (port-read-buffer port) #t)
+                (- pos start))))
+         (else (lp (+ pos read)))))))
+  (let ((pos (take-already-buffered)))
+    (cond
+     ((= pos (+ start count))
+      count)
+     ((< (- (+ start count) pos) (port-read-buffering port))
+      (buffer-and-fill pos))
+     (else (fill-directly pos)))))
+
+(define (get-bytevector-n port count)
+  (let* ((bv (make-bytevector count))
+         (result (get-bytevector-n! port bv 0 count)))
+    (cond ((eof-object? result)
+           result)
+          ((= result count)
+           bv)
+          (else
+           (let ((bv* (make-bytevector result)))
+             (bytevector-copy! bv 0 bv* 0 result)
+             bv*)))))
+
+(define (get-bytevector-some port)
+  (call-with-values (lambda () (fill-input port 1 'binary))
+    (lambda (buf cur buffered)
+      (if (zero? buffered)
+          (begin
+            (set-port-buffer-has-eof?! buf #f)
+            the-eof-object)
+          (let ((result (make-bytevector buffered)))
+            (bytevector-copy! (port-buffer-bytevector buf) cur
+                              result 0 buffered)
+            (set-port-buffer-cur! buf (+ cur buffered))
+            result)))))
+
+(define (get-bytevector-some! port bv start count)
+  (if (zero? count)
+      0
+      (call-with-values (lambda () (fill-input port 1 'binary))
+        (lambda (buf cur buffered)
+          (if (zero? buffered)
+              (begin
+                (set-port-buffer-has-eof?! buf #f)
+                the-eof-object)
+              (let ((transfer-size (min count buffered)))
+                (bytevector-copy! (port-buffer-bytevector buf) cur
+                                  transfer-size start buffered)
+                (set-port-buffer-cur! buf (+ cur transfer-size))
+                transfer-size))))))
+
+(define (put-u8 port byte)
+  (let* ((buf (port-write-buffer port))
+         (bv (port-buffer-bytevector buf))
+         (end (port-buffer-end buf)))
+    (unless (<= 0 end (bytevector-length bv))
+      (error "not an output port" port))
+    (when (and (eq? (port-buffer-cur buf) end) (port-random-access? port))
+      (flush-input port))
+    (cond
+     ((= end (bytevector-length bv))
+      ;; Multiple threads racing; race to flush, then retry.
+      (flush-output port)
+      (put-u8 port byte))
+     (else
+      (bytevector-u8-set! bv end byte)
+      (set-port-buffer-end! buf (1+ end))
+      (when (= (1+ end) (bytevector-length bv)) (flush-output port))))))
+
+(define* (put-bytevector port src #:optional (start 0)
+                         (count (- (bytevector-length src) start)))
+  (unless (<= 0 start (+ start count) (bytevector-length src))
+    (error "invalid start/count" start count))
+  (let* ((buf (port-write-buffer port))
+         (bv (port-buffer-bytevector buf))
+         (size (bytevector-length bv))
+         (cur (port-buffer-cur buf))
+         (end (port-buffer-end buf))
+         (buffered (max (- end cur) 0)))
+    (when (and (eq? cur end) (port-random-access? port))
+      (flush-input port))
+    (cond
+     ((<= size count)
+      ;; The write won't fit in the buffer at all; write directly.
+      ;; Write directly.  Flush write buffer first if needed.
+      (when (< cur end) (flush-output port))
+      (write-bytes port src start count))
+     ((< (- size buffered) count)
+      ;; The write won't fit into the buffer along with what's already
+      ;; buffered.  Flush and fill.
+      (flush-output port)
+      (set-port-buffer-end! buf count)
+      (bytevector-copy! src start bv 0 count))
+     (else
+      ;; The write will fit in the buffer, but we need to shuffle the
+      ;; already-buffered bytes (if any) down.
+      (set-port-buffer-cur! buf 0)
+      (set-port-buffer-end! buf (+ buffered count))
+      (bytevector-copy! bv cur bv 0 buffered)
+      (bytevector-copy! src start bv buffered count)
+      ;; If the buffer completely fills, we flush.
+      (when (= (+ buffered count) size)
+        (flush-output port))))))
+
+(define (decoding-error subr port)
+  ;; GNU definition; fixme?
+  (define EILSEQ 84)
+  (throw 'decoding-error subr "input decoding error" EILSEQ port))
+
+(define-inlinable (decode-utf8 bv start avail u8_0 kt kf)
+  (cond
+   ((< u8_0 #x80)
+    (kt (integer->char u8_0) 1))
+   ((and (<= #xc2 u8_0 #xdf) (<= 2 avail))
+    (let ((u8_1 (bytevector-u8-ref bv (1+ start))))
+      (if (= (logand u8_1 #xc0) #x80)
+          (kt (integer->char
+               (logior (ash (logand u8_0 #x1f) 6)
+                       (logand u8_1 #x3f)))
+              2)
+          (kf))))
+   ((and (= (logand u8_0 #xf0) #xe0) (<= 3 avail))
+    (let ((u8_1 (bytevector-u8-ref bv (+ start 1)))
+          (u8_2 (bytevector-u8-ref bv (+ start 2))))
+      (if (and (= (logand u8_1 #xc0) #x80)
+               (= (logand u8_2 #xc0) #x80)
+               (case u8_0
+                 ((#xe0) (>= u8_1 #xa0))
+                 ((#xed) (>= u8_1 #x9f))
+                 (else #t)))
+          (kt (integer->char
+               (logior (ash (logand u8_0 #x0f) 12)
+                       (ash (logand u8_1 #x3f) 6)
+                       (logand u8_2 #x3f)))
+              3)
+          (kf))))
+   ((and (<= #xf0 u8_0 #xf4) (<= 4 avail))
+    (let ((u8_1 (bytevector-u8-ref bv (+ start 1)))
+          (u8_2 (bytevector-u8-ref bv (+ start 2)))
+          (u8_3 (bytevector-u8-ref bv (+ start 3))))
+      (if (and (= (logand u8_1 #xc0) #x80)
+               (= (logand u8_2 #xc0) #x80)
+               (= (logand u8_3 #xc0) #x80)
+               (case u8_0
+                 ((#xf0) (>= u8_1 #x90))
+                 ((#xf4) (>= u8_1 #x8f))
+                 (else #t)))
+          (kt (integer->char
+               (logior (ash (logand u8_0 #x07) 18)
+                       (ash (logand u8_1 #x3f) 12)
+                       (ash (logand u8_2 #x3f) 6)
+                       (logand u8_3 #x3f)))
+              4)
+          (kf))))
+   (else (kf))))
+
+(define (bad-utf8-len bv cur buffering first-byte)
+  (define (ref n)
+    (bytevector-u8-ref bv (+ cur n)))
+  (cond
+   ((< first-byte #x80) 0)
+   ((<= #xc2 first-byte #xdf)
+    (cond
+     ((< buffering 2) 1)
+     ((not (= (logand (ref 1) #xc0) #x80)) 1)
+     (else 0)))
+   ((= (logand first-byte #xf0) #xe0)
+    (cond
+     ((< buffering 2) 1)
+     ((not (= (logand (ref 1) #xc0) #x80)) 1)
+     ((and (eq? first-byte #xe0) (< (ref 1) #xa0)) 1)
+     ((and (eq? first-byte #xed) (< (ref 1) #x9f)) 1)
+     ((< buffering 3) 2)
+     ((not (= (logand (ref 2) #xc0) #x80)) 2)
+     (else 0)))
+   ((<= #xf0 first-byte #xf4)
+    (cond
+     ((< buffering 2) 1)
+     ((not (= (logand (ref 1) #xc0) #x80)) 1)
+     ((and (eq? first-byte #xf0) (< (ref 1) #x90)) 1)
+     ((and (eq? first-byte #xf4) (< (ref 1) #x8f)) 1)
+     ((< buffering 3) 2)
+     ((not (= (logand (ref 2) #xc0) #x80)) 2)
+     ((< buffering 4) 3)
+     ((not (= (logand (ref 3) #xc0) #x80)) 3)
+     (else 0)))
+   (else 1)))
+
+(define (peek-char-and-next-cur/utf8 port buf cur first-byte)
+  (if (< first-byte #x80)
+      (values (integer->char first-byte) buf (+ cur 1))
+      (call-with-values (lambda ()
+                          (fill-input port
+                                      (cond
+                                       ((<= #xc2 first-byte #xdf) 2)
+                                       ((= (logand first-byte #xf0) #xe0) 3)
+                                       (else 4))))
+        (lambda (buf cur buffering)
+          (let ((bv (port-buffer-bytevector buf)))
+            (define (bad-utf8)
+              (let ((len (bad-utf8-len bv cur buffering first-byte)))
+                (when (zero? len) (error "internal error"))
+                (if (eq? (port-conversion-strategy port) 'substitute)
+                    (values #\xFFFD buf (+ cur len))
+                    (decoding-error "peek-char" port))))
+            (decode-utf8 bv cur buffering first-byte
+                         (lambda (char len)
+                           (values char buf (+ cur len)))
+                         bad-utf8))))))
+
+(define (peek-char-and-next-cur/iso-8859-1 port buf cur first-byte)
+  (values (integer->char first-byte) buf (+ cur 1)))
+
+(define (peek-char-and-next-cur/iconv port)
+  (let lp ((prev-input-size 0))
+    (let ((input-size (1+ prev-input-size)))
+      (call-with-values (lambda () (fill-input port input-size))
+        (lambda (buf cur buffered)
+          (cond
+           ((< buffered input-size)
+            ;; Buffer failed to fill; EOF, possibly premature.
+            (cond
+             ((zero? prev-input-size)
+              (values the-eof-object buf cur))
+             ((eq? (port-conversion-strategy port) 'substitute)
+              (values #\xFFFD buf (+ cur prev-input-size)))
+             (else
+              (decoding-error "peek-char" port))))
+           ((port-decode-char port (port-buffer-bytevector buf)
+                              cur input-size)
+            => (lambda (char)
+                 (values char buf (+ cur input-size))))
+           (else
+            (lp input-size))))))))
+
+(define (peek-char-and-next-cur port)
+  (define (have-byte buf bv cur buffered)
+    (let ((first-byte (bytevector-u8-ref bv cur)))
+      (case (%port-encoding port)
+        ((UTF-8)
+         (peek-char-and-next-cur/utf8 port buf cur first-byte))
+        ((ISO-8859-1)
+         (peek-char-and-next-cur/iso-8859-1 port buf cur first-byte))
+        (else
+         (peek-char-and-next-cur/iconv port)))))
+  (peek-bytes port 1 have-byte
+              (lambda (buf bv cur buffered)
+                (if (< 0 buffered)
+                    (have-byte buf bv cur buffered)
+                    (values the-eof-object buf cur)))))
+
+(define* (peek-char #:optional (port (current-input-port)))
+  (define (slow-path)
+    (call-with-values (lambda () (peek-char-and-next-cur port))
+      (lambda (char buf cur)
+        char)))
+  (define (fast-path buf bv cur buffered)
+    (let ((u8 (bytevector-u8-ref bv cur))
+          (enc (%port-encoding port)))
+      (case enc
+        ((UTF-8) (decode-utf8 bv cur buffered u8 (lambda (char len) char)
+                              slow-path))
+        ((ISO-8859-1) (integer->char u8))
+        (else (slow-path)))))
+  (peek-bytes port 1 fast-path
+              (lambda (buf bv cur buffered) (slow-path))))
+
+(define-inlinable (advance-port-position! pos char)
+  ;; FIXME: this cond is a speed hack; really we should just compile
+  ;; `case' better.
+  (cond
+   ;; FIXME: char>? et al should compile well.
+   ((<= (char->integer #\space) (char->integer char))
+    (set-port-position-column! pos (1+ (port-position-column pos))))
+   (else
+    (case char
+      ((#\alarm) #t)                    ; No change.
+      ((#\backspace)
+       (let ((col (port-position-column pos)))
+         (when (> col 0)
+           (set-port-position-column! pos (1- col)))))
+      ((#\newline)
+       (set-port-position-line! pos (1+ (port-position-line pos)))
+       (set-port-position-column! pos 0))
+      ((#\return)
+       (set-port-position-column! pos 0))
+      ((#\tab)
+       (let ((col (port-position-column pos)))
+         (set-port-position-column! pos (- (+ col 8) (remainder col 8)))))
+      (else
+       (set-port-position-column! pos (1+ (port-position-column pos))))))))
+
+(define* (read-char #:optional (port (current-input-port)))
+  (define (finish buf char)
+    (advance-port-position! (port-buffer-position buf) char)
+    char)
+  (define (slow-path)
+    (call-with-values (lambda () (peek-char-and-next-cur port))
+      (lambda (char buf cur)
+        (set-port-buffer-cur! buf cur)
+        (if (eq? char the-eof-object)
+            (begin
+              (set-port-buffer-has-eof?! buf #f)
+              char)
+            (finish buf char)))))
+  (define (fast-path buf bv cur buffered)
+    (let ((u8 (bytevector-u8-ref bv cur))
+          (enc (%port-encoding port)))
+      (case enc
+        ((UTF-8)
+         (decode-utf8 bv cur buffered u8
+                      (lambda (char len)
+                        (set-port-buffer-cur! buf (+ cur len))
+                        (finish buf char))
+                      slow-path))
+        ((ISO-8859-1)
+         (set-port-buffer-cur! buf (+ cur 1))
+         (finish buf (integer->char u8)))
+        (else (slow-path)))))
+  (peek-bytes port 1 fast-path
+              (lambda (buf bv cur buffered) (slow-path))))
+
+(define-inlinable (port-fold-chars/iso-8859-1 port proc seed)
+  (let* ((buf (port-read-buffer port))
+         (cur (port-buffer-cur buf)))
+    (let fold-buffer ((buf buf) (cur cur) (seed seed))
+      (let ((bv (port-buffer-bytevector buf))
+            (end (port-buffer-end buf)))
+        (let fold-chars ((cur cur) (seed seed))
+          (cond
+           ((= end cur)
+            (call-with-values (lambda () (fill-input port))
+              (lambda (buf cur buffered)
+                (if (zero? buffered)
+                    (call-with-values (lambda () (proc the-eof-object seed))
+                      (lambda (seed done?)
+                        (if done? seed (fold-buffer buf cur seed))))
+                    (fold-buffer buf cur seed)))))
+           (else
+            (let ((ch (integer->char (bytevector-u8-ref bv cur)))
+                  (cur (1+ cur)))
+              (set-port-buffer-cur! buf cur)
+              (advance-port-position! (port-buffer-position buf) ch)
+              (call-with-values (lambda () (proc ch seed))
+                (lambda (seed done?)
+                  (if done? seed (fold-chars cur seed))))))))))))
+
+(define-inlinable (port-fold-chars port proc seed)
+  (case (%port-encoding port)
+    ((ISO-8859-1) (port-fold-chars/iso-8859-1 port proc seed))
+    (else
+     (let lp ((seed seed))
+       (let ((ch (read-char port)))
+         (call-with-values (lambda () (proc ch seed))
+           (lambda (seed done?)
+             (if done? seed (lp seed)))))))))
+
+(define* (read-delimited delims #:optional (port (current-input-port))
+                         (handle-delim 'trim))
+  ;; Currently this function conses characters into a list, then uses
+  ;; reverse-list->string.  It wastes 2 words per character but it still
+  ;; seems to be the fastest thing at the moment.
+  (define (finish delim chars)
+    (define (->string chars)
+      (if (and (null? chars) (not (char? delim)))
+          the-eof-object
+          (reverse-list->string chars)))
+    (case handle-delim
+      ((trim) (->string chars))
+      ((split) (cons (->string chars) delim))
+      ((concat)
+       (->string (if (char? delim) (cons delim chars) chars)))
+      ((peek)
+       (when (char? delim) (unread-char delim port))
+       (->string chars))
+      (else
+       (error "unexpected handle-delim value: " handle-delim))))
+  (define-syntax-rule (make-folder delimiter?)
+    (lambda (char chars)
+      (if (or (not (char? char)) (delimiter? char))
+          (values (finish char chars) #t)
+          (values (cons char chars) #f))))
+  (define-syntax-rule (specialized-fold delimiter?)
+    (port-fold-chars port (make-folder delimiter?) '()))
+  (case (string-length delims)
+    ((0) (specialized-fold (lambda (char) #f)))
+    ((1) (let ((delim (string-ref delims 0)))
+           (specialized-fold (lambda (char) (eqv? char delim)))))
+    (else => (lambda (ndelims)
+               (specialized-fold
+                (lambda (char)
+                  (let lp ((i 0))
+                    (and (< i ndelims)
+                         (or (eqv? char (string-ref delims i))
+                             (lp (1+ i)))))))))))
+
+(define* (read-line #:optional (port (current-input-port))
+                    (handle-delim 'trim))
+  (read-delimited "\n" port handle-delim))
+
+(define* (%read-line port)
+  (read-line port 'split))
+
+(define* (put-string port str #:optional (start 0)
+                     (count (- (string-length str) start)))
+  (let* ((aux (port-auxiliary-write-buffer port))
+         (pos (port-buffer-position aux))
+         (line (port-position-line pos)))
+    (set-port-buffer-cur! aux 0)
+    (port-clear-stream-start-for-bom-write port aux)
+    (let lp ((encoded 0))
+      (when (< encoded count)
+        (let ((encoded (+ encoded
+                          (port-encode-chars port aux str
+                                             (+ start encoded)
+                                             (- count encoded)))))
+          (let ((end (port-buffer-end aux)))
+            (set-port-buffer-end! aux 0)
+            (put-bytevector port (port-buffer-bytevector aux) 0 end)
+            (lp encoded)))))
+    (when (and (not (eqv? line (port-position-line pos)))
+               (port-line-buffered? port))
+      (flush-output port))))
+
+(define* (put-char port char)
+  (let ((aux (port-auxiliary-write-buffer port)))
+    (set-port-buffer-cur! aux 0)
+    (port-clear-stream-start-for-bom-write port aux)
+    (port-encode-char port aux char)
+    (let ((end (port-buffer-end aux)))
+      (set-port-buffer-end! aux 0)
+      (put-bytevector port (port-buffer-bytevector aux) 0 end))
+    (when (and (eqv? char #\newline) (port-line-buffered? port))
+      (flush-output port))))
+
+(define accept
+  (let ((%accept (@ (guile) accept)))
+    (lambda* (port #:optional (flags 0))
+      (let lp ()
+        (or (%accept port flags)
+            (begin
+              (wait-for-readable port)
+              (lp)))))))
+
+(define connect
+  (let ((%connect (@ (guile) connect)))
+    (lambda (port sockaddr . args)
+      (unless (apply %connect port sockaddr args)
+        ;; Clownshoes semantics; see connect(2).
+        (wait-for-writable port)
+        (let ((err (getsockopt port SOL_SOCKET SO_ERROR)))
+          (unless (zero? err)
+            (scm-error 'system-error "connect" "~A"
+                       (list (strerror err)) #f)))))))
+
+(define saved-port-bindings #f)
+(define port-bindings
+  '(((guile)
+     read-char peek-char force-output close-port
+     accept connect)
+    ((ice-9 binary-ports)
+     get-u8 lookahead-u8 get-bytevector-n get-bytevector-n!
+     get-bytevector-some get-bytevector-some!
+     put-u8 put-bytevector)
+    ((ice-9 textual-ports)
+     put-char put-string)
+    ((ice-9 rdelim) %read-line read-line read-delimited)))
+(define (install-suspendable-ports!)
+  (unless saved-port-bindings
+    (set! saved-port-bindings (make-hash-table))
+    (let ((suspendable-ports (resolve-module '(ice-9 suspendable-ports))))
+      (for-each
+       (match-lambda
+         ((mod . syms)
+          (let ((mod (resolve-module mod)))
+            (for-each (lambda (sym)
+                        (hashq-set! saved-port-bindings sym
+                                    (module-ref mod sym))
+                        (module-set! mod sym
+                                     (module-ref suspendable-ports sym)))
+                      syms))))
+       port-bindings))))
+
+(define (uninstall-suspendable-ports!)
+  (when saved-port-bindings
+    (for-each
+     (match-lambda
+       ((mod . syms)
+        (let ((mod (resolve-module mod)))
+          (for-each (lambda (sym)
+                      (let ((saved (hashq-ref saved-port-bindings sym)))
+                        (module-set! mod sym saved)))
+                    syms))))
+     port-bindings)
+    (set! saved-port-bindings #f)))