wingo pushed a commit to branch wip-whippet
in repository guile.
commit 2a015937ca2abc230996db821c7aed2888918ff1
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Wed Jun 18 10:37:42 2025 +0200
Move bytevector input ports implementation to Scheme
* module/ice-9/binary-ports.scm (open-bytevector-input-port): New
implementation.
* libguile/r6rs-ports.c (scm_open_bytevector_input_port): Proxy to
Scheme.
---
libguile/r6rs-ports.c | 146 +++++-------------------------------------
module/ice-9/binary-ports.scm | 43 +++++++++++--
2 files changed, 55 insertions(+), 134 deletions(-)
diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c
index 9390ce678..da47d2189 100644
--- a/libguile/r6rs-ports.c
+++ b/libguile/r6rs-ports.c
@@ -57,22 +57,6 @@ SCM_SYMBOL (sym_error, "error");
-/* Unimplemented features. */
-
-
-/* Transoders are currently not implemented since Guile 1.8 is not
- Unicode-capable. Thus, most of the code here assumes the use of the
- binary transcoder. */
-static inline void
-transcoders_not_implemented (void)
-{
- fprintf (stderr, "%s: warning: transcoders not implemented\n",
- PACKAGE_NAME);
-}
-
-
-
-
/* End-of-file object. */
SCM_DEFINE (scm_eof_object, "eof-object", 0, 0, 0,
@@ -87,118 +71,6 @@ SCM_DEFINE (scm_eof_object, "eof-object", 0, 0, 0,
-/* Input ports. */
-
-#define MAX(A, B) ((A) >= (B) ? (A) : (B))
-#define MIN(A, B) ((A) < (B) ? (A) : (B))
-
-/* Bytevector input ports. */
-static scm_t_port_type *bytevector_input_port_type = 0;
-
-struct bytevector_input_port {
- SCM bytevector;
- size_t pos;
-};
-
-static inline SCM
-make_bytevector_input_port (SCM bv)
-{
- const unsigned long mode_bits = SCM_RDNG;
- struct bytevector_input_port *stream;
-
- stream = scm_gc_typed_calloc (struct bytevector_input_port);
- stream->bytevector = bv;
- stream->pos = 0;
- return scm_c_make_port_with_encoding (bytevector_input_port_type, mode_bits,
- sym_ISO_8859_1, sym_error,
- (scm_t_bits) stream);
-}
-
-static size_t
-bytevector_input_port_read (SCM port, SCM dst, size_t start, size_t count)
-{
- size_t remaining;
- struct bytevector_input_port *stream = (void *) SCM_STREAM (port);
-
- if (stream->pos >= SCM_BYTEVECTOR_LENGTH (stream->bytevector))
- return 0;
-
- remaining = SCM_BYTEVECTOR_LENGTH (stream->bytevector) - stream->pos;
- if (remaining < count)
- count = remaining;
-
- memcpy (SCM_BYTEVECTOR_CONTENTS (dst) + start,
- SCM_BYTEVECTOR_CONTENTS (stream->bytevector) + stream->pos,
- count);
-
- stream->pos += count;
-
- return count;
-}
-
-static scm_t_off
-bytevector_input_port_seek (SCM port, scm_t_off offset, int whence)
-#define FUNC_NAME "bytevector_input_port_seek"
-{
- struct bytevector_input_port *stream = (void *) SCM_STREAM (port);
- size_t base;
- scm_t_off target;
-
- if (whence == SEEK_CUR)
- base = stream->pos;
- else if (whence == SEEK_SET)
- base = 0;
- else if (whence == SEEK_END)
- base = SCM_BYTEVECTOR_LENGTH (stream->bytevector);
- else
- scm_wrong_type_arg_msg (FUNC_NAME, 0, port, "invalid `seek' parameter");
-
- if (base > SCM_T_OFF_MAX
- || INT_ADD_OVERFLOW ((scm_t_off) base, offset))
- scm_num_overflow (FUNC_NAME);
- target = (scm_t_off) base + offset;
-
- if (target >= 0 && target <= SCM_BYTEVECTOR_LENGTH (stream->bytevector))
- stream->pos = target;
- else
- scm_out_of_range (FUNC_NAME, scm_from_off_t (offset));
-
- return target;
-}
-#undef FUNC_NAME
-
-
-/* Instantiate the bytevector input port type. */
-static inline void
-initialize_bytevector_input_ports (void)
-{
- bytevector_input_port_type =
- scm_make_port_type ("r6rs-bytevector-input-port",
- bytevector_input_port_read,
- NULL);
-
- scm_set_port_seek (bytevector_input_port_type, bytevector_input_port_seek);
-}
-
-
-SCM_DEFINE (scm_open_bytevector_input_port,
- "open-bytevector-input-port", 1, 1, 0,
- (SCM bv, SCM transcoder),
- "Return an input port whose contents are drawn from "
- "bytevector @var{bv}.")
-#define FUNC_NAME s_scm_open_bytevector_input_port
-{
- SCM_VALIDATE_BYTEVECTOR (1, bv);
- if (!SCM_UNBNDP (transcoder) && !scm_is_false (transcoder))
- transcoders_not_implemented ();
-
- return make_bytevector_input_port (bv);
-}
-#undef FUNC_NAME
-
-
-
-
/* Binary input. */
/* We currently don't support specific binary input ports. */
@@ -351,6 +223,8 @@ SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some",
1, 0, 0,
}
#undef FUNC_NAME
+#define MIN(A, B) ((A) < (B) ? (A) : (B))
+
SCM_DEFINE (scm_get_bytevector_some_x, "get-bytevector-some!", 4, 0, 0,
(SCM port, SCM bv, SCM start, SCM count),
"Read up to @var{count} bytes from @var{port}, blocking "
@@ -518,18 +392,31 @@ SCM_DEFINE (scm_unget_bytevector, "unget-bytevector", 2,
2, 0,
-/* Bytevector output port. */
+/* Bytevector input and output ports. */
+static SCM open_bytevector_input_port_var;
static SCM open_bytevector_output_port_var;
static scm_i_pthread_once_t bytevector_port_vars = SCM_I_PTHREAD_ONCE_INIT;
static void
init_bytevector_port_vars (void)
{
+ open_bytevector_input_port_var =
+ scm_c_public_lookup ("ice-9 binary-ports", "open-bytevector-input-port");
open_bytevector_output_port_var =
scm_c_public_lookup ("ice-9 binary-ports", "open-bytevector-output-port");
}
+SCM
+scm_open_bytevector_input_port (SCM bv, SCM transcoder)
+{
+ scm_i_pthread_once (&bytevector_port_vars, init_bytevector_port_vars);
+ return SCM_UNBNDP (transcoder)
+ ? scm_call_1 (scm_variable_ref (open_bytevector_input_port_var), bv)
+ : scm_call_2 (scm_variable_ref (open_bytevector_input_port_var), bv,
+ transcoder);
+}
+
SCM
scm_open_bytevector_output_port (SCM transcoder)
{
@@ -724,7 +611,6 @@ scm_register_r6rs_ports (void)
(scm_t_extension_init_func) scm_init_r6rs_ports,
NULL);
- initialize_bytevector_input_ports ();
initialize_transcoded_ports ();
}
diff --git a/module/ice-9/binary-ports.scm b/module/ice-9/binary-ports.scm
index 390cd4f65..cb8fe1efe 100644
--- a/module/ice-9/binary-ports.scm
+++ b/module/ice-9/binary-ports.scm
@@ -53,6 +53,9 @@
;; Note that this extension also defines %make-transcoded-port, which is
;; not exported but is used by (rnrs io ports).
+(load-extension (string-append "libguile-" (effective-version))
+ "scm_init_r6rs_ports")
+
(define (bytevector-concatenate-reverse bvs)
(let* ((len (let lp ((bvs bvs) (len 0))
(match bvs
@@ -73,7 +76,42 @@
(let ((dst (make-bytevector count)))
(bytevector-copy! src start dst 0 count)
dst))
-
+
+(define* (open-bytevector-input-port src #:optional transcoder)
+ "Return an input port whose contents are drawn from bytevector @var{src}."
+ (unless (bytevector? src)
+ (error "not a bytevector" src))
+ (when transcoder
+ (error "transcoders not implemented"))
+ (define pos 0)
+ (define (bv-read port dst start count)
+ (let ((to-copy (min count (- (bytevector-length src) pos))))
+ (bytevector-copy! src pos dst start to-copy)
+ (set! pos (+ pos to-copy))
+ to-copy))
+
+ (define (bv-seek port offset whence)
+ (define len (bytevector-length src))
+ (define base
+ (cond
+ ((eq? whence SEEK_SET) 0)
+ ((eq? whence SEEK_CUR) pos)
+ ((eq? whence SEEK_END) len)
+ (else (error "bad whence value" whence))))
+ (define dst (+ base offset))
+ (unless (<= 0 dst len)
+ (error "out of range" dst))
+ (set! pos dst)
+ dst)
+
+ (make-custom-port #:id "bytevector-input-port"
+ #:read bv-read
+ #:seek bv-seek
+ #:random-access? (lambda (_) #t)
+ ;; FIXME: Instead default to current encoding, if
+ ;; someone reads text from this port.
+ #:encoding 'ISO-8859-1 #:conversion-strategy 'error))
+
(define* (open-bytevector-output-port #:optional transcoder)
"Return two values: an output port and a procedure. The latter should be
called with zero arguments to obtain a bytevector containing the data
@@ -143,9 +181,6 @@ accumulated by the port."
(force-output port))
(get-output-bytevector))))
-(load-extension (string-append "libguile-" (effective-version))
- "scm_init_r6rs_ports")
-
(define (call-with-input-bytevector bv proc)
"Call the one-argument procedure @var{proc} with a newly created
binary input port from which the bytevector @var{bv}'s contents may be
