Guile-hoot/module/hoot/ports.scm

;;; Ports
;;; Copyright (C) 2024 Igalia, S.L.
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; Commentary:
;;;
;;; Ports.
;;;
;;; Code:

(library (hoot ports)
  (export %port-fold-case?
          %set-port-fold-case?!

          make-port
          port-filename
          port-line
          port-column
          get-output-bytevector
          open-output-bytevector
          open-input-bytevector

          open-input-string
          open-output-string
          get-output-string

          ;; R7RS ports
          eof-object?
          eof-object
          port?
          input-port?
          output-port?
          binary-port?
          textual-port?
          input-port-open?
          output-port-open?
          close-input-port
          close-output-port
          close-port
          call-with-port
          seek
          flush-input-port
          flush-output-port
          u8-ready?
          peek-u8
          read-u8
          read-bytevector
          read-bytevector!
          char-ready?
          peek-char
          read-char
          read-string
          read-line
          write-u8
          write-bytevector
          write-char
          newline
          write-string

          standard-input-port
          standard-output-port
          standard-error-port

          current-input-port
          current-output-port
          current-error-port)
  (import (hoot primitives)
    (hoot cond-expand)
    (hoot boxes)
    (hoot bytevectors)
    (hoot char)
    (hoot eq)
    (hoot pairs)
    (hoot not)
    (hoot lists)
    (hoot strings)
    (hoot parameters)
    (hoot procedures)
    (hoot numbers)
    (hoot vectors)
    (hoot errors)
    (hoot match)
    (hoot values)
    (hoot bitwise))

  ;; FIXME: kwargs
  ;; FIXME: suspendability
  (define (make-port read
                     write
                     input-waiting?
                     seek
                     close
                     truncate
                     repr
                     file-name
                     read-buf-size
                     write-buf-size
                     r/w-random-access?
                     fold-case?
                     private-data)
    (when file-name (check-type file-name string? 'make-port))
    (let ((read-buf (and read (vector (make-bytevector read-buf-size 0) 0 0 #f)))
          (write-buf (and write (vector (make-bytevector write-buf-size 0) 0 0))))
      (%inline-wasm
       '(func (param $read (ref eq))
              (param $write (ref eq))
              (param $input-waiting? (ref eq))
              (param $seek (ref eq))
              (param $close (ref eq))
              (param $truncate (ref eq))
              (param $repr (ref eq))
              (param $file-name (ref eq))
              (param $read-buf (ref eq))
              (param $write-buf (ref eq))
              (param $read-buffering (ref eq))
              (param $r/w-random-access? (ref eq))
              (param $fold-case? (ref eq))
              (param $private-data (ref eq))
              (result (ref eq))
              (struct.new $port (i32.const 0)
                          (ref.i31 (i32.const 17))
                          (local.get $read)
                          (local.get $write)
                          (local.get $input-waiting?)
                          (local.get $seek)
                          (local.get $close)
                          (local.get $truncate)
                          (ref.cast $string (local.get $repr))
                          (local.get $file-name)
                          (struct.new $mutable-pair
                                      (i32.const 0)
                                      (ref.i31 (i32.const 0))
                                      (ref.i31 (i32.const 0)))
                          (local.get $read-buf)
                          (local.get $write-buf)
                          (local.get $read-buffering)
                          (local.get $r/w-random-access?)
                          (local.get $fold-case?)
                          (local.get $private-data)))
       read write input-waiting? seek close truncate repr file-name
       read-buf write-buf read-buf-size r/w-random-access?
       fold-case? private-data)))

  (define (%set-port-buffer-cur! buf cur)           (vector-set! buf 1 cur))
  (define (%set-port-buffer-end! buf end)           (vector-set! buf 2 end))
  (define (%set-port-buffer-has-eof?! buf has-eof?) (vector-set! buf 3 has-eof?))

  (define-syntax-rule (%define-simple-port-getter getter $field)
    (define (getter port)
      ;; FIXME: arg type checking
      (%inline-wasm
       '(func (param $port (ref $port)) (result (ref eq))
              (struct.get $port $field (local.get $port)))
       port)))
  (define-syntax-rule (%define-simple-port-setter setter $field)
    (define (setter port val)
      ;; FIXME: arg type checking
      (%inline-wasm
       '(func (param $port (ref $port)) (param $val (ref eq))
              (struct.set $port $field (local.get $port) (local.get $val)))
       port val)))

  (%define-simple-port-getter %port-open? $open?)
  (%define-simple-port-getter %port-read $read)
  (%define-simple-port-getter %port-write $write)
  (%define-simple-port-getter %port-input-waiting? $input-waiting?)
  (%define-simple-port-getter %port-seek $seek)
  (%define-simple-port-getter %port-close $close)
  (%define-simple-port-getter %port-truncate $truncate)
  (%define-simple-port-getter %port-repr $repr)
  (%define-simple-port-getter port-filename $filename)
  (%define-simple-port-getter %port-position $position)
  (%define-simple-port-getter %port-read-buffer $read-buf)
  (%define-simple-port-getter %port-write-buffer $write-buf)
  (%define-simple-port-getter %port-read-buffering $read-buffering)
  (%define-simple-port-getter %port-r/w-random-access? $r/w-random-access?)
  (%define-simple-port-getter %port-fold-case? $fold-case?)
  (%define-simple-port-getter %port-private-data $private-data)

  (%define-simple-port-setter %set-port-open?! $open?)
  (%define-simple-port-setter %set-port-filename! $filename)
  (%define-simple-port-setter %set-port-read-buffer! $read-buf)
  (%define-simple-port-setter %set-port-write-buffer! $write-buf)
  (%define-simple-port-setter %set-port-read-buffering! $read-buffering)
  (%define-simple-port-setter %set-port-fold-case?! $fold-case?)

  (define (port-line port)
    (check-type port port? 'port-line)
    (car (%port-position port)))
  (define (port-column port)
    (check-type port port? 'port-column)
    (cdr (%port-position port)))

  (define* (get-output-bytevector port #:optional (clear-buffer? #f))
    ;; FIXME: How to know it's a bytevector output port?
    (check-type port output-port? 'get-output-bytevector)
    (define accum (%port-private-data port))
    (flush-output-port port)
    (let ((flattened (bytevector-concatenate-reverse (box-ref accum))))
      (box-set! accum (if clear-buffer?
                          '()
                          (list flattened)))
      flattened))

  (define (open-output-bytevector)
    (define accum (make-box '()))
    (define pos #f)
    (define (appending?) (not pos))
    (define default-buffer-size 1024)
    (define (bv-write bv start count)   ; write
      (unless (zero? count)
        (cond
         ((appending?)
          (box-set! accum
                    (cons (bytevector-copy bv start (+ start count))
                          (box-ref accum))))
         (else
          (let* ((dst (get-output-bytevector port))
                 (to-copy (min count (- (bytevector-length dst) pos))))
            (bytevector-copy! dst pos bv start to-copy)
            (cond
             ((< to-copy count)
              (box-set!
               accum
               (list (bytevector-copy bv (+ start to-copy) (- count to-copy))
                     dst))
              (set! pos #f))
             (else
              (set! pos (+ pos count))))))))
      count)
    (define (bv-seek offset whence)     ; seek
      (define len (bytevector-length (get-output-bytevector port)))
      (define base (match whence ('start 0) ('cur (or pos len)) ('end len)))
      (define dst (+ base offset))
      (check-range dst 0 len 'seek)
      (set! pos (if (= pos dst) #f dst))
      dst)

    (define port
      (make-port #f                     ; read
                 bv-write
                 #f                     ; input-waiting?
                 bv-seek
                 #f                     ; close
                 #f                     ; truncate
                 "bytevector"           ; repr
                 #f                     ; filename
                 #f                     ; read-buf-size
                 default-buffer-size    ; write-buf-size
                 #f                     ; r/w-random-access
                 #f                     ; fold-case?
                 accum                  ; private data
                 ))
    port)

  (define (open-input-bytevector src)
    (check-type src bytevector? 'open-input-bytevector)
    (define pos 0)
    (define default-buffer-size 1024)
    (define (bv-read dst start count)
      (let* ((to-copy (min count (- (bytevector-length src) pos)))
             (end (+ pos to-copy)))
        (bytevector-copy! dst start src pos end)
        (set! pos end)
        to-copy))
    (define (bv-seek offset whence)     ; seek
      (define len (bytevector-length src))
      (define base (match whence ('start 0) ('cur pos) ('end len)))
      (define dst (+ base offset))
      (check-range dst 0 len 'seek)
      (set! pos dst)
      dst)
    ;; FIXME: Can we just provide `src` directly as the read buffer?
    (make-port bv-read
               #f                       ; write
               #f                       ; input-waiting?
               bv-seek
               #f                       ; close
               #f                       ; truncate
               "bytevector"             ; repr
               #f                       ; filename
               default-buffer-size      ; read-buf-size
               #f                       ; write-buf-size
               #t                       ; r/w-random-access
               #f                       ; fold-case?
               #f                       ; private data
               ))

  ;; FIXME: kwargs
  (define (make-soft-port repr %read-string %write-string input-waiting? close)
    (check-type repr string? 'make-port)
    (define (make-reader read-string)
      (define buffer #f)
      (define buffer-pos 0)
      (lambda (bv start count)
        (unless (and buffer (< buffer-pos (bytevector-length buffer)))
          (let* ((str (%read-string)))
            (set! buffer (string->utf8 str))
            (set! buffer-pos 0)))

        (let* ((to-copy (min count (- (bytevector-length buffer) buffer-pos)))
               (next-pos (+ buffer-pos to-copy)))
          (bytevector-copy! bv start buffer buffer-pos next-pos)
          (if (= (bytevector-length buffer) next-pos)
              (set! buffer #f)
              (set! buffer-pos next-pos))
          to-copy)))

    (define (make-writer write-string)
      (lambda (bv start count)
        ;; FIXME: If the writer is binary, that could split a codepoint in
        ;; two, resulting in badness.  Shouldn't happen with textual
        ;; writers but it's worth noting.
        (%write-string (utf8->string bv start (+ start count)))
        count))

    (define default-buffer-size 1024)
    (make-port (and read-string (make-reader read-string))
               (and write-string (make-writer write-string))
               input-waiting?
               #f                       ; seek
               #f                       ; close
               #f                       ; truncate
               repr                     ; repr
               #f                       ; filename
               default-buffer-size      ; read-buf-size
               default-buffer-size      ; write-buf-size
               #f                       ; r/w-random-access
               #f                       ; fold-case?
               #f                       ; private data
               ))

  (define (open-input-string str)
    (open-input-bytevector (string->utf8 str)))

  (define (open-output-string) (open-output-bytevector))
  (define* (get-output-string p #:optional (clear-buffer? #f))
    (utf8->string (get-output-bytevector p clear-buffer?)))

  ;; R7RS ports
  (define (eof-object? x) (%eof-object? x))
  (define (eof-object)
    (define-syntax eof-object
      (lambda (stx) #`'#,%the-eof-object))
    (eof-object))

  (define (port? x)
    (%inline-wasm '(func (param $obj (ref eq))
                         (result (ref eq))
                         (if (ref eq)
                             (ref.test $port (local.get $obj))
                             (then (ref.i31 (i32.const 17)))
                             (else (ref.i31 (i32.const 1)))))
                  x))
  (define (input-port? x) (and (port? x) (%port-read x) #t))
  (define (output-port? x) (and (port? x) (%port-write x) #t))
  (define (binary-port? x) (port? x))
  (define (textual-port? x) (port? x))
  (define (input-port-open? x)
    (check-type x input-port? 'input-port-open?)
    (%port-open? x))
  (define (output-port-open? x)
    (check-type x output-port? 'output-port-open?)
    (%port-open? x))
  (define (close-input-port port)
    (check-type port input-port? 'close-input-port)
    ;; FIXME: Allow half-closing of socket-like ports.
    (close-port port))
  (define (close-output-port port)
    (check-type port output-port? 'close-output-port)
    ;; FIXME: Allow half-closing of socket-like ports.
    (close-port port))
  (define (close-port port)
    (check-type port port? 'close-port)
    (when (%port-open? port)
      (when (output-port? port) (flush-output-port port))
      (%set-port-open?! port #f)
      (match (%port-close port)
        (#f #f)
        (close (close))))
    (values))
  (define (call-with-port port proc)
    (check-type port port? 'call-with-port)
    (check-type proc procedure? 'call-with-port)
    (call-with-values (lambda () (proc port))
      (lambda vals
        (close-port port)
        (apply values vals))))

  (define (seek port offset whence)
    (check-type port port? 'seek)
    (check-type offset exact-integer? 'seek)
    (assert (case whence ((cur start end) #t) (else #f)) 'seek)
    (define (buffered-bytes buf)
      (define (port-buffer-cur buf) (vector-ref buf 1))
      (define (port-buffer-end buf) (vector-ref buf 2))
      (if (vector? buf)
          (- (port-buffer-end buf) (port-buffer-cur buf))
          0))
    (cond
     ((%port-seek port)
      => (lambda (%seek)
           (cond
            ((and (eq? whence 'cur) (zero? offset))
             ;; Query current position, adjust for buffering without
             ;; flush.
             (let ((pos (%seek offset whence))
                   (buf-in (buffered-bytes (%port-read-buffer port)))
                   (buf-out (buffered-bytes (%port-write-buffer port))))
               (+ pos (- buf-in) buf-out)))
            ((not (%port-r/w-random-access? port))
             (raise (make-not-seekable-error port 'seek)))
            (else
             (when (input-port? port) (flush-input-port port))
             (when (output-port? port) (flush-output-port port))
             (let ((pos (%seek offset whence)))
               (when (input-port? port)
                 (%set-port-buffer-has-eof?! (%port-read-buffer port) #f))
               pos)))))
     (else (raise (make-not-seekable-error port 'seek)))))

  (define (%write-bytes port bv start count)
    (let ((written ((%port-write port) bv start count)))
      (check-range written 0 count '%write-bytes)
      (when (< written count)
        (%write-bytes port bv (+ start written) (- count written)))))

  (define (%read-bytes port bv start count)
    (let ((read ((%port-read port) bv start count)))
      (check-range read 0 count '%read-bytes)
      read))

  (define* (flush-input-port #:optional (port (current-output-port)))
    ;; For buffered input+output ports that are random-access?, it's
    ;; likely that when switching from reading to writing that we will
    ;; have some bytes waiting to be read, and that the underlying
    ;; port-position is ahead.  This function discards buffered input and
    ;; seeks back from before the buffered input.
    (check-type port port? 'flush-input-port)
    (match (%port-read-buffer port)
      (#f (raise (make-type-error port 'flush-input-port 'input-port?)))
      ((and buf #(bv cur end has-eof?))
       (when (< cur end)
         (%set-port-buffer-cur! buf 0)
         (%set-port-buffer-end! buf 0)
         (seek port (- cur end) 'cur)))))
  (define* (flush-output-port #:optional (port (current-output-port)))
    (check-type port port? 'flush-output-port)
    (match (%port-write-buffer port)
      (#f (raise (make-type-error port 'flush-output-port 'output-port?)))
      ((and buf #(bv cur end))
       (when (< cur end)
         (%set-port-buffer-cur! buf 0)
         (%set-port-buffer-end! buf 0)
         (%write-bytes port bv cur (- end cur))))))

  (define* (u8-ready? #:optional (port (current-input-port)))
    (check-type port port? 'u8-ready?)
    (match (%port-read-buffer port)
      (#f (raise (make-type-error port 'u8-ready? 'input-port?)))
      (#(bv cur end has-eof?)
       (or (< cur end)
           has-eof?
           (match (%port-input-waiting? port)
             (#f #t)
             (proc (proc)))))))

  (define (%fill-input port buf minimum-buffering)
    (match buf
      (#(bv cur end has-eof?)
       (let ((avail (- end cur)))
         (cond
          ((or has-eof?
               (<= minimum-buffering avail))
           (values buf avail))
          ((< (bytevector-length bv) minimum-buffering)
           (let* ((expanded (make-bytevector minimum-buffering 0))
                  (buf (vector expanded 0 (- end cur) #f)))
             (when (< cur end)
               (bytevector-copy! expanded 0 bv cur end))
             (%set-port-read-buffer! port buf)
             (%fill-input port buf minimum-buffering)))
          (else
           (when (< 0 cur)
             (bytevector-copy! bv 0 bv cur end)
             (%set-port-buffer-cur! buf 0))
           (let lp ((end avail))
             (let* ((must-read (- minimum-buffering end))
                    ;; precondition: read-buffering <= len(read-buffer)
                    ;; precondition: minimum-buffering <= len(read-buffer)
                    ;; precondition: end < minimum-buffering
                    (count (- (max (%port-read-buffering port)
                                   minimum-buffering)
                              end))
                    (read (%read-bytes port bv end count))
                    (end (+ end read)))
               (cond
                ((zero? read)
                 (%set-port-buffer-end! buf end)
                 (%set-port-buffer-has-eof?! buf #t)
                 (values buf end))
                ((< end minimum-buffering)
                 (lp end))
                (else
                 (%set-port-buffer-end! buf end)
                 (values buf end)))))))))))

  (define* (peek-u8 #:optional (port (current-input-port)))
    (check-type port port? 'peek-u8)
    (let lp ((buf (%port-read-buffer port)))
      (match buf
        (#f (raise (make-type-error port 'peek-u8 'input-port?)))
        (#(bv cur end has-eof?)
         (cond
          ((eq? cur end)
           (if has-eof?
               (eof-object)
               (call-with-values (lambda ()
                                   (%fill-input port buf 1))
                 (lambda (buf avail)
                   (if (zero? avail)
                       (eof-object)
                       (lp buf))))))
          (else
           (bytevector-u8-ref bv cur)))))))

  (define* (read-u8 #:optional (port (current-input-port)))
    (check-type port port? 'read-u8)
    (define (read-eof! buf)
      (%set-port-buffer-has-eof?! buf #f)
      (eof-object))
    (let lp ((buf (%port-read-buffer port)))
      (match buf
        (#f (raise (make-type-error port 'read-u8 'input-port?)))
        (#(bv cur end has-eof?)
         (cond
          ((eq? cur end)
           (if has-eof?
               (read-eof! buf)
               (call-with-values (lambda ()
                                   (%fill-input port buf 1))
                 (lambda (buf avail)
                   (if (zero? avail)
                       (read-eof! buf)
                       (lp buf))))))
          (else
           (%set-port-buffer-cur! buf (1+ cur))
           (bytevector-u8-ref bv cur)))))))

  (define* (read-bytevector k #:optional (port (current-input-port)))
    (check-range k 0 (1- (ash 1 29)) 'read-bytevector)
    (check-type port input-port? 'read-bytevector)
    (call-with-values (lambda ()
                        (%fill-input port (%port-read-buffer port) (max k 1)))
      (lambda (buf avail)
        (cond
         ((zero? avail)
          (%set-port-buffer-has-eof?! buf #f)
          (eof-object))
         (else
          (match buf
            (#(src cur end has-eof?)
             (let* ((cur* (min (+ cur k) end))
                    (bv (bytevector-copy src cur cur*)))
               (%set-port-buffer-cur! buf cur*)
               bv))))))))

  (define* (read-bytevector! dst #:optional (port (current-input-port))
                             (start 0) (end (bytevector-length dst)))
    (check-type dst bytevector? 'read-bytevector!)
    (check-range start 0 (bytevector-length dst) 'read-bytevector!)
    (check-range end start (bytevector-length dst) 'read-bytevector!)
    (check-type port input-port? 'read-bytevector!)
    (let ((count (- start end)))
      (call-with-values (lambda ()
                          (%fill-input port (%port-read-buffer port)
                                       (max count 1)))
        (lambda (buf avail)
          (cond
           ((zero? avail)
            (%set-port-buffer-has-eof?! buf #f)
            (eof-object))
           (else
            (match buf
              (#(src cur end has-eof?)
               (let* ((cur* (min (+ cur count) end))
                      (count (- cur* cur)))
                 (bytevector-copy! dst start src cur cur*)
                 (%set-port-buffer-cur! buf cur*)
                 count)))))))))

  (define* (char-ready? #:optional (port (current-input-port)))
    (u8-ready? port))

  (define* (peek-char #:optional (port (current-input-port)))
    (let ((a (peek-u8 port)))
      (cond
       ((eof-object? a) a)
       ((< a #b10000000) (integer->char a))
       (else
        ;; FIXME: This is a sloppy UTF-8 decoder.  Need to think more
        ;; about this.
        (let ((len (cond ((< a #b11100000) 2)
                         ((< a #b11110000) 3)
                         (else 4))))
          (call-with-values (lambda ()
                              (%fill-input port (%port-read-buffer port) len))
            (lambda (buf avail)
              (when (< len avail)
                (error "decoding error: partial utf-8 sequence"))
              (match buf
                (#(bv cur end has-eof?)
                 (integer->char
                  (%inline-wasm
                   '(func (param $bv (ref $bytevector))
                          (param $cur i32)
                          (param $end i32)
                          (result i64)
                          (i64.extend_i32_s
                           (stringview_iter.next
                            (string.as_iter
                             (string.new_lossy_utf8_array
                              (struct.get $bytevector $vals (local.get $bv))
                              (local.get $cur)
                              (local.get $end))))))
                   bv cur (+ cur len))))))))))))

  (define* (read-char #:optional (port (current-input-port)))
    (let ((a (peek-u8 port)))
      (cond
       ((eof-object? a) a)
       ((<= a #x7f)
        (match (%port-read-buffer port)
          ((and buf #(bv cur end has-eof?))
           (%set-port-buffer-cur! buf (1+ cur))
           (integer->char a))))
       (else
        (let ((len (cond ((< a #b11100000) 2)
                         ((< a #b11110000) 3)
                         (else 4))))
          (call-with-values (lambda ()
                              (%fill-input port (%port-read-buffer port) len))
            (lambda (buf avail)
              (when (< len avail)
                (error "decoding error: partial utf-8 sequence"))
              (match buf
                (#(bv cur end has-eof?)
                 (%set-port-buffer-cur! buf (+ cur len))
                 (integer->char
                  (%inline-wasm
                   '(func (param $bv (ref $bytevector))
                          (param $cur i32)
                          (param $end i32)
                          (result i64)
                          (i64.extend_i32_s
                           (stringview_iter.next
                            (string.as_iter
                             (string.new_lossy_utf8_array
                              (struct.get $bytevector $vals (local.get $bv))
                              (local.get $cur)
                              (local.get $end))))))
                   bv cur (+ cur len))))))))))))
  (define* (read-string k #:optional (port (current-input-port)))
    (check-type port input-port? 'read-string)
    (cond
     ;; Call peek-char to ensure we're at the start of some UTF-8.
     ((eof-object? (peek-char port)) (eof-object))
     (else
      (match (%port-read-buffer port)
        ((and buf #(bv cur end has-eof?))
         (define (take-string count cur*)
           (%set-port-buffer-cur! buf cur*)
           (define str (utf8->string bv cur cur*))
           (let ((remaining (- k count)))
             (if (zero? remaining)
                 str
                 (match (read-string remaining port)
                   ((? eof-object?) str)
                   (tail (string-append str tail))))))
         ;; Count codepoints in buffer.
         (let count-codepoints ((count 0) (cur cur))
           (if (and (< cur end) (< count k))
               (let* ((u8 (bytevector-u8-ref bv cur))
                      (len (cond ((< u8 #b10000000) 1)
                                 ((< u8 #b11100000) 2)
                                 ((< u8 #b11110000) 3)
                                 (else 4))))
                 (if (<= (+ cur len) end)
                     (count-codepoints (1+ count) (+ cur len))
                     (take-string count cur)))
               (take-string count cur))))))))
  (define* (read-line #:optional (port (current-input-port)))
    (check-type port input-port? 'read-line)
    (define bytes '())
    (define (finish)
      (utf8->string (bytevector-concatenate-reverse bytes)))
    (let read-some ((buf (%port-read-buffer port)))
      (match buf
        (#(bv cur end has-eof?)
         (define (accumulate-bytes! end)
           (set! bytes (cons (bytevector-copy bv cur end) bytes)))
         (let scan-for-newline ((pos cur))
           (cond
            ((< pos end)
             (let ((u8 (bytevector-u8-ref bv pos)))
               (cond
                ((or (eq? u8 (char->integer #\newline))
                     (eq? u8 (char->integer #\return)))
                 (accumulate-bytes! pos)
                 (%set-port-buffer-cur! buf (1+ pos))
                 (when (and (eq? u8 (char->integer #\return))
                            (eq? (peek-u8 port) (char->integer #\newline)))
                   (read-u8 port))
                 (finish))
                (else
                 (scan-for-newline (1+ pos))))))
            ((< cur pos)
             (accumulate-bytes! pos)
             (%set-port-buffer-cur! buf pos)
             (read-some (%fill-input port buf 1)))
            ((not has-eof?)
             (read-some (%fill-input port buf 1)))
            ((null? bytes)
             (%set-port-buffer-has-eof?! buf #f)
             (eof-object))
            (else
             (finish))))))))

  (define* (write-u8 u8 #:optional (port (current-output-port)))
    (check-type port port? 'write-u8)
    (match (%port-write-buffer port)
      (#f (raise (make-type-error port 'write-u8 'output-port?)))
      ((and buf #(dst cur end))
       (when (and (eq? cur end) (%port-r/w-random-access? port))
         (flush-output-port port))
       (cond
        ((= end (bytevector-length dst))
         ;; Multiple threads racing; race to flush, then retry.
         (flush-output-port port)
         (write-u8 u8 port))
        (else
         (bytevector-u8-set! dst end u8)
         (let ((end (1+ end)))
           (%set-port-buffer-end! buf end)
           (when (= end (bytevector-length dst))
             (flush-output-port port))))))))

  (define* (write-bytevector bv #:optional (port (current-output-port))
                             (start 0) (end (bytevector-length bv)))
    (check-type port port? 'write-u8)
    (let ((count (- end start)))
      (match (%port-write-buffer port)
        (#f (raise (make-type-error port 'write-bytevector 'output-port?)))
        ((and buf #(dst cur end))
         (when (and (eq? cur end) (%port-r/w-random-access? port))
           (flush-output-port port))
         (let ((size (bytevector-length dst))
               (buffered (- end cur)))
           (cond
            ((<= (+ end count) size)
             ;; Bytes fit in buffer: copy directly.
             (bytevector-copy! dst end bv start (+ start count))
             (let ((end (+ end count)))
               (%set-port-buffer-end! buf end)
               (when (= end size)
                 (flush-output-port port))))
            ((< count size)
             ;; Bytes fit in buffer, but we have to flush output first.
             (flush-output-port port)
             (bytevector-copy! dst 0 bv start (+ start count))
             (%set-port-buffer-cur! buf 0)
             (%set-port-buffer-end! buf count)
             (when (= count size)
               (flush-output-port port)))
            (else
             ;; Otherwise flush any buffered output, then make an
             ;; unbuffered write.
             (unless (zero? buffered) (flush-output-port port))
             (%write-bytes port bv start count))))))))

  (define* (write-char x #:optional (port (current-output-port)))
    ;; FIXME: update port position.
    (define (low-six i) (logand i #b111111))
    (let ((i (char->integer x)))
      (cond
       ((<= i #x7f)
        (write-u8 i port))
       ((<= i #x7ff)
        (write-bytevector
         (bytevector (logior #b11000000 (ash i -6))
                     (logior #b10000000 (low-six i)))
         port))
       ((<= i #xffff)
        (write-bytevector
         (bytevector (logior #b11100000 (ash i -12))
                     (logior #b10000000 (low-six (ash i -6)))
                     (logior #b10000000 (low-six i)))
         port))
       (else
        (write-bytevector
         (bytevector (logior #b11110000 (ash i -18))
                     (logior #b10000000 (low-six (ash i -12)))
                     (logior #b10000000 (low-six (ash i -6)))
                     (logior #b10000000 (low-six i)))
         port)))))

  (define* (newline #:optional (port (current-output-port)))
    (write-char #\newline port))

  (define* (write-string str #:optional (port (current-output-port)))
    ;; FIXME: Could avoid the double-copy and encode directly to buffer.
    (write-bytevector (string->utf8 str) port))

  (define (standard-input-port)
    (make-soft-port "stdin"
                    (lambda ()
                      (%inline-wasm
                       '(func (result (ref eq))
                              (struct.new $string
                                          (i32.const 0)
                                          (call $read-stdin)))))
                    #f #f #f))
  (define (standard-output-port)
    (make-soft-port "stdout"
                    #f
                    (lambda (str)
                      (%inline-wasm
                       '(func (param $str (ref string))
                              (call $write-stdout (local.get $str)))
                       str))
                    #f #f))
  (define (standard-error-port)
    (make-soft-port "stderr"
                    #f
                    (lambda (str)
                      (%inline-wasm
                       '(func (param $str (ref string))
                              (call $write-stderr (local.get $str)))
                       str))
                    #f #f))

  (cond-expand
   (guile-vm)
   (hoot-main
    (define current-input-port
      (make-parameter (standard-input-port)
                      (lambda (val)
                        (check-type val input-port? 'current-input-port)
                        val)))
    (define current-output-port
      (make-parameter (standard-output-port)
                      (lambda (val)
                        (check-type val output-port? 'current-output-port)
                        val)))
    (define current-error-port
      (make-parameter (standard-error-port)
                      (lambda (val)
                        (check-type val output-port? 'current-error-port)
                        val)))
    (%inline-wasm
     '(func (param $current-input-port (ref eq))
            (param $current-output-port (ref eq))
            (param $current-error-port (ref eq))
            (global.set $current-input-port (local.get $current-input-port))
            (global.set $current-output-port (local.get $current-output-port))
            (global.set $current-error-port (local.get $current-error-port)))
     current-input-port
     current-output-port
     current-error-port))
   (hoot-aux
    (define current-input-port
      (%inline-wasm
       '(func (result (ref eq)) (global.get $current-input-port))))
    (define current-output-port
      (%inline-wasm
       '(func (result (ref eq)) (global.get $current-output-port))))
    (define current-error-port
      (%inline-wasm
       '(func (result (ref eq)) (global.get $current-error-port)))))))