From a72057457e5a086c803483cbcc9af37890bbd670 Mon Sep 17 00:00:00 2001 From: Ludovic Court`es Date: Thu, 22 Feb 2007 17:59:01 +0000 Subject: [PATCH] ports: Added `open-bytevector-output-port'. * modules/r6rs/i/o/ports.scm: Export `open-bytevector-output-port'. * src/ports.c: Include . (transcoders_not_implemented): New. (scm_r6rs_open_bytevector_input_port): Use it. (bytevector_output_port_type): New. (SCM_GC_BOP, SCM_BOP_BUFFER_INITIAL_SIZE, SCM_R6RS_BOP_BUFFER, SCM_R6RS_SET_BOP_BUFFER): New macros. (scm_t_bop_buffer): New type. (bop_buffer_init, bop_buffer_grow): New functions. (make_bop, bop_free, bop_write, bop_seek): New. (bop_proc_apply, bop_proc_mark): New. (scm_r6rs_open_bytevector_output_port): New. (initialize_bytevector_output_ports): New. (scm_init_r6rs_ports): Call it. * src/ports.h: Updated. * tests/io-ports.test: Use `srfi-11'. (7.2.11 Binary Output)[open-bytevector-output-port]: New test. [bytevector output port supports `port-position']: New test. git-archimport-id: lcourtes@laas.fr--2006-libre/guile-r6rs-libs--devo--0--patch-27 --- ChangeLog | 34 ++++++ modules/r6rs/i/o/ports.scm | 3 +- src/ports.c | 251 ++++++++++++++++++++++++++++++++++++++++++++- src/ports.h | 1 + tests/io-ports.test | 34 +++++- 5 files changed, 318 insertions(+), 5 deletions(-) diff --git a/ChangeLog b/ChangeLog index b03a2ba..194da78 100644 --- a/ChangeLog +++ b/ChangeLog @@ -2,6 +2,40 @@ # arch-tag: automatic-ChangeLog--lcourtes@laas.fr--2006-libre/guile-r6rs-libs--devo--0 # +2007-02-22 17:59:01 GMT Ludovic Court`es patch-27 + + Summary: + ports: Added `open-bytevector-output-port'. + Revision: + guile-r6rs-libs--devo--0--patch-27 + + * modules/r6rs/i/o/ports.scm: Export `open-bytevector-output-port'. + + * src/ports.c: Include . + (transcoders_not_implemented): New. + (scm_r6rs_open_bytevector_input_port): Use it. + (bytevector_output_port_type): New. + (SCM_GC_BOP, SCM_BOP_BUFFER_INITIAL_SIZE, SCM_R6RS_BOP_BUFFER, + SCM_R6RS_SET_BOP_BUFFER): New macros. + (scm_t_bop_buffer): New type. + (bop_buffer_init, bop_buffer_grow): New functions. + (make_bop, bop_free, bop_write, bop_seek): New. + (bop_proc_apply, bop_proc_mark): New. + (scm_r6rs_open_bytevector_output_port): New. + (initialize_bytevector_output_ports): New. + (scm_init_r6rs_ports): Call it. + + * src/ports.h: Updated. + + * tests/io-ports.test: Use `srfi-11'. + (7.2.11 Binary Output)[open-bytevector-output-port]: New test. + [bytevector output port supports `port-position']: New test. + + modified files: + ChangeLog modules/r6rs/i/o/ports.scm src/ports.c src/ports.h + tests/io-ports.test + + 2007-02-22 15:07:35 GMT Ludovic Court`es patch-26 Summary: diff --git a/modules/r6rs/i/o/ports.scm b/modules/r6rs/i/o/ports.scm index 82278fa..3fa9bd8 100644 --- a/modules/r6rs/i/o/ports.scm +++ b/modules/r6rs/i/o/ports.scm @@ -35,7 +35,8 @@ get-bytevector-some get-bytevector-all ;; binary output - put-u8 put-bytevector)) + put-u8 put-bytevector + open-bytevector-output-port)) (load-extension "libguile-r6rs-libs-v-0" "scm_init_r6rs_ports") diff --git a/src/ports.c b/src/ports.c index 88df581..bd30fbf 100644 --- a/src/ports.c +++ b/src/ports.c @@ -18,12 +18,26 @@ #include "config.h" #include +#include #include #include "ports.h" #include "bytevector.h" #include "utils.h" + +/* 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. */ @@ -157,9 +171,7 @@ SCM_DEFINE (scm_r6rs_open_bytevector_input_port, { SCM_VALIDATE_R6RS_BYTEVECTOR (1, bv); if (transcoder != SCM_UNDEFINED) - /* FIXME: Implement transcoders along with `port-position' et al. */ - fprintf (stderr, "%s: warning: transcoders not implemented\n", - PACKAGE_NAME); + transcoders_not_implemented (); return (make_bip (bv)); } @@ -706,6 +718,238 @@ SCM_DEFINE (scm_r6rs_put_bytevector, "put-bytevector", 2, 2, 0, } #undef FUNC_NAME + + +/* Bytevector output port ("bop" for short). */ + +/* Implementation of "bops". + + Each bop has an internal buffer, of type `scm_t_bop_buffer', attached to + it. The procedure returned along with the output port is actually an + applicable SMOB. The SMOB holds a reference to the port. When applied, + the SMOB swallows the port's internal buffer, turning it into a + bytevector, and resets it. + + XXX: Access to a bop's internal buffer is not thread-safe. */ + +static scm_t_bits bytevector_output_port_type = 0; + +SCM_SMOB (bytevector_output_port_procedure, + "r6rs-bytevector-output-port-procedure", + 0); + +#define SCM_GC_BOP "r6rs-bytevector-output-port" +#define SCM_BOP_BUFFER_INITIAL_SIZE 4096 + +/* Representation of a bop's internal buffer. */ +typedef struct +{ + size_t total_len; + size_t len; + size_t pos; + char *buffer; +} scm_t_bop_buffer; + + +/* Accessing a bop's buffer. */ +#define SCM_R6RS_BOP_BUFFER(_port) \ + ((scm_t_bop_buffer *) SCM_STREAM (_port)) +#define SCM_R6RS_SET_BOP_BUFFER(_port, _buf) \ + (SCM_SETSTREAM ((_port), (scm_t_bits) (_buf))) + + +static inline void +bop_buffer_init (scm_t_bop_buffer *buf) +{ + buf->total_len = buf->len = buf->pos = 0; + buf->buffer = NULL; +} + +static inline void +bop_buffer_grow (scm_t_bop_buffer *buf) +{ + char *new_buf; + + new_buf = scm_gc_realloc ((void *) buf->buffer, buf->total_len, + buf->total_len * 2, + SCM_GC_BOP); + buf->buffer = new_buf; + buf->total_len *= 2; +} + +static inline SCM +make_bop (void) +{ + SCM port, bop_proc; + scm_t_port *c_port; + scm_t_bop_buffer *buf; + const unsigned long mode_bits = SCM_OPN | SCM_WRTNG | SCM_BUF0; + + port = scm_new_port_table_entry (bytevector_output_port_type); + + buf = (scm_t_bop_buffer *) scm_gc_malloc (sizeof (* buf), SCM_GC_BOP); + bop_buffer_init (buf); + + c_port = SCM_PTAB_ENTRY (port); + c_port->write_buf = c_port->write_pos = c_port->write_end = NULL; + + SCM_R6RS_SET_BOP_BUFFER (port, buf); + + /* Mark PORT as open and writable. */ + SCM_SET_CELL_TYPE (port, bytevector_output_port_type | mode_bits); + + /* Make the bop procedure. */ + SCM_NEWSMOB (bop_proc, bytevector_output_port_procedure, + SCM_PACK (port)); + + return (scm_values (scm_list_2 (port, bop_proc))); +} + +static size_t +bop_free (SCM port) +{ + /* The port itself is necessarily freed _after_ the bop proc, since the bop + proc holds a reference to it. Thus we can safely free the internal + buffer when the bop becomes unreferenced. */ + scm_t_bop_buffer *buf; + + buf = SCM_R6RS_BOP_BUFFER (port); + if (buf->buffer) + scm_gc_free (buf->buffer, buf->total_len, SCM_GC_BOP); + + scm_gc_free (buf, sizeof (* buf), SCM_GC_BOP); + + return 0; +} + +/* Write SIZE octets from DATA to PORT. */ +static void +bop_write (SCM port, const void *data, size_t size) +{ + scm_t_bop_buffer *buf; + + buf = SCM_R6RS_BOP_BUFFER (port); + + while (buf->pos + size > buf->total_len) + { + /* The buffer must be grown. */ + if (buf->total_len == 0) + { + buf->buffer = scm_gc_malloc (SCM_BOP_BUFFER_INITIAL_SIZE, + SCM_GC_BOP); + buf->total_len = SCM_BOP_BUFFER_INITIAL_SIZE; + } + else + bop_buffer_grow (buf); + } + + memcpy (buf->buffer + buf->pos, data, size); + buf->pos += size; + buf->len = (buf->len > buf->pos) ? buf->len : buf->pos; +} + +static off_t +bop_seek (SCM port, off_t offset, int whence) +#define FUNC_NAME "bop_seek" +{ + scm_t_bop_buffer *buf; + + buf = SCM_R6RS_BOP_BUFFER (port); + switch (whence) + { + case SEEK_CUR: + offset += (off_t) buf->pos; + /* Fall through. */ + + case SEEK_SET: + if (offset > buf->len) + scm_out_of_range (FUNC_NAME, scm_from_int (offset)); + else + buf->pos = offset; + break; + + case SEEK_END: + if (offset >= buf->len) + scm_out_of_range (FUNC_NAME, scm_from_int (offset)); + else + buf->pos = buf->len - offset; + break; + + default: + scm_wrong_type_arg_msg (FUNC_NAME, 0, port, + "invalid `seek' parameter"); + } + + return buf->pos; +} +#undef FUNC_NAME + +/* Fetch data from a bop. */ +SCM_SMOB_APPLY (bytevector_output_port_procedure, + bop_proc_apply, 0, 0, 0, (SCM bop_proc)) +{ + SCM port, bv; + scm_t_bop_buffer *buf, result_buf; + + port = SCM_PACK (SCM_SMOB_DATA (bop_proc)); + buf = SCM_R6RS_BOP_BUFFER (port); + + result_buf = *buf; + bop_buffer_init (buf); + + if (result_buf.len == 0) + bv = scm_r6rs_c_take_bytevector (NULL, 0); + else + { + if (result_buf.total_len > result_buf.len) + /* Shrink the buffer. */ + result_buf.buffer = scm_gc_realloc ((void *) result_buf.buffer, + result_buf.total_len, + result_buf.len, + SCM_GC_BOP); + + bv = scm_r6rs_c_take_bytevector ((signed char *) result_buf.buffer, + result_buf.len); + } + + return bv; +} + +SCM_SMOB_MARK (bytevector_output_port_procedure, bop_proc_mark, + bop_proc) +{ + /* Mark the port associated to BOP_PROC. */ + return (SCM_PACK (SCM_SMOB_DATA (bop_proc))); +} + + +SCM_DEFINE (scm_r6rs_open_bytevector_output_port, + "open-bytevector-output-port", 0, 1, 0, + (SCM 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 accumulated by the port.") +#define FUNC_NAME scm_r6rs_open_bytevector_output_port +{ + if (transcoder != SCM_UNDEFINED) + transcoders_not_implemented (); + + return (make_bop ()); +} +#undef FUNC_NAME + +static inline void +initialize_bytevector_output_ports (void) +{ + bytevector_output_port_type = + scm_make_port_type ("r6rs-bytevector-output-port", + NULL, bop_write); + + scm_set_port_seek (bytevector_output_port_type, bop_seek); + scm_set_port_free (bytevector_output_port_type, bop_free); +} + + /* Initialization. */ @@ -716,6 +960,7 @@ scm_init_r6rs_ports (void) initialize_bytevector_input_ports (); initialize_custom_binary_input_ports (); + initialize_bytevector_output_ports (); } /* arch-tag: c041ffd6-8871-40e8-a25a-d0f8768a71dc diff --git a/src/ports.h b/src/ports.h index f27bcba..6ffa908 100644 --- a/src/ports.h +++ b/src/ports.h @@ -35,6 +35,7 @@ SCM_API SCM scm_r6rs_get_bytevector_some (SCM); SCM_API SCM scm_r6rs_get_bytevector_all (SCM); SCM_API SCM scm_r6rs_put_u8 (SCM, SCM); SCM_API SCM scm_r6rs_put_bytevector (SCM, SCM, SCM, SCM); +SCM_API SCM scm_r6rs_open_bytevector_output_port (SCM); #endif diff --git a/tests/io-ports.test b/tests/io-ports.test index cb6963c..2af24ff 100644 --- a/tests/io-ports.test +++ b/tests/io-ports.test @@ -20,6 +20,7 @@ (define-module (test-i/o-ports) :use-module (test-suite lib) :use-module (srfi srfi-1) + :use-module (srfi srfi-11) :use-module (r6rs i/o ports) :use-module (r6rs bytevector)) @@ -198,7 +199,38 @@ (put-bytevector port bv start count) (equal? (take (drop (bytevector->u8-list bv) start) count) (bytevector->u8-list - (get-bytevector-n port count)))))) + (get-bytevector-n port count))))) + + (pass-if "open-bytevector-output-port" + (let-values (((port get-content) + (open-bytevector-output-port))) + (let ((source (make-bytevector 7777))) + (put-bytevector port source) + (and (bytevector=? (get-content) source) + (bytevector=? (get-content) (make-bytevector 0)))))) + + (pass-if "bytevector output port supports `port-position'" + (let-values (((port get-content) + (open-bytevector-output-port))) + (let ((source (make-bytevector 7777)) + (overwrite (make-bytevector 33))) + (and (port-has-port-position? port) + (port-has-set-port-position!? port) + (begin + (put-bytevector port source) + (= (bytevector-length source) + (port-position port))) + (begin + (set-port-position! port 10) + (= 10 (port-position port))) + (begin + (put-bytevector port overwrite) + (bytevector-copy! overwrite 0 source 10 + (bytevector-length overwrite)) + (= (port-position port) + (+ 10 (bytevector-length overwrite)))) + (bytevector=? (get-content) source) + (bytevector=? (get-content) (make-bytevector 0))))))) (with-test-prefix "7.2.7 Input Ports" -- 2.11.4.GIT