[Guile-commits] 05/18: Add "custom ports"

[Andy Wingo]

wingo pushed a commit to branch main
in repository guile.

commit 1852fbfef99c99090b4508918565ef19a345a7ab
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Sat May 27 21:51:57 2023 +0200

    Add "custom ports"
    
    Custom ports are a kind of port that exposes the C port type interface
    directly to Scheme.  In this way the full capability of C is available
    to Scheme, and also the read and write functions can be tail-called from
    Scheme (via port-read / port-write).
    
    * libguile/custom-ports.c:
    * libguile/custom-ports.h:
    * module/ice-9/custom-ports.scm: New files.
    * libguile/init.c:
    * libguile/Makefile.am:
    * am/bootstrap.am: Add to the build.
    * doc/ref/api-io.texi: Update the manual.
---
 am/bootstrap.am               |   3 +-
 doc/ref/api-io.texi           | 428 +++++++++++++++++++++++++-----------------
 libguile/Makefile.am          |   8 +-
 libguile/custom-ports.c       | 205 ++++++++++++++++++++
 libguile/custom-ports.h       |  29 +++
 libguile/init.c               |   4 +-
 module/ice-9/custom-ports.scm | 167 ++++++++++++++++
 7 files changed, 664 insertions(+), 180 deletions(-)

diff --git a/am/bootstrap.am b/am/bootstrap.am
index 53ee68315..ffa37095d 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -1,4 +1,4 @@
-##     Copyright (C) 2009-2022 Free Software Foundation, Inc.
+##     Copyright (C) 2009-2023 Free Software Foundation, Inc.
 ##
 ##   This file is part of GNU Guile.
 ##
@@ -132,6 +132,7 @@ SOURCES =                                   \
   ice-9/control.scm                            \
   ice-9/copy-tree.scm                          \
   ice-9/curried-definitions.scm                        \
+  ice-9/custom-ports.scm                       \
   ice-9/deprecated.scm                         \
   ice-9/documentation.scm                      \
   ice-9/eval-string.scm                                \
diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi
index 86f83e85e..5d5dfa58b 100644
--- a/doc/ref/api-io.texi
+++ b/doc/ref/api-io.texi
@@ -1,7 +1,7 @@
 @c -*-texinfo-*-
 @c This is part of the GNU Guile Reference Manual.
 @c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2009,
-@c   2010, 2011, 2013, 2016, 2019, 2021  Free Software Foundation, Inc.
+@c   2010, 2011, 2013, 2016, 2019, 2021, 2023  Free Software Foundation, Inc.
 @c See the file guile.texi for copying conditions.
 
 @node Input and Output
@@ -20,7 +20,6 @@
 * Port Types::                  Types of port and how to make them.
 * Venerable Port Interfaces::   Procedures from the last millenium.
 * Using Ports from C::          Nice interfaces for C.
-* I/O Extensions::              Implementing new port types in C.
 * Non-Blocking I/O::            How Guile deals with EWOULDBLOCK.
 * BOM Handling::                Handling of Unicode byte order marks.
 @end menu
@@ -1063,6 +1062,8 @@ initialized with the @var{port} argument.
 * Custom Ports:: Ports whose implementation you control.
 * Soft Ports:: An older version of custom ports.
 * Void Ports:: Ports on nothing at all.
+* Low-Level Custom Ports:: Implementing new kinds of port.
+* Low-Level Custom Ports in C:: A C counterpart to make-custom-port.
 @end menu
 
 
@@ -1548,6 +1549,253 @@ specifies the input/output modes for this port: see the
 documentation for @code{open-file} in @ref{File Ports}.
 @end deffn
 
+@node Low-Level Custom Ports
+@subsubsection Low-Level Custom Ports
+
+This section describes how to implement a new kind of port using Guile's
+lowest-level, most primitive interfaces.  First, load the @code{(ice-9
+custom-ports)} module:
+
+@example
+(use-modules (ice-9 custom-ports))
+@end example
+
+Then to make a new port, call @code{make-custom-port}:
+
+@deffn {Scheme Procedure} make-custom-port @
+       [#:read] [#:write] @
+       [#:read-wait-fd] [#:write-wait-fd] [#:input-waiting?] @
+       [#:seek] [#:random-access?] [#:get-natural-buffer-sizes] @
+       [#:id] [#:print] @
+       [#:close] [#:close-on-gc?] @
+       [#:truncate] @
+       [#:encoding] [#:conversion-strategy]
+Make a new custom port.
+
+@xref{Encoding}, for more on @code{#:encoding} and
+@code{#:conversion-strategy}.
+@end deffn
+
+A port has a number of associated procedures and properties which
+collectively implement its behavior.  Creating a new custom port mostly
+involves writing these procedures, which are passed as keyword arguments
+to @code{make-custom-port}.
+
+@deffn {Scheme Port Method} #:read port dst start count
+A port's @code{#:read} implementation fills read buffers.  It should
+copy bytes to the supplied bytevector @var{dst}, starting at offset
+@var{start} and continuing for @var{count} bytes, and return the number
+of bytes that were read, or @code{#f} to indicate that reading any bytes
+would block.
+@end deffn
+
+@deffn {Scheme Port Method} #:write port src start count
+A port's @code{#:write} implementation flushes write buffers to the
+mutable store.  It should write out bytes from the supplied bytevector
+@var{src}, starting at offset @var{start} and continuing for @var{count}
+bytes, and return the number of bytes that were written, or @code{#f} to
+indicate writing any bytes would block.
+@end deffn
+
+If @code{make-custom-port} is passed a @code{#:read} argument, the port
+will be an input port.  Passing a @code{#:write} argument will make an
+output port, and passing both will make an input-output port.
+
+@deffn {Scheme Port Method} #:read-wait-fd port
+@deffnx {Scheme Port Method} #:write-wait-fd port
+If a port's @code{#:read} or @code{#:write} method returns @code{#f},
+that indicates that reading or writing would block, and that Guile
+should instead @code{poll} on the file descriptor returned by the port's
+@code{#:read-wait-fd} or @code{#:write-wait-fd} method, respectively,
+until the operation can complete.  @xref{Non-Blocking I/O}, for a more
+in-depth discussion.
+
+These methods must be implemented if the @code{#:read} or @code{#:write}
+method can return @code{#f}, and should return a non-negative integer
+file descriptor.  However they may be called explicitly by a user, for
+example to determine if a port may eventually be readable or writeable.
+If there is no associated file descriptor with the port, they should
+return @code{#f}.  The default implementation returns @code{#f}.
+@end deffn
+
+@deffn {Scheme Port Method} #:input-waiting? port
+In rare cases it is useful to be able to know whether data can be read
+from a port.  For example, if the user inputs @code{1 2 3} at the
+interactive console, after reading and evaluating @code{1} the console
+shouldn't then print another prompt before reading and evaluating
+@code{2} because there is input already waiting.  If the port can look
+ahead, then it should implement the @code{#:input-waiting?} method,
+which returns @code{#t} if input is available, or @code{#f} reading the
+next byte would block.  The default implementation returns @code{#t}.
+@end deffn
+
+@deffn {Scheme Port Method} #:seek port offset whence
+Set or get the current byte position of the port.  Guile will flush read
+and/or write buffers before seeking, as appropriate.  The @var{offset}
+and @var{whence} parameters are as for the @code{seek} procedure;
+@xref{Random Access}.
+
+The @code{#:seek} method returns the byte position after seeking.  To
+query the current position, @code{#:seek} will be called with an
+@var{offset} of 0 and @code{SEEK_CUR} for @var{whence}.  Other values of
+@var{offset} and/or @var{whence} will actually perform the seek.  The
+@code{#:seek} method should throw an error if the port is not seekable,
+which is what the default implementation does.
+@end deffn
+
+@deffn {Scheme Port Method} #:truncate port
+Truncate the port data to be specified length.  Guile will flush buffers
+beforehand, as appropriate.  The default implementation throws an error,
+indicating that truncation is not supported for this port.
+@end deffn
+
+@deffn {Scheme Port Method} #:random-access? port
+Return @code{#t} if @var{port} is open for random access, or @code{#f}
+otherwise.
+
+@cindex random access
+Seeking on a random-access port with buffered input, or switching to
+writing after reading, will cause the buffered input to be discarded and
+Guile will seek the port back the buffered number of bytes.  Likewise
+seeking on a random-access port with buffered output, or switching to
+reading after writing, will flush pending bytes with a call to the
+@code{write} procedure.  @xref{Buffering}.
+
+Indicate to Guile that your port needs this behavior by returning true
+from your @code{#:random-access?} method.  The default implementation of
+this function returns @code{#t} if the port has a @code{#:seek}
+implementation.
+@end deffn
+
+@deffn {Scheme Port Method} #:get-natural-buffer-sizes read-buf-size 
write-buf-size
+Guile will internally attach buffers to ports.  An input port always has
+a read buffer, and an output port always has a write buffer.
+@xref{Buffering}.  A port buffer consists of a bytevector, along with
+some cursors into that bytevector denoting where to get and put data.
+
+Port implementations generally don't have to be concerned with
+buffering: a port's @code{#:read} or @code{#:write} method will receive
+the buffer's bytevector as an argument, along with an offset and a
+length into that bytevector, and should then either fill or empty that
+bytevector.  However in some cases, port implementations may be able to
+provide an appropriate default buffer size to Guile.  For example file
+ports implement @code{#:get-natural-buffer-sizes} to let the operating
+system inform Guile about the appropriate buffer sizes for the
+particular file opened by the port.
+
+This method returns two values, corresponding to the natural read and
+write buffer sizes for the ports.  The two parameters
+@var{read-buf-size} and @var{write-buf-size} are Guile's guesses for
+what sizes might be good.  A custom @code{#:get-natural-buffer-sizes}
+method could override Guile's choices, or just pass them on, as the
+default implementation does.
+@end deffn
+
+@deffn {Scheme Port Method} #:print port out
+Called when the port @var{port} is written to @var{out}, e.g. via
+@code{(write port out)}.
+
+If @code{#:print} is not explicitly supplied, the default implementation
+prints something like @code{#<@var{mode}:@var{id} @var{address}>}, where
+@var{mode} is either @code{input}, @code{output}, or
+@code{input-output}, @var{id} comes from the @code{#:id} keyword
+argument (defaulting to @code{"custom-port"}), and @var{address} is a
+unique integer associated with the port.
+@end deffn
+
+@deffn {Scheme Port Method} #:close port
+Called when @var{port} is closed.  It should release any
+explicitly-managed resources used by the port.
+@end deffn
+
+By default, ports that are garbage collected just go away without
+closing or flushing any buffered output.  If your port needs to release
+some external resource like a file descriptor, or needs to make sure
+that its internal buffers are flushed even if the port is collected
+while it was open, then pass @code{#:close-on-gc? #t} to
+@code{make-custom-port}.  Note that in that case, the @code{#:close}
+method will probably be called on a separate thread.
+
+Note that calls to all of these methods can proceed in parallel and
+concurrently and from any thread up until the point that the port is
+closed.  The call to @code{close} will happen when no other method is
+running, and no method will be called after the @code{close} method is
+called.  If your port implementation needs mutual exclusion to prevent
+concurrency, it is responsible for locking appropriately.
+
+@node Low-Level Custom Ports in C
+@subsubsection Low-Level Custom Ports in C
+
+The @code{make-custom-port} procedure described in the previous section
+has similar functionality on the C level, though it is organized a bit
+differently.
+
+In C, the mechanism is that one creates a new @dfn{port type object}.
+The methods are then associated with the port type object instead of the
+port itself.  The port type object is an opaque pointer allocated when
+defining the port type, which serves as a key into the port API.
+
+Ports themselves have associated @dfn{stream} values.  The stream is a
+pointer controlled by the user, which is set when the port is created.
+Given a port, the @code{SCM_STREAM} macro returns its associated stream
+value, as a @code{scm_t_bits}.  Note that your port methods are only
+ever called with ports of your type, so port methods can safely cast
+this value to the expected type.  Contrast this to Scheme, which doesn't
+need access to the stream because the @code{make-custom-port} methods
+can be closures that share port-specific data directly.
+
+A port type is created by calling @code{scm_make_port_type}.
+
+@deftypefun scm_t_port_type* scm_make_port_type (char *name, size_t (*read) 
(SCM port, SCM dst, size_t start, size_t count), size_t (*write) (SCM port, SCM 
src, size_t start, size_t count))
+Define a new port type.  The @var{name} parameter is like the
+@code{#:id} parameter to @code{make-custom-port}; and @var{read} and
+@var{write} are like @code{make-custom-port}'s @code{#:read} and
+@code{#:write}, except that they should return @code{(size_t)-1} if the
+read or write operation would block, instead of @code{#f}.
+@end deftypefun
+
+@deftypefun void scm_set_port_read_wait_fd (scm_t_port_type *type, int 
(*wait_fd) (SCM port))
+@deftypefunx void scm_set_port_write_wait_fd (scm_t_port_type *type, int 
(*wait_fd) (SCM port))
+@deftypefunx void scm_set_port_print (scm_t_port_type *type, int (*print) (SCM 
port, SCM dest_port, scm_print_state *pstate))
+@deftypefunx void scm_set_port_close (scm_t_port_type *type, void (*close) 
(SCM port))
+@deftypefunx void scm_set_port_needs_close_on_gc (scm_t_port_type *type, int 
needs_close_p)
+@deftypefunx void scm_set_port_seek (scm_t_port_type *type, scm_t_off (*seek) 
(SCM port, scm_t_off offset, int whence))
+@deftypefunx void scm_set_port_truncate (scm_t_port_type *type, void 
(*truncate) (SCM port, scm_t_off length))
+@deftypefunx void scm_set_port_random_access_p (scm_t_port_type *type, int 
(*random_access_p) (SCM port));
+@deftypefunx void scm_set_port_input_waiting (scm_t_port_type *type, int 
(*input_waiting) (SCM port));
+@deftypefunx void scm_set_port_get_natural_buffer_sizes @
+  (scm_t_port_type *type, void (*get_natural_buffer_sizes) (SCM, size_t 
*read_buf_size, size_t *write_buf_size))
+Port method definitions.  @xref{Low-Level Custom Ports}, for more
+details on each of these methods.
+@end deftypefun
+
+Once you have your port type, you can create ports with
+@code{scm_c_make_port}, or @code{scm_c_make_port_with_encoding}.
+
+@deftypefun SCM scm_c_make_port_with_encoding (scm_t_port_type *type, unsigned 
long mode_bits, SCM encoding, SCM conversion_strategy, scm_t_bits stream)
+@deftypefunx SCM scm_c_make_port (scm_t_port_type *type, unsigned long 
mode_bits, scm_t_bits stream)
+Make a port with the given @var{type}.  The @var{stream} indicates the
+private data associated with the port, which your port implementation
+may later retrieve with @code{SCM_STREAM}.  The mode bits should include
+one or more of the flags @code{SCM_RDNG} or @code{SCM_WRTNG}, indicating
+that the port is an input and/or an output port, respectively.  The mode
+bits may also include @code{SCM_BUF0} or @code{SCM_BUFLINE}, indicating
+that the port should be unbuffered or line-buffered, respectively.  The
+default is that the port will be block-buffered.  @xref{Buffering}.
+
+As you would imagine, @var{encoding} and @var{conversion_strategy}
+specify the port's initial textual encoding and conversion strategy.
+Both are symbols.  @code{scm_c_make_port} is the same as
+@code{scm_c_make_port_with_encoding}, except it uses the default port
+encoding and conversion strategy.
+@end deftypefun
+
+At this point you may be wondering whether to implement your custom port
+type in C or Scheme.  The answer is that probably you want to use
+Scheme's @code{make-custom-port}.  The speed is similar between C and
+Scheme, and ports implemented in C have the disadvantage of not being
+suspendable.  @xref{Non-Blocking I/O}.
+
 
 @node Venerable Port Interfaces
 @subsection Venerable Port Interfaces
@@ -1692,179 +1940,6 @@ second, the @code{scm_t_uint32*} buffer is a string in 
the UTF-32
 encoding.  These routines will update the port's line and column.
 @end deftypefn
 
-@node I/O Extensions
-@subsection Implementing New Port Types in C
-
-This section describes how to implement a new port type in C.  Although
-ports support many operations, as a data structure they present an
-opaque interface to the user.  To the port implementor, you have two
-pieces of information to work with: the port type, and the port's
-``stream''.  The port type is an opaque pointer allocated when defining
-your port type.  It is your key into the port API, and it helps you
-identify which ports are actually yours.  The ``stream'' is a pointer
-you control, and which you set when you create a port.  Get a stream
-from a port using the @code{SCM_STREAM} macro.  Note that your port
-methods are only ever called with ports of your type.
-
-A port type is created by calling @code{scm_make_port_type}.  Once you
-have your port type, you can create ports with @code{scm_c_make_port},
-or @code{scm_c_make_port_with_encoding}.
-
-@deftypefun scm_t_port_type* scm_make_port_type (char *name, size_t (*read) 
(SCM port, SCM dst, size_t start, size_t count), size_t (*write) (SCM port, SCM 
src, size_t start, size_t count))
-Define a new port type.  The @var{name}, @var{read} and @var{write}
-parameters are initial values for those port type fields, as described
-below.  The other fields are initialized with default values and can be
-changed later.
-@end deftypefun
-
-@deftypefun SCM scm_c_make_port_with_encoding (scm_t_port_type *type, unsigned 
long mode_bits, SCM encoding, SCM conversion_strategy, scm_t_bits stream)
-@deftypefunx SCM scm_c_make_port (scm_t_port_type *type, unsigned long 
mode_bits, scm_t_bits stream)
-Make a port with the given @var{type}.  The @var{stream} indicates the
-private data associated with the port, which your port implementation
-may later retrieve with @code{SCM_STREAM}.  The mode bits should include
-one or more of the flags @code{SCM_RDNG} or @code{SCM_WRTNG}, indicating
-that the port is an input and/or an output port, respectively.  The mode
-bits may also include @code{SCM_BUF0} or @code{SCM_BUFLINE}, indicating
-that the port should be unbuffered or line-buffered, respectively.  The
-default is that the port will be block-buffered.  @xref{Buffering}.
-
-As you would imagine, @var{encoding} and @var{conversion_strategy}
-specify the port's initial textual encoding and conversion strategy.
-Both are symbols.  @code{scm_c_make_port} is the same as
-@code{scm_c_make_port_with_encoding}, except it uses the default port
-encoding and conversion strategy.
-@end deftypefun
-
-The port type has a number of associate procedures and properties which
-collectively implement the port's behavior.  Creating a new port type
-mostly involves writing these procedures.
-
-@table @code
-@item name
-A pointer to a NUL terminated string: the name of the port type.  This
-property is initialized via the first argument to
-@code{scm_make_port_type}.
-
-@item read
-A port's @code{read} implementation fills read buffers.  It should copy
-bytes to the supplied bytevector @code{dst}, starting at offset
-@code{start} and continuing for @code{count} bytes, returning the number
-of bytes read.
-
-@item write
-A port's @code{write} implementation flushes write buffers to the
-mutable store.
-It should write out bytes from the supplied bytevector @code{src},
-starting at offset @code{start} and continuing for @code{count} bytes,
-and return the number of bytes that were written.
-
-@item read_wait_fd
-@itemx write_wait_fd
-If a port's @code{read} or @code{write} function returns @code{(size_t)
--1}, that indicates that reading or writing would block.  In that case
-to preserve the illusion of a blocking read or write operation, Guile's
-C port run-time will @code{poll} on the file descriptor returned by
-either the port's @code{read_wait_fd} or @code{write_wait_fd} function.
-Set using
-
-@deftypefun void scm_set_port_read_wait_fd (scm_t_port_type *type, int 
(*wait_fd) (SCM port))
-@deftypefunx void scm_set_port_write_wait_fd (scm_t_port_type *type, int 
(*wait_fd) (SCM port))
-@end deftypefun
-
-Only a port type which implements the @code{read_wait_fd} or
-@code{write_wait_fd} port methods can usefully return @code{(size_t) -1}
-from a read or write function.  @xref{Non-Blocking I/O}, for more on
-non-blocking I/O in Guile.
-
-@item print
-Called when @code{write} is called on the port, to print a port
-description.  For example, for a file port it may produce something
-like: @code{#<input: /etc/passwd 3>}.  Set using
-
-@deftypefun void scm_set_port_print (scm_t_port_type *type, int (*print) (SCM 
port, SCM dest_port, scm_print_state *pstate))
-The first argument @var{port} is the port being printed, the second
-argument @var{dest_port} is where its description should go.
-@end deftypefun
-
-@item close
-Called when the port is closed.  It should free any resources used by
-the port.  Set using
-
-@deftypefun void scm_set_port_close (scm_t_port_type *type, void (*close) (SCM 
port))
-@end deftypefun
-
-By default, ports that are garbage collected just go away without
-closing.  If your port type needs to release some external resource like
-a file descriptor, or needs to make sure that its internal buffers are
-flushed even if the port is collected while it was open, then mark the
-port type as needing a close on GC.
-
-@deftypefun void scm_set_port_needs_close_on_gc (scm_t_port_type *type, int 
needs_close_p)
-@end deftypefun
-
-@item seek
-Set the current position of the port.  Guile will flush read and/or
-write buffers before seeking, as appropriate.
-
-@deftypefun void scm_set_port_seek (scm_t_port_type *type, scm_t_off (*seek) 
(SCM port, scm_t_off offset, int whence))
-@end deftypefun
-
-@item truncate
-Truncate the port data to be specified length.  Guile will flush buffers
-before hand, as appropriate.  Set using
-
-@deftypefun void scm_set_port_truncate (scm_t_port_type *type, void 
(*truncate) (SCM port, scm_t_off length))
-@end deftypefun
-
-@item random_access_p
-Determine whether this port is a random-access port.
-
-@cindex random access
-Seeking on a random-access port with buffered input, or switching to
-writing after reading, will cause the buffered input to be discarded and
-Guile will seek the port back the buffered number of bytes.  Likewise
-seeking on a random-access port with buffered output, or switching to
-reading after writing, will flush pending bytes with a call to the
-@code{write} procedure.  @xref{Buffering}.
-
-Indicate to Guile that your port needs this behavior by returning a
-nonzero value from your @code{random_access_p} function.  The default
-implementation of this function returns nonzero if the port type
-supplies a seek implementation.
-
-@deftypefun void scm_set_port_random_access_p (scm_t_port_type *type, int 
(*random_access_p) (SCM port));
-@end deftypefun
-
-@item get_natural_buffer_sizes
-Guile will internally attach buffers to ports.  An input port always has
-a read buffer and an output port always has a write buffer.
-@xref{Buffering}.  A port buffer consists of a bytevector, along with
-some cursors into that bytevector denoting where to get and put data.
-
-Port implementations generally don't have to be concerned with
-buffering: a port type's @code{read} or @code{write} function will
-receive the buffer's bytevector as an argument, along with an offset and
-a length into that bytevector, and should then either fill or empty that
-bytevector.  However in some cases, port implementations may be able to
-provide an appropriate default buffer size to Guile.
-
-@deftypefun void scm_set_port_get_natural_buffer_sizes @
-  (scm_t_port_type *type, void (*get_natural_buffer_sizes) (SCM, size_t 
*read_buf_size, size_t *write_buf_size))
-Fill in @var{read_buf_size} and @var{write_buf_size} with an appropriate 
buffer size for this port, if one is known.
-@end deftypefun
-
-File ports implement a @code{get_natural_buffer_sizes} to let the
-operating system inform Guile about the appropriate buffer sizes for the
-particular file opened by the port.
-@end table
-
-Note that calls to all of these methods can proceed in parallel and
-concurrently and from any thread up until the point that the port is
-closed.  The call to @code{close} will happen when no other method is
-running, and no method will be called after the @code{close} method is
-called.  If your port implementation needs mutual exclusion to prevent
-concurrency, it is responsible for locking appropriately.
-
 @node Non-Blocking I/O
 @subsection Non-Blocking I/O
 
@@ -1914,7 +1989,8 @@ read or write from this file and the read or write 
returns a result
 indicating that more data can only be had by doing a blocking read or
 write, Guile will block by polling on the socket's @code{read-wait-fd}
 or @code{write-wait-fd}, to preserve the illusion of a blocking read or
-write.  @xref{I/O Extensions} for more on those internal interfaces.
+write.  @xref{Low-Level Custom Ports} for more on those internal
+interfaces.
 
 So far we have just reproduced the status quo: the file descriptor is
 non-blocking, but the operations on the port do block.  To go farther,
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 36b3ed502..eb971fb1c 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -1,6 +1,6 @@
 ## Process this file with Automake to create Makefile.in
 ##
-##   Copyright (C) 1998-2004, 2006-2014, 2016-2022
+##   Copyright (C) 1998-2004, 2006-2014, 2016-2023
 ##     Free Software Foundation, Inc.
 ##
 ##   This file is part of GUILE.
@@ -139,6 +139,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES =             
                \
        chooks.c                                \
        control.c                               \
        continuations.c                         \
+       custom-ports.c                          \
        debug.c                                 \
        deprecated.c                            \
        deprecation.c                           \
@@ -259,6 +260,7 @@ DOT_X_FILES =                                       \
        chars.x                                 \
        control.x                               \
        continuations.x                         \
+       custom-ports.x                          \
        debug.x                                 \
        deprecated.x                            \
        deprecation.x                           \
@@ -366,6 +368,7 @@ DOT_DOC_FILES =                             \
        chars.doc                               \
        control.doc                             \
        continuations.doc                       \
+       custom-ports.doc                        \
        debug.doc                               \
        deprecated.doc                          \
        deprecation.doc                         \
@@ -530,7 +533,8 @@ uninstall-hook:
 ## compile, since they are #included.  So instead we list them here.
 ## Perhaps we can deal with them normally once the merge seems to be
 ## working.
-noinst_HEADERS = elf.h                                         \
+noinst_HEADERS = custom-ports.h                                        \
+                 elf.h                                         \
                  integers.h                                    \
                  intrinsics.h                                  \
                  quicksort.i.c                                  \
diff --git a/libguile/custom-ports.c b/libguile/custom-ports.c
new file mode 100644
index 000000000..6e2b2ea99
--- /dev/null
+++ b/libguile/custom-ports.c
@@ -0,0 +1,205 @@
+/* Copyright 2023
+     Free Software Foundation, Inc.
+
+   This file is part of Guile.
+
+   Guile 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.
+
+   Guile 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 Guile.  If not, see
+   <https://www.gnu.org/licenses/>.  */
+
+#ifdef HAVE_CONFIG_H
+#include <config.h>
+#endif
+
+#include "boolean.h"
+#include "eval.h"
+#include "extensions.h"
+#include "gsubr.h"
+#include "modules.h"
+#include "numbers.h"
+#include "ports-internal.h"
+#include "syscalls.h"
+#include "values.h"
+#include "variable.h"
+#include "version.h"
+
+#include "custom-ports.h"
+
+
+#define FOR_EACH_METHOD_EXCEPT_READ_WRITE(M) \
+  M(print, "print") \
+  M(read_wait_fd, "read-wait-fd") \
+  M(write_wait_fd, "write-wait-fd") \
+  M(seek, "seek") \
+  M(close, "close") \
+  M(get_natural_buffer_sizes, "get-natural-buffer-sizes") \
+  M(random_access_p, "random-access?") \
+  M(input_waiting, "input-waiting?") \
+  M(truncate, "truncate")
+
+#define FOR_EACH_METHOD(M)             \
+  FOR_EACH_METHOD_EXCEPT_READ_WRITE(M) \
+  M(read, "read") \
+  M(write, "write")
+
+#define DEF_VAR(c_name, scm_name) static SCM c_name##_var;
+FOR_EACH_METHOD (DEF_VAR)
+#undef DEF_VAR
+     static int custom_port_print (SCM exp, SCM port,
+                                   scm_print_state * pstate)
+{
+  SCM data = SCM_PACK (SCM_STREAM (exp));
+  scm_call_3 (scm_variable_ref (print_var), exp, data, port);
+  return 1;
+}
+
+static int
+custom_port_read_wait_fd (SCM port)
+{
+  SCM data = SCM_PACK (SCM_STREAM (port));
+  SCM res = scm_call_2 (scm_variable_ref (read_wait_fd_var), port, data);
+  return scm_is_false (res) ? -1 : scm_to_signed_integer (res, 0, INT_MAX);
+}
+
+static int
+custom_port_write_wait_fd (SCM port)
+{
+  SCM data = SCM_PACK (SCM_STREAM (port));
+  SCM res = scm_call_2 (scm_variable_ref (write_wait_fd_var), port, data);
+  return scm_is_false (res) ? -1 : scm_to_signed_integer (res, 0, INT_MAX);
+}
+
+static scm_t_off
+custom_port_seek (SCM port, scm_t_off offset, int whence)
+{
+  SCM data = SCM_PACK (SCM_STREAM (port));
+  return scm_to_off_t (scm_call_4 (scm_variable_ref (seek_var), port, data,
+                                   scm_from_off_t (offset),
+                                   scm_from_int (whence)));
+}
+
+static void
+custom_port_close (SCM port)
+{
+  SCM data = SCM_PACK (SCM_STREAM (port));
+  scm_call_2 (scm_variable_ref (close_var), port, data);
+}
+
+static void
+custom_port_get_natural_buffer_sizes (SCM port, size_t *read_size,
+                                      size_t *write_size)
+{
+  SCM data = SCM_PACK (SCM_STREAM (port));
+  SCM res = scm_call_4 (scm_variable_ref (get_natural_buffer_sizes_var),
+                        port, data, scm_from_size_t (*read_size),
+                        scm_from_size_t (*write_size));
+  *read_size = scm_to_size_t (scm_c_value_ref (res, 0));
+  *write_size = scm_to_size_t (scm_c_value_ref (res, 1));
+}
+
+static int
+custom_port_random_access_p (SCM port)
+{
+  SCM data = SCM_PACK (SCM_STREAM (port));
+  return scm_to_bool (scm_call_2 (scm_variable_ref (random_access_p_var),
+                                  port, data));
+}
+
+static int
+custom_port_input_waiting (SCM port)
+{
+  SCM data = SCM_PACK (SCM_STREAM (port));
+  return scm_to_bool (scm_call_2 (scm_variable_ref (input_waiting_var),
+                                  port, data));
+}
+
+static void
+custom_port_truncate (SCM port, scm_t_off length)
+{
+  SCM data = SCM_PACK (SCM_STREAM (port));
+  scm_call_3 (scm_variable_ref (truncate_var), port, data,
+              scm_from_off_t (length));
+}
+
+static scm_t_port_type *custom_port_type;
+static scm_t_port_type *custom_port_type_with_close_on_gc;
+
+SCM_DEFINE_STATIC (make_custom_port, "%make-custom-port", 6, 0, 0,
+                   (SCM input_p, SCM output_p, SCM stream, SCM encoding,
+                    SCM conversion_strategy, SCM close_on_gc_p), "")
+{
+  long mode_bits = 0;
+  if (scm_is_true (input_p))
+    mode_bits |= SCM_RDNG;
+  if (scm_is_true (output_p))
+    mode_bits |= SCM_WRTNG;
+
+  scm_t_port_type *pt = scm_is_true (close_on_gc_p) ?
+    custom_port_type_with_close_on_gc : custom_port_type;
+
+  return scm_c_make_port_with_encoding (pt, mode_bits, encoding,
+                                        conversion_strategy,
+                                        SCM_UNPACK (stream));
+}
+
+SCM_DEFINE_STATIC (custom_port_data, "%custom-port-data", 1, 0, 0,
+                   (SCM port), "")
+#define FUNC_NAME s_custom_port_data
+{
+  SCM_ASSERT (SCM_PORT_TYPE (port) == custom_port_type
+              || SCM_PORT_TYPE (port) == custom_port_type_with_close_on_gc,
+              port, SCM_ARG1, "custom port");
+  return SCM_PACK (SCM_STREAM (port));
+}
+
+#undef FUNC_NAME
+
+static void
+scm_init_custom_ports (void)
+{
+#define RESOLVE_VAR(c_name, scm_name) \
+  c_name##_var = scm_c_lookup ("custom-port-" scm_name);
+  FOR_EACH_METHOD (RESOLVE_VAR);
+#undef RESOlVE_VAR
+
+  custom_port_type = scm_make_port_type ("custom-port", NULL, NULL);
+  custom_port_type_with_close_on_gc =
+    scm_make_port_type ("custom-port", NULL, NULL);
+
+#define INIT_PORT_TYPE(c_name, scm_name)                                \
+  scm_set_port_##c_name (custom_port_type, custom_port_##c_name);       \
+  scm_set_port_##c_name (custom_port_type_with_close_on_gc,             \
+                         custom_port_##c_name);
+  FOR_EACH_METHOD_EXCEPT_READ_WRITE (INIT_PORT_TYPE);
+#undef INIT_PORT_TYPE
+
+  scm_set_port_scm_read (custom_port_type, scm_variable_ref (read_var));
+  scm_set_port_scm_write (custom_port_type, scm_variable_ref (write_var));
+  scm_set_port_scm_read (custom_port_type_with_close_on_gc,
+                         scm_variable_ref (read_var));
+  scm_set_port_scm_write (custom_port_type_with_close_on_gc,
+                          scm_variable_ref (write_var));
+
+  scm_set_port_needs_close_on_gc (custom_port_type_with_close_on_gc, 1);
+
+#include "custom-ports.x"
+}
+
+void
+scm_register_custom_ports (void)
+{
+  scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
+                            "scm_init_custom_ports",
+                            (scm_t_extension_init_func) scm_init_custom_ports,
+                            NULL);
+}
diff --git a/libguile/custom-ports.h b/libguile/custom-ports.h
new file mode 100644
index 000000000..287a87837
--- /dev/null
+++ b/libguile/custom-ports.h
@@ -0,0 +1,29 @@
+#ifndef SCM_CUSTOM_PORTS_H
+#define SCM_CUSTOM_PORTS_H
+
+/* Copyright 2023
+     Free Software Foundation, Inc.
+
+   This file is part of Guile.
+
+   Guile 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.
+
+   Guile 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 Guile.  If not, see
+   <https://www.gnu.org/licenses/>.  */
+
+
+
+#include "libguile/scm.h"
+
+SCM_INTERNAL void scm_register_custom_ports (void);
+
+#endif /* SCM_CUSTOM_PORTS_H */
diff --git a/libguile/init.c b/libguile/init.c
index b0a39e6d4..da3d2f0b7 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -1,4 +1,4 @@
-/* Copyright 1995-2004,2006,2009-2014,2016-2020
+/* Copyright 1995-2004,2006,2009-2014,2016-2021,2023
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -52,6 +52,7 @@
 #include "chars.h"
 #include "continuations.h"
 #include "control.h"
+#include "custom-ports.h"
 #include "debug.h"
 #ifdef GUILE_DEBUG_MALLOC
 #include "debug-malloc.h"
@@ -373,6 +374,7 @@ scm_i_init_guile (void *base)
   scm_bootstrap_programs ();
   scm_bootstrap_vm ();
   scm_register_atomic ();
+  scm_register_custom_ports ();
   scm_register_fdes_finalizers ();
   scm_register_foreign ();
   scm_register_foreign_object ();
diff --git a/module/ice-9/custom-ports.scm b/module/ice-9/custom-ports.scm
new file mode 100644
index 000000000..ba50d238a
--- /dev/null
+++ b/module/ice-9/custom-ports.scm
@@ -0,0 +1,167 @@
+;;; custom-ports.scm --- Defining new ports in Scheme
+;;; Copyright (C) 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 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:
+;;;
+;;; Code:
+
+(define-module (ice-9 custom-ports)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 textual-ports)
+  #:use-module (srfi srfi-9)
+  #:declarative? #f ; Because of extension.
+  #:export (make-custom-port))
+
+;; Replaced by extension; here just to suppress warnings.
+(define %make-custom-port error)
+(define %custom-port-data error)
+
+(define-record-type <custom-port-data>
+  (make-custom-port-data print read write read-wait-fd write-wait-fd
+                         seek close get-natural-buffer-sizes
+                         random-access? input-waiting? truncate)
+  custom-port-data?
+  (print custom-port-data-print)
+  (read custom-port-data-read)
+  (write custom-port-data-write)
+  (read-wait-fd custom-port-data-read-wait-fd)
+  (write-wait-fd custom-port-data-write-wait-fd)
+  (seek custom-port-data-seek)
+  (close custom-port-data-close)
+  (get-natural-buffer-sizes custom-port-data-get-natural-buffer-sizes)
+  (random-access? custom-port-data-random-access?)
+  (input-waiting? custom-port-data-input-waiting?)
+  (truncate custom-port-data-truncate))
+
+(define-syntax define-custom-port-dispatcher
+  (lambda (stx)
+    (define (prefixed-name prefix suffix)
+      (datum->syntax suffix (symbol-append prefix (syntax->datum suffix))))
+    (syntax-case stx ()
+      ((_ stem arg ...)
+       (with-syntax ((accessor (prefixed-name 'custom-port-data- #'stem))
+                     (dispatcher (prefixed-name 'custom-port- #'stem)))
+         #'(define (dispatcher port data arg ...)
+             ((accessor data) port arg ...)))))))
+
+;; These bindings are captured by the extension.
+(define (custom-port-read port bv start count)
+  ((custom-port-data-read (%custom-port-data port)) port bv start count))
+(define (custom-port-write port bv start count)
+  ((custom-port-data-write (%custom-port-data port)) port bv start count))
+(define-custom-port-dispatcher print out-port)
+(define-custom-port-dispatcher read-wait-fd)
+(define-custom-port-dispatcher write-wait-fd)
+(define-custom-port-dispatcher seek offset whence)
+(define-custom-port-dispatcher close)
+(define-custom-port-dispatcher get-natural-buffer-sizes read-size write-size)
+(define-custom-port-dispatcher random-access?)
+(define-custom-port-dispatcher input-waiting?)
+(define-custom-port-dispatcher truncate length)
+
+
+(eval-when (load)
+  (load-extension (string-append "libguile-" (effective-version))
+                  "scm_init_custom_ports"))
+
+(define* (make-default-print #:key (id "custom-port"))
+  (lambda (port out-port)
+    (define mode
+      (cond
+       ((port-closed? port) "closed:")
+       ((input-port? port) (if (output-port? port) "input-output:" "input:"))
+       ((output-port? port) "output:")
+       (else "bogus:")))
+    (put-string out-port "#<")
+    (put-string out-port mode)
+    (put-string out-port id)
+    (put-string out-port " ")
+    (put-string out-port (number->string (object-address port) 16))
+    (put-string out-port ">")))
+
+(define (default-read-wait-fd port) #f)
+(define (default-write-wait-fd port) #f)
+
+(define (default-seek port offset whence)
+  (error "custom port did not define a seek method" port))
+
+(define (default-close port) (values))
+
+(define (default-get-natural-buffer-sizes port read-buf-size write-buf-size)
+  (values read-buf-size write-buf-size))
+
+(define (make-default-random-access? seek)
+  (if seek
+      (lambda (port) #t)
+      (lambda (port) #f)))
+
+(define (default-input-waiting? port) #t)
+(define (default-truncate port length)
+  (error "custom port did not define a truncate method" port))
+
+(define* (make-custom-port
+          #:key
+          read
+          write
+          (read-wait-fd default-read-wait-fd)
+          (input-waiting? (and read default-input-waiting?))
+          (write-wait-fd default-write-wait-fd)
+          (seek #f)
+          (random-access? #f)
+          (close #f)
+          (get-natural-buffer-sizes default-get-natural-buffer-sizes)
+          (id "custom-port")
+          (print (make-default-print #:id id))
+          (truncate default-truncate)
+          (encoding (string->symbol (fluid-ref %default-port-encoding)))
+          (conversion-strategy (fluid-ref %default-port-conversion-strategy))
+          (close-on-gc? #f))
+  "Create a custom port whose behavior is determined by the methods passed
+as keyword arguments.  Supplying a @code{#:read} method will make an input
+port, passing @code{#:write} will make an output port, and passing them
+both will make an input/output port.
+
+See the manual for full documentation on the semantics of these
+methods."
+  (define (canonicalize-encoding encoding)
+    (match encoding
+      (#f 'ISO-8859-1)
+      ((or 'ISO-8859-1 'UTF-8
+           'UTF-16 'UTF-16LE 'UTF-16BE
+           'UTF-32 'UTF-32LE 'UTF-32BE) encoding)
+      ((? symbol?)
+       (string->symbol (string-upcase (symbol->string encoding))))))
+  (define (canonicalize-conversion-strategy conversion-strategy)
+    (match encoding
+      ('escape 'escape)
+      ('substitute 'substitute)
+      (_ 'error)))
+  (let ((seek (or seek default-seek))
+        (close (or close default-close))
+        (random-access? (or random-access?
+                            (if seek (lambda (_) #t) (lambda (_) #f))))
+        (close-on-gc? (and close close-on-gc?)))
+    (define data
+      (make-custom-port-data print read write read-wait-fd write-wait-fd
+                             seek close get-natural-buffer-sizes
+                             random-access? input-waiting? truncate))
+    (unless (or read write)
+      (error "Must have at least one I/O method (#:read and #:write)"))
+    (%make-custom-port (->bool read) (->bool write) data
+                       (canonicalize-encoding encoding)
+                       (canonicalize-conversion-strategy conversion-strategy)
+                       close-on-gc?)))