mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

Add "custom ports"

Browse source 
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.
This commit is contained in:
Andy Wingo 2023-05-27 21:51:57 +02:00
parent 67dbc60e8f
commit 1852fbfef9
7 changed files with 664 additions and 180 deletions
Download patch file Download diff file Expand all files Collapse all files

3
am/bootstrap.am
View file

@ -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 \

428
doc/ref/api-io.texi
View file

@ -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,

8
libguile/Makefile.am
View file

@ -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 \

205
libguile/custom-ports.c Normal file
View file

@ -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);
}

29
libguile/custom-ports.h Normal file
View file

@ -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 */

4
libguile/init.c
View file

@ -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 ();

167
module/ice-9/custom-ports.scm Normal file
View file

@ -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?)))