X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/62e9a9b704524edfad98dd84ac5a11abd48d0b27..b05257b9232e2ee631c28b15cace5981c4927446:/libguile/r6rs-ports.c diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index d2c02ff40..d5fcd2076 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -1,18 +1,19 @@ -/* Copyright (C) 2009 Free Software Foundation, Inc. +/* Copyright (C) 2009, 2010, 2011, 2013 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 2.1 of the License, or (at your option) any later version. + * 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 + * 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 library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifdef HAVE_CONFIG_H @@ -83,7 +84,13 @@ make_bip (SCM bv) scm_t_port *c_port; const unsigned long mode_bits = SCM_OPN | SCM_RDNG; + scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex); + port = scm_new_port_table_entry (bytevector_input_port_type); + c_port = SCM_PTAB_ENTRY (port); + + /* Match the expectation of `binary-port?'. */ + c_port->encoding = NULL; /* Prevent BV from being GC'd. */ SCM_SETSTREAM (port, SCM_UNPACK (bv)); @@ -92,7 +99,6 @@ make_bip (SCM bv) c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); c_len = SCM_BYTEVECTOR_LENGTH (bv); - c_port = SCM_PTAB_ENTRY (port); c_port->read_pos = c_port->read_buf = (unsigned char *) c_bv; c_port->read_end = (unsigned char *) c_bv + c_len; c_port->read_buf_size = c_len; @@ -100,14 +106,9 @@ make_bip (SCM bv) /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */ SCM_SET_CELL_TYPE (port, bytevector_input_port_type | mode_bits); - return port; -} + scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex); -static SCM -bip_mark (SCM port) -{ - /* Mark the underlying bytevector. */ - return (SCM_PACK (SCM_STREAM (port))); + return port; } static int @@ -124,11 +125,11 @@ bip_fill_input (SCM port) return result; } -static off_t -bip_seek (SCM port, off_t offset, int whence) +static scm_t_off +bip_seek (SCM port, scm_t_off offset, int whence) #define FUNC_NAME "bip_seek" { - off_t c_result = 0; + scm_t_off c_result = 0; scm_t_port *c_port = SCM_PTAB_ENTRY (port); switch (whence) @@ -138,7 +139,7 @@ bip_seek (SCM port, off_t offset, int whence) /* Fall through. */ case SEEK_SET: - if (c_port->read_buf + offset < c_port->read_end) + if (c_port->read_buf + offset <= c_port->read_end) { c_port->read_pos = c_port->read_buf + offset; c_result = offset; @@ -175,7 +176,6 @@ initialize_bytevector_input_ports (void) scm_make_port_type ("r6rs-bytevector-input-port", bip_fill_input, NULL); - scm_set_port_mark (bytevector_input_port_type, bip_mark); scm_set_port_seek (bytevector_input_port_type, bip_seek); } @@ -206,19 +206,12 @@ SCM_DEFINE (scm_open_bytevector_input_port, #define SCM_CBP_CLOSE_PROC(_port) \ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 3) -static SCM -cbp_mark (SCM port) -{ - /* Mark the underlying method and object vector. */ - return (SCM_PACK (SCM_STREAM (port))); -} - -static off_t -cbp_seek (SCM port, off_t offset, int whence) +static scm_t_off +cbp_seek (SCM port, scm_t_off offset, int whence) #define FUNC_NAME "cbp_seek" { SCM result; - off_t c_result = 0; + scm_t_off c_result = 0; switch (whence) { @@ -319,13 +312,18 @@ make_cbip (SCM read_proc, SCM get_position_proc, SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc); SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc); + scm_i_pthread_mutex_lock (&scm_i_port_table_mutex); + port = scm_new_port_table_entry (custom_binary_input_port_type); + c_port = SCM_PTAB_ENTRY (port); + + /* Match the expectation of `binary-port?'. */ + c_port->encoding = NULL; /* Attach it the method vector. */ SCM_SETSTREAM (port, SCM_UNPACK (method_vector)); /* Have the port directly access the buffer (bytevector). */ - c_port = SCM_PTAB_ENTRY (port); c_port->read_pos = c_port->read_buf = (unsigned char *) c_bv; c_port->read_end = (unsigned char *) c_bv; c_port->read_buf_size = c_len; @@ -333,6 +331,8 @@ make_cbip (SCM read_proc, SCM get_position_proc, /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */ SCM_SET_CELL_TYPE (port, custom_binary_input_port_type | mode_bits); + scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex); + return port; } @@ -417,7 +417,6 @@ initialize_custom_binary_input_ports (void) scm_make_port_type ("r6rs-custom-binary-input-port", cbip_fill_input, NULL); - scm_set_port_mark (custom_binary_input_port_type, cbp_mark); scm_set_port_seek (custom_binary_input_port_type, cbp_seek); scm_set_port_close (custom_binary_input_port_type, cbp_close); } @@ -440,7 +439,7 @@ SCM_DEFINE (scm_get_u8, "get-u8", 1, 0, 0, SCM_VALIDATE_BINARY_INPUT_PORT (1, port); - c_result = scm_getc (port); + c_result = scm_get_byte_or_eof (port); if (c_result == EOF) result = SCM_EOF_VAL; else @@ -456,15 +455,16 @@ SCM_DEFINE (scm_lookahead_u8, "lookahead-u8", 1, 0, 0, "point past the octet.") #define FUNC_NAME s_scm_lookahead_u8 { + int u8; SCM result; SCM_VALIDATE_BINARY_INPUT_PORT (1, port); - result = scm_peek_char (port); - if (SCM_CHARP (result)) - result = SCM_I_MAKINUM ((signed char) SCM_CHAR (result)); - else + u8 = scm_peek_byte_or_eof (port); + if (u8 == EOF) result = SCM_EOF_VAL; + else + result = SCM_I_MAKINUM ((scm_t_uint8) u8); return result; } @@ -498,7 +498,7 @@ SCM_DEFINE (scm_get_bytevector_n, "get-bytevector-n", 2, 0, 0, if ((c_read == 0) && (c_count > 0)) { - if (SCM_EOF_OBJECT_P (scm_peek_char (port))) + if (scm_peek_byte_or_eof (port) == EOF) result = SCM_EOF_VAL; else result = scm_null_bytevector; @@ -545,7 +545,7 @@ SCM_DEFINE (scm_get_bytevector_n_x, "get-bytevector-n!", 4, 0, 0, if ((c_read == 0) && (c_count > 0)) { - if (SCM_EOF_OBJECT_P (scm_peek_char (port))) + if (scm_peek_byte_or_eof (port) == EOF) result = SCM_EOF_VAL; else result = SCM_I_MAKINUM (0); @@ -577,7 +577,7 @@ SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0, SCM_VALIDATE_BINARY_INPUT_PORT (1, port); c_len = 4096; - c_bv = (char *) scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR); + c_bv = (char *) scm_gc_malloc_pointerless (c_len, SCM_GC_BYTEVECTOR); c_total = 0; do @@ -593,15 +593,17 @@ SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0, } /* We can't use `scm_c_read ()' since it blocks. */ - c_chr = scm_getc (port); + c_chr = scm_get_byte_or_eof (port); if (c_chr != EOF) { c_bv[c_total] = (char) c_chr; c_total++; } } - while ((scm_is_true (scm_char_ready_p (port))) - && (!SCM_EOF_OBJECT_P (scm_peek_char (port)))); + /* XXX: We want to check for the availability of a byte, but that's + what `scm_char_ready_p' actually does. */ + while (scm_is_true (scm_char_ready_p (port)) + && (scm_peek_byte_or_eof (port) != EOF)); if (c_total == 0) { @@ -618,7 +620,7 @@ SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0, c_len = (unsigned) c_total; } - result = scm_c_take_bytevector ((signed char *) c_bv, c_len); + result = scm_c_take_gc_bytevector ((signed char *) c_bv, c_len); } return result; @@ -641,7 +643,7 @@ SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 0, SCM_VALIDATE_BINARY_INPUT_PORT (1, port); c_len = c_count = 4096; - c_bv = (char *) scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR); + c_bv = (char *) scm_gc_malloc_pointerless (c_len, SCM_GC_BYTEVECTOR); c_total = c_read = 0; do @@ -660,7 +662,7 @@ SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 0, c_read = scm_c_read (port, c_bv + c_total, c_count); c_total += c_read, c_count -= c_read; } - while (!SCM_EOF_OBJECT_P (scm_peek_char (port))); + while (scm_peek_byte_or_eof (port) != EOF); if (c_total == 0) { @@ -677,7 +679,7 @@ SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 0, c_len = (unsigned) c_total; } - result = scm_c_take_bytevector ((signed char *) c_bv, c_len); + result = scm_c_take_gc_bytevector ((signed char *) c_bv, c_len); } return result; @@ -724,11 +726,11 @@ SCM_DEFINE (scm_put_bytevector, "put-bytevector", 2, 2, 0, c_len = SCM_BYTEVECTOR_LENGTH (bv); c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); - if (start != SCM_UNDEFINED) + if (!scm_is_eq (start, SCM_UNDEFINED)) { c_start = scm_to_uint (start); - if (count != SCM_UNDEFINED) + if (!scm_is_eq (count, SCM_UNDEFINED)) { c_count = scm_to_uint (count); if (SCM_UNLIKELY (c_start + c_count > c_len)) @@ -813,7 +815,7 @@ bop_buffer_grow (scm_t_bop_buffer *buf, size_t min_size) new_buf = scm_gc_realloc ((void *) buf->buffer, buf->total_len, new_size, SCM_GC_BOP); else - new_buf = scm_gc_malloc (new_size, SCM_GC_BOP); + new_buf = scm_gc_malloc_pointerless (new_size, SCM_GC_BOP); buf->buffer = new_buf; buf->total_len = new_size; @@ -827,12 +829,17 @@ make_bop (void) scm_t_bop_buffer *buf; const unsigned long mode_bits = SCM_OPN | SCM_WRTNG; + scm_i_pthread_mutex_lock (&scm_i_port_table_mutex); + port = scm_new_port_table_entry (bytevector_output_port_type); + c_port = SCM_PTAB_ENTRY (port); + + /* Match the expectation of `binary-port?'. */ + c_port->encoding = NULL; 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; c_port->write_buf_size = 0; @@ -841,30 +848,14 @@ make_bop (void) /* Mark PORT as open and writable. */ SCM_SET_CELL_TYPE (port, bytevector_output_port_type | mode_bits); + scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex); + /* Make the bop procedure. */ - SCM_NEWSMOB (bop_proc, bytevector_output_port_procedure, - SCM_PACK (port)); + SCM_NEWSMOB (bop_proc, bytevector_output_port_procedure, buf); 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_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) @@ -881,8 +872,8 @@ bop_write (SCM port, const void *data, size_t size) buf->len = (buf->len > buf->pos) ? buf->len : buf->pos; } -static off_t -bop_seek (SCM port, off_t offset, int whence) +static scm_t_off +bop_seek (SCM port, scm_t_off offset, int whence) #define FUNC_NAME "bop_seek" { scm_t_bop_buffer *buf; @@ -891,7 +882,7 @@ bop_seek (SCM port, off_t offset, int whence) switch (whence) { case SEEK_CUR: - offset += (off_t) buf->pos; + offset += (scm_t_off) buf->pos; /* Fall through. */ case SEEK_SET: @@ -921,17 +912,16 @@ bop_seek (SCM port, off_t offset, int whence) SCM_SMOB_APPLY (bytevector_output_port_procedure, bop_proc_apply, 0, 0, 0, (SCM bop_proc)) { - SCM port, bv; + SCM bv; scm_t_bop_buffer *buf, result_buf; - port = SCM_PACK (SCM_SMOB_DATA (bop_proc)); - buf = SCM_BOP_BUFFER (port); + buf = (scm_t_bop_buffer *) SCM_SMOB_DATA (bop_proc); result_buf = *buf; bop_buffer_init (buf); if (result_buf.len == 0) - bv = scm_c_take_bytevector (NULL, 0); + bv = scm_c_take_gc_bytevector (NULL, 0); else { if (result_buf.total_len > result_buf.len) @@ -941,21 +931,13 @@ SCM_SMOB_APPLY (bytevector_output_port_procedure, result_buf.len, SCM_GC_BOP); - bv = scm_c_take_bytevector ((signed char *) result_buf.buffer, - result_buf.len); + bv = scm_c_take_gc_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 with BOP_PROC. */ - return (SCM_PACK (SCM_SMOB_DATA (bop_proc))); -} - - SCM_DEFINE (scm_open_bytevector_output_port, "open-bytevector-output-port", 0, 1, 0, (SCM transcoder), @@ -979,7 +961,6 @@ initialize_bytevector_output_ports (void) NULL, bop_write); scm_set_port_seek (bytevector_output_port_type, bop_seek); - scm_set_port_free (bytevector_output_port_type, bop_free); } @@ -1007,19 +988,26 @@ make_cbop (SCM write_proc, SCM get_position_proc, SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc); SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc); + scm_i_pthread_mutex_lock (&scm_i_port_table_mutex); + port = scm_new_port_table_entry (custom_binary_output_port_type); + c_port = SCM_PTAB_ENTRY (port); + + /* Match the expectation of `binary-port?'. */ + c_port->encoding = NULL; /* Attach it the method vector. */ SCM_SETSTREAM (port, SCM_UNPACK (method_vector)); /* Have the port directly access the buffer (bytevector). */ - c_port = SCM_PTAB_ENTRY (port); c_port->write_buf = c_port->write_pos = c_port->write_end = NULL; c_port->write_buf_size = c_port->read_buf_size = 0; /* Mark PORT as open, writable and unbuffered. */ SCM_SET_CELL_TYPE (port, custom_binary_output_port_type | mode_bits); + scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex); + return port; } @@ -1098,14 +1086,213 @@ initialize_custom_binary_output_ports (void) scm_make_port_type ("r6rs-custom-binary-output-port", NULL, cbop_write); - scm_set_port_mark (custom_binary_output_port_type, cbp_mark); scm_set_port_seek (custom_binary_output_port_type, cbp_seek); scm_set_port_close (custom_binary_output_port_type, cbp_close); } +/* Transcoded ports ("tp" for short). */ +static scm_t_bits transcoded_port_type = 0; + +#define TP_INPUT_BUFFER_SIZE 4096 + +#define SCM_TP_BINARY_PORT(_port) SCM_PACK (SCM_STREAM (_port)) + +static inline SCM +make_tp (SCM binary_port, unsigned long mode) +{ + SCM port; + scm_t_port *c_port; + const unsigned long mode_bits = SCM_OPN | mode; + + scm_i_pthread_mutex_lock (&scm_i_port_table_mutex); + + port = scm_new_port_table_entry (transcoded_port_type); + + SCM_SETSTREAM (port, SCM_UNPACK (binary_port)); + + SCM_SET_CELL_TYPE (port, transcoded_port_type | mode_bits); + + if (SCM_INPUT_PORT_P (port)) + { + c_port = SCM_PTAB_ENTRY (port); + c_port->read_buf = scm_gc_malloc_pointerless (TP_INPUT_BUFFER_SIZE, + "port buffer"); + c_port->read_pos = c_port->read_end = c_port->read_buf; + c_port->read_buf_size = TP_INPUT_BUFFER_SIZE; + + SCM_SET_CELL_WORD_0 (port, SCM_CELL_WORD_0 (port) & ~SCM_BUF0); + } + + scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex); + + return port; +} + +static void +tp_write (SCM port, const void *data, size_t size) +{ + scm_c_write (SCM_TP_BINARY_PORT (port), data, size); +} + +static int +tp_fill_input (SCM port) +{ + size_t count; + scm_t_port *c_port = SCM_PTAB_ENTRY (port); + SCM bport = SCM_TP_BINARY_PORT (port); + scm_t_port *c_bport = SCM_PTAB_ENTRY (bport); + + /* We can't use `scm_c_read' here, since it blocks until the whole + block has been read or EOF. */ + + if (c_bport->rw_active == SCM_PORT_WRITE) + scm_force_output (bport); + + if (c_bport->read_pos >= c_bport->read_end) + scm_fill_input (bport); + + count = c_bport->read_end - c_bport->read_pos; + if (count > c_port->read_buf_size) + count = c_port->read_buf_size; + + memcpy (c_port->read_buf, c_bport->read_pos, count); + c_bport->read_pos += count; + + if (c_bport->rw_random) + c_bport->rw_active = SCM_PORT_READ; + + if (count == 0) + return EOF; + else + { + c_port->read_pos = c_port->read_buf; + c_port->read_end = c_port->read_buf + count; + return *c_port->read_buf; + } +} + +static void +tp_flush (SCM port) +{ + SCM binary_port = SCM_TP_BINARY_PORT (port); + scm_t_port *c_port = SCM_PTAB_ENTRY (port); + size_t count = c_port->write_pos - c_port->write_buf; + + /* As the runtime will try to flush all ports upon exit, we test for + the underlying port still being open here. Otherwise, when you + would explicitly close the underlying port and the transcoded port + still had data outstanding, you'd get an exception on Guile exit. + + We just throw away the data when the underlying port is closed. */ + + if (SCM_OPOUTPORTP (binary_port)) + scm_c_write (binary_port, c_port->write_buf, count); + + c_port->write_pos = c_port->write_buf; + c_port->rw_active = SCM_PORT_NEITHER; + + if (SCM_OPOUTPORTP (binary_port)) + scm_force_output (binary_port); +} + +static int +tp_close (SCM port) +{ + if (SCM_OUTPUT_PORT_P (port)) + tp_flush (port); + return scm_is_true (scm_close_port (SCM_TP_BINARY_PORT (port))) ? 0 : -1; +} + +static inline void +initialize_transcoded_ports (void) +{ + transcoded_port_type = + scm_make_port_type ("r6rs-transcoded-port", tp_fill_input, tp_write); + + scm_set_port_flush (transcoded_port_type, tp_flush); + scm_set_port_close (transcoded_port_type, tp_close); +} + +SCM_DEFINE (scm_i_make_transcoded_port, + "%make-transcoded-port", 1, 0, 0, + (SCM port), + "Return a new port which reads and writes to @var{port}") +#define FUNC_NAME s_scm_i_make_transcoded_port +{ + SCM result; + unsigned long mode = 0; + + SCM_VALIDATE_PORT (SCM_ARG1, port); + + if (scm_is_true (scm_output_port_p (port))) + mode |= SCM_WRTNG; + else if (scm_is_true (scm_input_port_p (port))) + mode |= SCM_RDNG; + + result = make_tp (port, mode); + + /* FIXME: We should actually close `port' "in a special way" here, + according to R6RS. As there is no way to do that in Guile without + rendering the underlying port unusable for our purposes as well, we + just leave it open. */ + + return result; +} +#undef FUNC_NAME + + +/* Textual I/O */ + +SCM_DEFINE (scm_get_string_n_x, + "get-string-n!", 4, 0, 0, + (SCM port, SCM str, SCM start, SCM count), + "Read up to @var{count} characters from @var{port} into " + "@var{str}, starting at @var{start}. If no characters " + "can be read before the end of file is encountered, the end " + "of file object is returned. Otherwise, the number of " + "characters read is returned.") +#define FUNC_NAME s_scm_get_string_n_x +{ + size_t c_start, c_count, c_len, c_end, j; + scm_t_wchar c; + + SCM_VALIDATE_OPINPORT (1, port); + SCM_VALIDATE_STRING (2, str); + c_len = scm_c_string_length (str); + c_start = scm_to_size_t (start); + c_count = scm_to_size_t (count); + c_end = c_start + c_count; + + if (SCM_UNLIKELY (c_end > c_len)) + scm_out_of_range (FUNC_NAME, count); + + for (j = c_start; j < c_end; j++) + { + c = scm_getc (port); + if (c == EOF) + { + size_t chars_read = j - c_start; + return chars_read == 0 ? SCM_EOF_VAL : scm_from_size_t (chars_read); + } + scm_c_string_set_x (str, j, SCM_MAKE_CHAR (c)); + } + return count; +} +#undef FUNC_NAME + + /* Initialization. */ +void +scm_register_r6rs_ports (void) +{ + scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, + "scm_init_r6rs_ports", + (scm_t_extension_init_func) scm_init_r6rs_ports, + NULL); +} + void scm_init_r6rs_ports (void) { @@ -1115,4 +1302,5 @@ scm_init_r6rs_ports (void) initialize_custom_binary_input_ports (); initialize_bytevector_output_ports (); initialize_custom_binary_output_ports (); + initialize_transcoded_ports (); }