mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-07-01 15:20:34 +02:00
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.
This commit is contained in:
Andy Wingo
parent
2fc5ff5264
commit
2a015937ca
2 changed files with 55 additions and 134 deletions
|
|
@ -55,22 +55,6 @@ SCM_SYMBOL (sym_ISO_8859_1, "ISO-8859-1");
|
|||
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. */
|
||||
|
|
@ -85,118 +69,6 @@ SCM_DEFINE (scm_eof_object, "eof-object", 0, 0, 0,
|
|||
#undef FUNC_NAME
|
||||
|
||||
|
||||
|
||||
|
||||
/* 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. */
|
||||
|
|
@ -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 ();
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue