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