[Guile-commits] 01/01: Implement R6RS custom textual ports

[Andy Wingo]

wingo pushed a commit to branch wip-custom-ports
in repository guile.

commit 86f63a1cb86e1600c1379a10c18af95ece4cfa80
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Sun May 28 14:20:34 2023 +0200

    Implement R6RS custom textual ports
    
    * module/ice-9/textual-ports.scm (custom-textual-port-read+flush-input):
    (custom-textual-port-write):
    (custom-textual-port-seek):
    (custom-textual-port-close):
    (custom-textual-port-random-access?):
    (make-custom-textual-input-port):
    (make-custom-textual-output-port):
    (make-custom-textual-input/output-port): New procedures.
    * doc/ref/api-io.texi (Ports): Update docs.
---
 doc/ref/api-io.texi            |  73 ++++++++++++++----
 module/ice-9/textual-ports.scm | 164 ++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 220 insertions(+), 17 deletions(-)

diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi
index e6cb80394..6faa8b5a1 100644
--- a/doc/ref/api-io.texi
+++ b/doc/ref/api-io.texi
@@ -45,7 +45,7 @@ example, we might display a string to a file like this:
 
 There are also string ports, for taking input from a string, or
 collecting output to a string; bytevector ports, for doing the same but
-using a bytevector as a source or sink of data; and soft ports, for
+using a bytevector as a source or sink of data; and custom ports, for
 arranging to call Scheme functions to provide input or handle output.
 @xref{Port Types}.
 
@@ -1390,20 +1390,27 @@ away from its default.  @xref{Encoding}.
 @subsubsection Custom Ports
 
 Custom ports allow the user to provide input and handle output via
-user-supplied procedures.  Guile currently only provides custom binary
-ports, not textual ports; for custom textual ports, @xref{Soft Ports}.
-We should add the R6RS custom textual port interfaces though.
-Contributions are appreciated.
+user-supplied procedures.  The most basic of these operates on the level
+of bytes, calling user-supplied functions to supply bytes for input and
+accept bytes for output.  In Guile, textual ports are built on top of
+binary ports, encoding and decoding their codepoint sequences from the
+bytes; the higher-level textual layer for custom ports allows users to
+deal in characters instead of bytes.
+
+Before using these procedures, import the appropriate module:
+
+@example
+(use-modules (ice-9 binary-ports))
+(use-modules (ice-9 textual-ports))
+@end example
 
 @cindex custom binary input ports
 @deffn {Scheme Procedure} make-custom-binary-input-port id read! get-position 
set-position! close
-Return a new custom binary input port@footnote{This is similar in spirit
-to Guile's @dfn{soft ports} (@pxref{Soft Ports}).} named @var{id} (a
-string) whose input is drained by invoking @var{read!} and passing it a
-bytevector, an index where bytes should be written, and the number of
-bytes to read.  The @code{read!}  procedure must return an integer
-indicating the number of bytes read, or @code{0} to indicate the
-end-of-file.
+Return a new custom binary input port named @var{id} (a string) whose
+input is drained by invoking @var{read!} and passing it a bytevector, an
+index where bytes should be written, and the number of bytes to read.
+The @code{read!}  procedure must return an integer indicating the number
+of bytes read, or @code{0} to indicate the end-of-file.
 
 Optionally, if @var{get-position} is not @code{#f}, it must be a thunk
 that will be called when @code{port-position} is invoked on the custom
@@ -1477,13 +1484,50 @@ random-access, causing the buffer to be flushed between 
reads and
 writes.
 @end deffn
 
+@cindex custom textual ports
+@cindex custom textual input ports
+@cindex custom textual output ports
+@cindex custom textual input/output ports
+@deffn {Scheme Procedure} make-custom-textual-input-port id read! get-position 
set-position! close
+@deffnx {Scheme Procedure} make-custom-textual-output-port id write! 
get-position set-position! close
+@deffnx {Scheme Procedure} make-custom-textual-input/output-port id read! 
write! get-position set-position! close
+Like their custom binary port counterparts, but for textual ports.
+Concretely this means that instead of being passed a bytevector, the
+@var{read} function is passed a mutable string to fill, and likewise for
+the buffer supplied to @var{write}.  Port positions are still expressed
+in bytes, however.
+
+If string ports were not supplied with Guile, we could implement them
+With custom textual ports:
+@example
+(define (open-string-input-port source)
+  (define position 0)
+  (define length (string-length source))
+
+  (define (read! dst start count)
+    (let ((count (min count (- length position))))
+      (string-copy! dst start source position (+ position count))
+      (set! position (+ position count))
+      count))
+
+  (make-custom-textual-input-port "strport" read! #f #f #f))
+
+(read (open-string-input-port "hello"))
+@end example
+@end deffn
+
 @node Soft Ports
 @subsubsection Soft Ports
 @cindex Soft port
 @cindex Port, soft
 
-A @dfn{soft port} is a port based on a vector of procedures capable of
-accepting or delivering characters.  It allows emulation of I/O ports.
+Soft ports are what Guile had before it had custom binary and textual
+ports.  Probably you want to use one of those instead.  @xref{Custom
+Ports}.
+
+But since you are still here, a @dfn{soft port} is a port based on a
+vector of procedures capable of accepting or delivering characters.  It
+allows emulation of I/O ports.
 
 @deffn {Scheme Procedure} make-soft-port pv modes
 Return a port capable of receiving or delivering characters as
@@ -1532,7 +1576,6 @@ For example:
 @end lisp
 @end deffn
 
-
 @node Void Ports
 @subsubsection Void Ports
 @cindex Void port
diff --git a/module/ice-9/textual-ports.scm b/module/ice-9/textual-ports.scm
index ba30a8b1f..2ad074f95 100644
--- a/module/ice-9/textual-ports.scm
+++ b/module/ice-9/textual-ports.scm
@@ -1,6 +1,6 @@
 ;;;; textual-ports.scm --- Textual I/O on ports
 
-;;;;   Copyright (C) 2016 Free Software Foundation, Inc.
+;;;;   Copyright (C) 2016, 2023 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
@@ -23,7 +23,10 @@
 (define-module (ice-9 textual-ports)
   #:use-module (ice-9 ports internal)
   #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 custom-ports)
+  #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
+  #:use-module (rnrs bytevectors)
   #:re-export (get-string-n!
                put-char
                put-string)
@@ -33,7 +36,10 @@
             lookahead-char
             get-string-n
             get-string-all
-            get-line))
+            get-line
+            make-custom-textual-input-port
+            make-custom-textual-output-port
+            make-custom-textual-input/output-port))
 
 (define (get-char port)
   (read-char port))
@@ -68,3 +74,157 @@ the characters read."
     (cond ((eof-object? rv) rv)
           ((= rv count)     s)
           (else             (substring/shared s 0 rv)))))
+
+(define (type-error proc expecting val)
+  (scm-error 'wrong-type-arg proc "Wrong type (expecting `~S'): ~S"
+             (list expecting val) (list val)))
+
+(define (custom-textual-port-read+flush-input read)
+  (unless (procedure? read)
+    (type-error "custom-textual-port-read" "procedure" read))
+  (define-values (transcoder get-bytes) (open-bytevector-output-port))
+  (define buffer #f)
+  (define buffer-pos 0)
+  (define (%read port bv start count)
+    (unless (and buffer (< buffer-pos (bytevector-length buffer)))
+      (let* ((str (make-string (max (port-read-buffering port) 1)))
+             (chars (read str 0 (string-length str))))
+        (unless (and (exact-integer? chars) (<= 0 chars (string-length str)))
+          (scm-error 'out-of-range "custom-textual-port-read"
+                     "Value out of range: ~S" (list chars) (list chars)))
+        (unless (eq? (port-encoding port) (port-encoding transcoder))
+          (set-port-encoding! transcoder (port-encoding port)))
+        (unless (eq? (port-conversion-strategy port)
+                     (port-conversion-strategy transcoder))
+          (set-port-conversion-strategy! transcoder
+                                         (port-conversion-strategy port)))
+        (put-string transcoder str 0 chars)
+        (set! buffer (get-bytes))
+        (set! buffer-pos 0)))
+
+    (let ((to-copy (min count (- (bytevector-length buffer) buffer-pos))))
+      (bytevector-copy! buffer buffer-pos bv start to-copy)
+      (if (= (bytevector-length buffer) (+ buffer-pos to-copy))
+          (set! buffer #f)
+          (set! buffer-pos (+ buffer-pos to-copy)))
+      to-copy))
+  (define (%flush-input)
+    (get-bytes)
+    (set! buffer #f))
+  (values %read %flush-input))
+
+(define (subbytevector bv start count)
+  (if (and (zero? start) (= count (bytevector-length bv)))
+      bv
+      (let ((sub (make-bytevector count)))
+        (bytevector-copy! bv start sub 0 count)
+        sub)))
+
+(define (custom-textual-port-write write)
+  (unless (procedure? write)
+    (type-error "custom-textual-port-write" "procedure" write))
+  (lambda (port bv start count)
+    (let* ((bytes (subbytevector bv start count))
+           (str (call-with-input-bytevector
+                 bytes
+                 (lambda (bport)
+                   (set-port-encoding! bport (port-encoding port))
+                   (set-port-conversion-strategy!
+                    bport
+                    (port-conversion-strategy port))
+                   (get-string-all port))))
+           (len (string-length str)))
+      (let lp ((written 0))
+        (cond
+         ((= written len) count)
+         (else
+          (let ((to-write (- len written)))
+            (let ((res (write str written to-write)))
+              (unless (and (exact-integer? res) (<= 0 res to-write))
+                (scm-error 'out-of-range "custom-textual-port-write"
+                           "Value out of range: ~S" (list res) (list res)))
+              (lp (+ written res))))))))))
+
+(define (custom-textual-port-seek get-position set-position! flush-input)
+  (when get-position
+    (unless (procedure? get-position)
+      (type-error "custom-textual-port-seek" "procedure" get-position)))
+  (when set-position!
+    (unless (procedure? set-position!)
+      (type-error "custom-textual-port-seek" "procedure" set-position!)))
+
+  (define (seek port offset whence)
+    (cond
+     ((eqv? whence SEEK_CUR)
+      (unless get-position
+        (type-error "custom-textual-port-seek"
+                    "R6RS custom textual port with `port-position` support"
+                    port))
+      (if (zero? offset)
+          (get-position)
+          (seek port (+ (get-position) offset) SEEK_SET)))
+     ((eqv? whence SEEK_SET)
+      (unless set-position!
+        (type-error "custom-textual-port-seek"
+                    "Seekable R6RS custom textual port"
+                    port))
+      (flush-input)
+      (set-position! offset)
+      ;; Assume setting the position succeeds.
+      offset)
+     ((eqv? whence SEEK_END)
+      (error "R6RS custom textual ports do not support `SEEK_END'"))))
+  seek)
+
+(define (custom-textual-port-close close)
+  (match close
+    (#f (lambda (port) #t))
+    ((? procedure?) (lambda (port) (close)))
+    (_ (type-error "custom-textual-port-close" "procedure" close))))
+
+(define (custom-textual-port-random-access? set-position!)
+  (if set-position!
+      (lambda (port) #t)
+      (lambda (port) #f)))
+
+(define (make-custom-textual-input-port id read get-position set-position!
+                                        close)
+  (unless (string? id)
+    (type-error "make-custom-textual-input-port" "string" id))
+  (define-values (%read %flush-input)
+    (custom-textual-port-read+flush-input read))
+  (make-custom-port #:id id
+                    #:read %read
+                    #:seek (custom-textual-port-seek get-position set-position!
+                                                     %flush-input)
+                    #:close (custom-textual-port-close close)
+                    #:random-access?
+                    (custom-textual-port-random-access? set-position!)))
+
+(define (make-custom-textual-output-port id write get-position set-position!
+                                         close)
+  (unless (string? id)
+    (type-error "make-custom-textual-output-port" "string" id))
+  (define (flush-input) #t)
+  (make-custom-port #:id id
+                    #:write (custom-textual-port-write write)
+                    #:seek (custom-textual-port-seek get-position set-position!
+                                                     flush-input)
+                    #:close (custom-textual-port-close close)
+                    #:random-access?
+                    (custom-textual-port-random-access? set-position!)))
+
+(define (make-custom-textual-input/output-port id read write get-position
+                                               set-position! close)
+  (unless (string? id)
+    (type-error "make-custom-textual-input/output-port" "string" id))
+  (define-values (%read %flush-input)
+    (custom-textual-port-read+flush-input read))
+  (make-custom-port #:id id
+                    #:read %read
+                    #:write (custom-textual-port-write write)
+                    #:seek (custom-textual-port-seek get-position set-position!
+                                                     %flush-input)
+                    #:close (custom-textual-port-close close)
+                    #:random-access?
+                    (custom-textual-port-random-access? set-position!)))