From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Andreas Rottmann Newsgroups: gmane.lisp.guile.devel Subject: [PATCH 1/3] Split r6rs-ports.c according to module boundaries Date: Sun, 9 Dec 2012 13:47:25 +0100 Message-ID: <1355057247-17885-2-git-send-email-a.rottmann@gmx.at> References: <1355057247-17885-1-git-send-email-a.rottmann@gmx.at> NNTP-Posting-Host: plane.gmane.org X-Trace: ger.gmane.org 1355057296 17378 80.91.229.3 (9 Dec 2012 12:48:16 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Sun, 9 Dec 2012 12:48:16 +0000 (UTC) To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Sun Dec 09 13:48:28 2012 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1ThgIz-0000ax-RY for guile-devel@m.gmane.org; Sun, 09 Dec 2012 13:48:26 +0100 Original-Received: from localhost ([::1]:49400 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ThgIn-000356-Iq for guile-devel@m.gmane.org; Sun, 09 Dec 2012 07:48:13 -0500 Original-Received: from eggs.gnu.org ([208.118.235.92]:42083) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ThgIb-0002tK-Qk for guile-devel@gnu.org; Sun, 09 Dec 2012 07:48:09 -0500 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1ThgIV-0008CU-NL for guile-devel@gnu.org; Sun, 09 Dec 2012 07:48:01 -0500 Original-Received: from mailout-de.gmx.net ([213.165.64.22]:57454) by eggs.gnu.org with smtp (Exim 4.71) (envelope-from ) id 1ThgIV-0008CB-3N for guile-devel@gnu.org; Sun, 09 Dec 2012 07:47:55 -0500 Original-Received: (qmail invoked by alias); 09 Dec 2012 12:47:53 -0000 Original-Received: from 91-119-183-136.dynamic.xdsl-line.inode.at (EHLO cubox.home.rotty.xx.vu) [91.119.183.136] by mail.gmx.net (mp010) with SMTP; 09 Dec 2012 13:47:53 +0100 X-Authenticated: #3102804 X-Provags-ID: V01U2FsdGVkX19GiZQ9bIFGOdh1ZKllkTw9EDWH0ho6zl5p1FvZ6C n6wpvW8bOMnEqr Original-Received: from delenn.home.rotty.xx.vu (delenn.home.rotty.xx.vu [IPv6:fdfb:599d:f328:2::6e]) by cubox.home.rotty.xx.vu (Postfix) with ESMTP id 4B55B16009E; Sun, 9 Dec 2012 13:47:52 +0100 (CET) Original-Received: by delenn.home.rotty.xx.vu (Postfix, from userid 1000) id 4211E320160; Sun, 9 Dec 2012 13:47:52 +0100 (CET) X-Mailer: git-send-email 1.7.10.4 In-Reply-To: <1355057247-17885-1-git-send-email-a.rottmann@gmx.at> X-Y-GMX-Trusted: 0 X-detected-operating-system: by eggs.gnu.org: GNU/Linux 3.x [generic] X-Received-From: 213.165.64.22 X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:15322 Archived-At: Currently, r6rs-ports.c provides procedures exported from `(ice-9 binary-ports)'. However, in addition, it also provides `%make-transcoder', which is used by `(rnrs io ports)' via a "private import". This change splits r6rs-ports.c into two parts, one specific to `(ice-9 binary-ports)' and the other specific to `(rnrs io ports)'. This provides a place to put internal C-implemented helpers needed only in `(rnrs io ports)', thus allowing to eliminate the private import of `%make-transcoder'. * libguile/binary-port.c: New file, contains the most part of what has been in libguile/r6rs-ports.c for now. * libguile/binary-ports.h: Ditto for the header part. * libguile/r6rs-ports.c: Now contains just transcoded ports, as this API is not part of the `(ice-9 binary-ports)' module. * libguile/r6rs-ports.h: Now includes "libguile/binary-ports.h", and defines the extension registration and initialization functions. * libguile/Makefile.am: Add new files. --- libguile/Makefile.am | 2 + libguile/binary-ports.c | 1152 +++++++++++++++++++++++++++++++++++++++++ libguile/binary-ports.h | 46 ++ libguile/r6rs-ports.c | 1111 +-------------------------------------- libguile/r6rs-ports.h | 21 +- module/ice-9/binary-ports.scm | 7 +- module/rnrs/io/ports.scm | 9 +- 7 files changed, 1211 insertions(+), 1137 deletions(-) create mode 100644 libguile/binary-ports.c create mode 100644 libguile/binary-ports.h diff --git a/libguile/Makefile.am b/libguile/Makefile.am index e216435..3c0fc8e 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -125,6 +125,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \ async.c \ backtrace.c \ boolean.c \ + binary-ports.c \ bitvectors.c \ bytevectors.c \ chars.c \ @@ -230,6 +231,7 @@ DOT_X_FILES = \ async.x \ backtrace.x \ boolean.x \ + binary-ports.x \ bitvectors.x \ bytevectors.x \ chars.x \ diff --git a/libguile/binary-ports.c b/libguile/binary-ports.c new file mode 100644 index 0000000..b58578b --- /dev/null +++ b/libguile/binary-ports.c @@ -0,0 +1,1152 @@ +/* Copyright (C) 2009, 2010, 2011, 2012 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 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 + * 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 + */ + +#ifdef HAVE_CONFIG_H +# include +#endif + +#ifdef HAVE_UNISTD_H +# include +#endif + +#include +#include +#include + +#include "libguile/_scm.h" +#include "libguile/bytevectors.h" +#include "libguile/chars.h" +#include "libguile/eval.h" +#include "libguile/r6rs-ports.h" +#include "libguile/strings.h" +#include "libguile/validate.h" +#include "libguile/values.h" +#include "libguile/vectors.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. */ + +SCM_DEFINE (scm_eof_object, "eof-object", 0, 0, 0, + (void), + "Return the end-of-file object.") +#define FUNC_NAME s_scm_eof_object +{ + return (SCM_EOF_VAL); +} +#undef FUNC_NAME + + +/* Input ports. */ + +#ifndef MIN +# define MIN(a,b) ((a) < (b) ? (a) : (b)) +#endif + +/* Bytevector input ports or "bip" for short. */ +static scm_t_bits bytevector_input_port_type = 0; + +static inline SCM +make_bip (SCM bv) +{ + SCM port; + char *c_bv; + unsigned c_len; + 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)); + + /* Have the port directly access the bytevector. */ + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); + c_len = SCM_BYTEVECTOR_LENGTH (bv); + + 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; + + /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */ + SCM_SET_CELL_TYPE (port, bytevector_input_port_type | mode_bits); + + scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex); + + return port; +} + +static int +bip_fill_input (SCM port) +{ + int result; + scm_t_port *c_port = SCM_PTAB_ENTRY (port); + + if (c_port->read_pos >= c_port->read_end) + result = EOF; + else + result = (int) *c_port->read_pos; + + return result; +} + +static scm_t_off +bip_seek (SCM port, scm_t_off offset, int whence) +#define FUNC_NAME "bip_seek" +{ + scm_t_off c_result = 0; + scm_t_port *c_port = SCM_PTAB_ENTRY (port); + + switch (whence) + { + case SEEK_CUR: + offset += c_port->read_pos - c_port->read_buf; + /* Fall through. */ + + case SEEK_SET: + if (c_port->read_buf + offset <= c_port->read_end) + { + c_port->read_pos = c_port->read_buf + offset; + c_result = offset; + } + else + scm_out_of_range (FUNC_NAME, scm_from_int (offset)); + break; + + case SEEK_END: + if (c_port->read_end - offset >= c_port->read_buf) + { + c_port->read_pos = c_port->read_end - offset; + c_result = c_port->read_pos - c_port->read_buf; + } + else + scm_out_of_range (FUNC_NAME, scm_from_int (offset)); + break; + + default: + scm_wrong_type_arg_msg (FUNC_NAME, 0, port, + "invalid `seek' parameter"); + } + + return c_result; +} +#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", bip_fill_input, + NULL); + + scm_set_port_seek (bytevector_input_port_type, bip_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_bip (bv)); +} +#undef FUNC_NAME + + +/* Custom binary ports. The following routines are shared by input and + output custom binary ports. */ + +#define SCM_CBP_GET_POSITION_PROC(_port) \ + SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 1) +#define SCM_CBP_SET_POSITION_PROC(_port) \ + SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 2) +#define SCM_CBP_CLOSE_PROC(_port) \ + SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 3) + +static scm_t_off +cbp_seek (SCM port, scm_t_off offset, int whence) +#define FUNC_NAME "cbp_seek" +{ + SCM result; + scm_t_off c_result = 0; + + switch (whence) + { + case SEEK_CUR: + { + SCM get_position_proc; + + get_position_proc = SCM_CBP_GET_POSITION_PROC (port); + if (SCM_LIKELY (scm_is_true (get_position_proc))) + result = scm_call_0 (get_position_proc); + else + scm_wrong_type_arg_msg (FUNC_NAME, 0, port, + "R6RS custom binary port does not " + "support `port-position'"); + + offset += scm_to_int (result); + /* Fall through. */ + } + + case SEEK_SET: + { + SCM set_position_proc; + + set_position_proc = SCM_CBP_SET_POSITION_PROC (port); + if (SCM_LIKELY (scm_is_true (set_position_proc))) + result = scm_call_1 (set_position_proc, scm_from_int (offset)); + else + scm_wrong_type_arg_msg (FUNC_NAME, 0, port, + "R6RS custom binary port does not " + "support `set-port-position!'"); + + /* Assuming setting the position succeeded. */ + c_result = offset; + break; + } + + default: + /* `SEEK_END' cannot be supported. */ + scm_wrong_type_arg_msg (FUNC_NAME, 0, port, + "R6RS custom binary ports do not " + "support `SEEK_END'"); + } + + return c_result; +} +#undef FUNC_NAME + +static int +cbp_close (SCM port) +{ + SCM close_proc; + + close_proc = SCM_CBP_CLOSE_PROC (port); + if (scm_is_true (close_proc)) + /* Invoke the `close' thunk. */ + scm_call_0 (close_proc); + + return 1; +} + + +/* Custom binary input port ("cbip" for short). */ + +static scm_t_bits custom_binary_input_port_type = 0; + +/* Size of the buffer embedded in custom binary input ports. */ +#define CBIP_BUFFER_SIZE 4096 + +/* Return the bytevector associated with PORT. */ +#define SCM_CBIP_BYTEVECTOR(_port) \ + SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 4) + +/* Return the various procedures of PORT. */ +#define SCM_CBIP_READ_PROC(_port) \ + SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0) + + +static inline SCM +make_cbip (SCM read_proc, SCM get_position_proc, + SCM set_position_proc, SCM close_proc) +{ + SCM port, bv, method_vector; + char *c_bv; + unsigned c_len; + scm_t_port *c_port; + const unsigned long mode_bits = SCM_OPN | SCM_RDNG; + + /* Use a bytevector as the underlying buffer. */ + c_len = CBIP_BUFFER_SIZE; + bv = scm_c_make_bytevector (c_len); + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); + + /* Store the various methods and bytevector in a vector. */ + method_vector = scm_c_make_vector (5, SCM_BOOL_F); + SCM_SIMPLE_VECTOR_SET (method_vector, 4, bv); + SCM_SIMPLE_VECTOR_SET (method_vector, 0, read_proc); + SCM_SIMPLE_VECTOR_SET (method_vector, 1, 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->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; + + /* 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; +} + +static int +cbip_fill_input (SCM port) +#define FUNC_NAME "cbip_fill_input" +{ + int result; + scm_t_port *c_port = SCM_PTAB_ENTRY (port); + + again: + if (c_port->read_pos >= c_port->read_end) + { + /* Invoke the user's `read!' procedure. */ + unsigned c_octets; + SCM bv, read_proc, octets; + + /* Use the bytevector associated with PORT as the buffer passed to the + `read!' procedure, thereby avoiding additional allocations. */ + bv = SCM_CBIP_BYTEVECTOR (port); + read_proc = SCM_CBIP_READ_PROC (port); + + /* The assumption here is that C_PORT's internal buffer wasn't changed + behind our back. */ + assert (c_port->read_buf == + (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv)); + assert ((unsigned) c_port->read_buf_size + == SCM_BYTEVECTOR_LENGTH (bv)); + + octets = scm_call_3 (read_proc, bv, SCM_INUM0, + SCM_I_MAKINUM (CBIP_BUFFER_SIZE)); + c_octets = scm_to_uint (octets); + + c_port->read_pos = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv); + c_port->read_end = (unsigned char *) c_port->read_pos + c_octets; + + if (c_octets > 0) + goto again; + else + result = EOF; + } + else + result = (int) *c_port->read_pos; + + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_make_custom_binary_input_port, + "make-custom-binary-input-port", 5, 0, 0, + (SCM id, SCM read_proc, SCM get_position_proc, + SCM set_position_proc, SCM close_proc), + "Return a new custom binary input port whose input is drained " + "by invoking @var{read_proc} and passing it a bytevector, an " + "index where octets should be written, and an octet count.") +#define FUNC_NAME s_scm_make_custom_binary_input_port +{ + SCM_VALIDATE_STRING (1, id); + SCM_VALIDATE_PROC (2, read_proc); + + if (!scm_is_false (get_position_proc)) + SCM_VALIDATE_PROC (3, get_position_proc); + + if (!scm_is_false (set_position_proc)) + SCM_VALIDATE_PROC (4, set_position_proc); + + if (!scm_is_false (close_proc)) + SCM_VALIDATE_PROC (5, close_proc); + + return (make_cbip (read_proc, get_position_proc, set_position_proc, + close_proc)); +} +#undef FUNC_NAME + + +/* Instantiate the custom binary input port type. */ +static inline void +initialize_custom_binary_input_ports (void) +{ + custom_binary_input_port_type = + scm_make_port_type ("r6rs-custom-binary-input-port", + cbip_fill_input, NULL); + + scm_set_port_seek (custom_binary_input_port_type, cbp_seek); + scm_set_port_close (custom_binary_input_port_type, cbp_close); +} + + + +/* Binary input. */ + +/* We currently don't support specific binary input ports. */ +#define SCM_VALIDATE_BINARY_INPUT_PORT SCM_VALIDATE_OPINPORT + +SCM_DEFINE (scm_get_u8, "get-u8", 1, 0, 0, + (SCM port), + "Read an octet from @var{port}, a binary input port, " + "blocking as necessary.") +#define FUNC_NAME s_scm_get_u8 +{ + SCM result; + int c_result; + + SCM_VALIDATE_BINARY_INPUT_PORT (1, port); + + c_result = scm_get_byte_or_eof (port); + if (c_result == EOF) + result = SCM_EOF_VAL; + else + result = SCM_I_MAKINUM ((unsigned char) c_result); + + return result; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_lookahead_u8, "lookahead-u8", 1, 0, 0, + (SCM port), + "Like @code{get-u8} but does not update @var{port} to " + "point past the octet.") +#define FUNC_NAME s_scm_lookahead_u8 +{ + int u8; + SCM result; + + SCM_VALIDATE_BINARY_INPUT_PORT (1, port); + + 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; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_get_bytevector_n, "get-bytevector-n", 2, 0, 0, + (SCM port, SCM count), + "Read @var{count} octets from @var{port}, blocking as " + "necessary and return a bytevector containing the octets " + "read. If fewer bytes are available, a bytevector smaller " + "than @var{count} is returned.") +#define FUNC_NAME s_scm_get_bytevector_n +{ + SCM result; + char *c_bv; + unsigned c_count; + size_t c_read; + + SCM_VALIDATE_BINARY_INPUT_PORT (1, port); + c_count = scm_to_uint (count); + + result = scm_c_make_bytevector (c_count); + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (result); + + if (SCM_LIKELY (c_count > 0)) + /* XXX: `scm_c_read ()' does not update the port position. */ + c_read = scm_c_read (port, c_bv, c_count); + else + /* Don't invoke `scm_c_read ()' since it may block. */ + c_read = 0; + + if ((c_read == 0) && (c_count > 0)) + { + if (SCM_EOF_OBJECT_P (scm_peek_char (port))) + result = SCM_EOF_VAL; + else + result = scm_null_bytevector; + } + else + { + if (c_read < c_count) + result = scm_c_shrink_bytevector (result, c_read); + } + + return result; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_get_bytevector_n_x, "get-bytevector-n!", 4, 0, 0, + (SCM port, SCM bv, SCM start, SCM count), + "Read @var{count} bytes from @var{port} and store them " + "in @var{bv} starting at index @var{start}. Return either " + "the number of bytes actually read or the end-of-file " + "object.") +#define FUNC_NAME s_scm_get_bytevector_n_x +{ + SCM result; + char *c_bv; + unsigned c_start, c_count, c_len; + size_t c_read; + + SCM_VALIDATE_BINARY_INPUT_PORT (1, port); + SCM_VALIDATE_BYTEVECTOR (2, bv); + c_start = scm_to_uint (start); + c_count = scm_to_uint (count); + + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); + c_len = SCM_BYTEVECTOR_LENGTH (bv); + + if (SCM_UNLIKELY (c_start + c_count > c_len)) + scm_out_of_range (FUNC_NAME, count); + + if (SCM_LIKELY (c_count > 0)) + c_read = scm_c_read (port, c_bv + c_start, c_count); + else + /* Don't invoke `scm_c_read ()' since it may block. */ + c_read = 0; + + if ((c_read == 0) && (c_count > 0)) + { + if (SCM_EOF_OBJECT_P (scm_peek_char (port))) + result = SCM_EOF_VAL; + else + result = SCM_I_MAKINUM (0); + } + else + result = scm_from_size_t (c_read); + + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0, + (SCM port), + "Read from @var{port}, blocking as necessary, until data " + "are available or and end-of-file is reached. Return either " + "a new bytevector containing the data read or the " + "end-of-file object.") +#define FUNC_NAME s_scm_get_bytevector_some +{ + /* Read at least one byte, unless the end-of-file is already reached, and + read while characters are available (buffered). */ + + SCM result; + char *c_bv; + unsigned c_len; + size_t c_total; + + SCM_VALIDATE_BINARY_INPUT_PORT (1, port); + + c_len = 4096; + c_bv = (char *) scm_gc_malloc_pointerless (c_len, SCM_GC_BYTEVECTOR); + c_total = 0; + + do + { + int c_chr; + + if (c_total + 1 > c_len) + { + /* Grow the bytevector. */ + c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2, + SCM_GC_BYTEVECTOR); + c_len *= 2; + } + + /* We can't use `scm_c_read ()' since it blocks. */ + c_chr = scm_getc (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)))); + + if (c_total == 0) + { + result = SCM_EOF_VAL; + scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR); + } + else + { + if (c_len > c_total) + { + /* Shrink the bytevector. */ + c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total, + SCM_GC_BYTEVECTOR); + c_len = (unsigned) c_total; + } + + result = scm_c_take_gc_bytevector ((signed char *) c_bv, c_len); + } + + return result; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 0, + (SCM port), + "Read from @var{port}, blocking as necessary, until " + "the end-of-file is reached. Return either " + "a new bytevector containing the data read or the " + "end-of-file object (if no data were available).") +#define FUNC_NAME s_scm_get_bytevector_all +{ + SCM result; + char *c_bv; + unsigned c_len, c_count; + size_t c_read, c_total; + + SCM_VALIDATE_BINARY_INPUT_PORT (1, port); + + c_len = c_count = 4096; + c_bv = (char *) scm_gc_malloc_pointerless (c_len, SCM_GC_BYTEVECTOR); + c_total = c_read = 0; + + do + { + if (c_total + c_read > c_len) + { + /* Grow the bytevector. */ + c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2, + SCM_GC_BYTEVECTOR); + c_count = c_len; + c_len *= 2; + } + + /* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is + reached. */ + 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))); + + if (c_total == 0) + { + result = SCM_EOF_VAL; + scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR); + } + else + { + if (c_len > c_total) + { + /* Shrink the bytevector. */ + c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total, + SCM_GC_BYTEVECTOR); + c_len = (unsigned) c_total; + } + + result = scm_c_take_gc_bytevector ((signed char *) c_bv, c_len); + } + + return result; +} +#undef FUNC_NAME + + + +/* Binary output. */ + +/* We currently don't support specific binary input ports. */ +#define SCM_VALIDATE_BINARY_OUTPUT_PORT SCM_VALIDATE_OPOUTPORT + + +SCM_DEFINE (scm_put_u8, "put-u8", 2, 0, 0, + (SCM port, SCM octet), + "Write @var{octet} to binary port @var{port}.") +#define FUNC_NAME s_scm_put_u8 +{ + scm_t_uint8 c_octet; + + SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port); + c_octet = scm_to_uint8 (octet); + + scm_putc ((char) c_octet, port); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_put_bytevector, "put-bytevector", 2, 2, 0, + (SCM port, SCM bv, SCM start, SCM count), + "Write the contents of @var{bv} to @var{port}, optionally " + "starting at index @var{start} and limiting to @var{count} " + "octets.") +#define FUNC_NAME s_scm_put_bytevector +{ + char *c_bv; + unsigned c_start, c_count, c_len; + + SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port); + SCM_VALIDATE_BYTEVECTOR (2, bv); + + c_len = SCM_BYTEVECTOR_LENGTH (bv); + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); + + if (!scm_is_eq (start, SCM_UNDEFINED)) + { + c_start = scm_to_uint (start); + + if (!scm_is_eq (count, SCM_UNDEFINED)) + { + c_count = scm_to_uint (count); + if (SCM_UNLIKELY (c_start + c_count > c_len)) + scm_out_of_range (FUNC_NAME, count); + } + else + { + if (SCM_UNLIKELY (c_start >= c_len)) + scm_out_of_range (FUNC_NAME, start); + else + c_count = c_len - c_start; + } + } + else + c_start = 0, c_count = c_len; + + scm_c_write (port, c_bv + c_start, c_count); + + return SCM_UNSPECIFIED; +} +#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_BOP_BUFFER(_port) \ + ((scm_t_bop_buffer *) SCM_STREAM (_port)) +#define SCM_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, size_t min_size) +{ + char *new_buf; + size_t new_size; + + for (new_size = buf->total_len + ? buf->total_len : SCM_BOP_BUFFER_INITIAL_SIZE; + new_size < min_size; + new_size *= 2); + + if (buf->buffer) + new_buf = scm_gc_realloc ((void *) buf->buffer, buf->total_len, + new_size, SCM_GC_BOP); + else + new_buf = scm_gc_malloc_pointerless (new_size, SCM_GC_BOP); + + buf->buffer = new_buf; + buf->total_len = new_size; +} + +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_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->write_buf = c_port->write_pos = c_port->write_end = NULL; + c_port->write_buf_size = 0; + + SCM_SET_BOP_BUFFER (port, buf); + + /* 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, buf); + + return (scm_values (scm_list_2 (port, bop_proc))); +} + +/* 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_BOP_BUFFER (port); + + if (buf->pos + size > buf->total_len) + bop_buffer_grow (buf, buf->pos + size); + + memcpy (buf->buffer + buf->pos, data, size); + buf->pos += size; + buf->len = (buf->len > buf->pos) ? buf->len : buf->pos; +} + +static scm_t_off +bop_seek (SCM port, scm_t_off offset, int whence) +#define FUNC_NAME "bop_seek" +{ + scm_t_bop_buffer *buf; + + buf = SCM_BOP_BUFFER (port); + switch (whence) + { + case SEEK_CUR: + offset += (scm_t_off) buf->pos; + /* Fall through. */ + + case SEEK_SET: + if (offset < 0 || (unsigned) offset > buf->len) + scm_out_of_range (FUNC_NAME, scm_from_int (offset)); + else + buf->pos = offset; + break; + + case SEEK_END: + if (offset < 0 || (unsigned) offset >= buf->len) + scm_out_of_range (FUNC_NAME, scm_from_int (offset)); + else + buf->pos = buf->len - (offset + 1); + 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 bv; + scm_t_bop_buffer *buf, result_buf; + + 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_gc_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_c_take_gc_bytevector ((signed char *) result_buf.buffer, + result_buf.len); + } + + return bv; +} + +SCM_DEFINE (scm_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 s_scm_open_bytevector_output_port +{ + if (!SCM_UNBNDP (transcoder) && !scm_is_false (transcoder)) + 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); +} + + +/* Custom binary output port ("cbop" for short). */ + +static scm_t_bits custom_binary_output_port_type; + +/* Return the various procedures of PORT. */ +#define SCM_CBOP_WRITE_PROC(_port) \ + SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0) + + +static inline SCM +make_cbop (SCM write_proc, SCM get_position_proc, + SCM set_position_proc, SCM close_proc) +{ + SCM port, method_vector; + scm_t_port *c_port; + const unsigned long mode_bits = SCM_OPN | SCM_WRTNG; + + /* Store the various methods and bytevector in a vector. */ + method_vector = scm_c_make_vector (4, SCM_BOOL_F); + SCM_SIMPLE_VECTOR_SET (method_vector, 0, write_proc); + SCM_SIMPLE_VECTOR_SET (method_vector, 1, 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->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; +} + +/* Write SIZE octets from DATA to PORT. */ +static void +cbop_write (SCM port, const void *data, size_t size) +#define FUNC_NAME "cbop_write" +{ + long int c_result; + size_t c_written; + SCM bv, write_proc, result; + + /* XXX: Allocating a new bytevector at each `write' call is inefficient, + but necessary since (1) we don't control the lifetime of the buffer + pointed to by DATA, and (2) the `write!' procedure could capture the + bytevector it is passed. */ + bv = scm_c_make_bytevector (size); + memcpy (SCM_BYTEVECTOR_CONTENTS (bv), data, size); + + write_proc = SCM_CBOP_WRITE_PROC (port); + + /* Since the `write' procedure of Guile's ports has type `void', it must + try hard to write exactly SIZE bytes, regardless of how many bytes the + sink can handle. */ + for (c_written = 0; + c_written < size; + c_written += c_result) + { + result = scm_call_3 (write_proc, bv, + scm_from_size_t (c_written), + scm_from_size_t (size - c_written)); + + c_result = scm_to_long (result); + if (SCM_UNLIKELY (c_result < 0 + || (size_t) c_result > (size - c_written))) + scm_wrong_type_arg_msg (FUNC_NAME, 0, result, + "R6RS custom binary output port `write!' " + "returned a incorrect integer"); + } +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_make_custom_binary_output_port, + "make-custom-binary-output-port", 5, 0, 0, + (SCM id, SCM write_proc, SCM get_position_proc, + SCM set_position_proc, SCM close_proc), + "Return a new custom binary output port whose output is drained " + "by invoking @var{write_proc} and passing it a bytevector, an " + "index where octets should be written, and an octet count.") +#define FUNC_NAME s_scm_make_custom_binary_output_port +{ + SCM_VALIDATE_STRING (1, id); + SCM_VALIDATE_PROC (2, write_proc); + + if (!scm_is_false (get_position_proc)) + SCM_VALIDATE_PROC (3, get_position_proc); + + if (!scm_is_false (set_position_proc)) + SCM_VALIDATE_PROC (4, set_position_proc); + + if (!scm_is_false (close_proc)) + SCM_VALIDATE_PROC (5, close_proc); + + return (make_cbop (write_proc, get_position_proc, set_position_proc, + close_proc)); +} +#undef FUNC_NAME + + +/* Instantiate the custom binary output port type. */ +static inline void +initialize_custom_binary_output_ports (void) +{ + custom_binary_output_port_type = + scm_make_port_type ("r6rs-custom-binary-output-port", + NULL, cbop_write); + + scm_set_port_seek (custom_binary_output_port_type, cbp_seek); + scm_set_port_close (custom_binary_output_port_type, cbp_close); +} + + +/* 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_binary_ports (void) +{ + scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, + "scm_init_binary_ports", + (scm_t_extension_init_func) scm_init_binary_ports, + NULL); +} + +void +scm_init_binary_ports (void) +{ +#include "libguile/binary-ports.x" + + initialize_bytevector_input_ports (); + initialize_custom_binary_input_ports (); + initialize_bytevector_output_ports (); + initialize_custom_binary_output_ports (); +} diff --git a/libguile/binary-ports.h b/libguile/binary-ports.h new file mode 100644 index 0000000..efd7ed9 --- /dev/null +++ b/libguile/binary-ports.h @@ -0,0 +1,46 @@ +#ifndef SCM_BINARY_PORTS_H +#define SCM_BINARY_PORTS_H + +/* Copyright (C) 2009, 2010, 2011 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 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 + * 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 + */ + + + +#include "libguile/__scm.h" + +/* Binary I/O Ports. */ + +SCM_API SCM scm_eof_object (void); +SCM_API SCM scm_open_bytevector_input_port (SCM, SCM); +SCM_API SCM scm_make_custom_binary_input_port (SCM, SCM, SCM, SCM, SCM); +SCM_API SCM scm_get_u8 (SCM); +SCM_API SCM scm_lookahead_u8 (SCM); +SCM_API SCM scm_get_bytevector_n (SCM, SCM); +SCM_API SCM scm_get_bytevector_n_x (SCM, SCM, SCM, SCM); +SCM_API SCM scm_get_bytevector_some (SCM); +SCM_API SCM scm_get_bytevector_all (SCM); +SCM_API SCM scm_put_u8 (SCM, SCM); +SCM_API SCM scm_put_bytevector (SCM, SCM, SCM, SCM); +SCM_API SCM scm_open_bytevector_output_port (SCM); +SCM_API SCM scm_make_custom_binary_output_port (SCM, SCM, SCM, SCM, SCM); +SCM_API SCM scm_get_string_n_x (SCM, SCM, SCM, SCM); + +SCM_API void scm_init_binary_ports (void); +SCM_INTERNAL void scm_register_binary_ports (void); + +#endif /* SCM_BINARY_PORTS_H */ diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c index e867429..19dea8d 100644 --- a/libguile/r6rs-ports.c +++ b/libguile/r6rs-ports.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc. +/* Copyright (C) 2009, 2010, 2011, 2012 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 @@ -20,1073 +20,8 @@ # include #endif -#ifdef HAVE_UNISTD_H -# include -#endif - -#include -#include -#include - #include "libguile/_scm.h" -#include "libguile/bytevectors.h" -#include "libguile/chars.h" -#include "libguile/eval.h" #include "libguile/r6rs-ports.h" -#include "libguile/strings.h" -#include "libguile/validate.h" -#include "libguile/values.h" -#include "libguile/vectors.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. */ - -SCM_DEFINE (scm_eof_object, "eof-object", 0, 0, 0, - (void), - "Return the end-of-file object.") -#define FUNC_NAME s_scm_eof_object -{ - return (SCM_EOF_VAL); -} -#undef FUNC_NAME - - -/* Input ports. */ - -#ifndef MIN -# define MIN(a,b) ((a) < (b) ? (a) : (b)) -#endif - -/* Bytevector input ports or "bip" for short. */ -static scm_t_bits bytevector_input_port_type = 0; - -static inline SCM -make_bip (SCM bv) -{ - SCM port; - char *c_bv; - unsigned c_len; - 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)); - - /* Have the port directly access the bytevector. */ - c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); - c_len = SCM_BYTEVECTOR_LENGTH (bv); - - 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; - - /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */ - SCM_SET_CELL_TYPE (port, bytevector_input_port_type | mode_bits); - - scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex); - - return port; -} - -static int -bip_fill_input (SCM port) -{ - int result; - scm_t_port *c_port = SCM_PTAB_ENTRY (port); - - if (c_port->read_pos >= c_port->read_end) - result = EOF; - else - result = (int) *c_port->read_pos; - - return result; -} - -static scm_t_off -bip_seek (SCM port, scm_t_off offset, int whence) -#define FUNC_NAME "bip_seek" -{ - scm_t_off c_result = 0; - scm_t_port *c_port = SCM_PTAB_ENTRY (port); - - switch (whence) - { - case SEEK_CUR: - offset += c_port->read_pos - c_port->read_buf; - /* Fall through. */ - - case SEEK_SET: - if (c_port->read_buf + offset <= c_port->read_end) - { - c_port->read_pos = c_port->read_buf + offset; - c_result = offset; - } - else - scm_out_of_range (FUNC_NAME, scm_from_int (offset)); - break; - - case SEEK_END: - if (c_port->read_end - offset >= c_port->read_buf) - { - c_port->read_pos = c_port->read_end - offset; - c_result = c_port->read_pos - c_port->read_buf; - } - else - scm_out_of_range (FUNC_NAME, scm_from_int (offset)); - break; - - default: - scm_wrong_type_arg_msg (FUNC_NAME, 0, port, - "invalid `seek' parameter"); - } - - return c_result; -} -#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", bip_fill_input, - NULL); - - scm_set_port_seek (bytevector_input_port_type, bip_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_bip (bv)); -} -#undef FUNC_NAME - - -/* Custom binary ports. The following routines are shared by input and - output custom binary ports. */ - -#define SCM_CBP_GET_POSITION_PROC(_port) \ - SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 1) -#define SCM_CBP_SET_POSITION_PROC(_port) \ - SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 2) -#define SCM_CBP_CLOSE_PROC(_port) \ - SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 3) - -static scm_t_off -cbp_seek (SCM port, scm_t_off offset, int whence) -#define FUNC_NAME "cbp_seek" -{ - SCM result; - scm_t_off c_result = 0; - - switch (whence) - { - case SEEK_CUR: - { - SCM get_position_proc; - - get_position_proc = SCM_CBP_GET_POSITION_PROC (port); - if (SCM_LIKELY (scm_is_true (get_position_proc))) - result = scm_call_0 (get_position_proc); - else - scm_wrong_type_arg_msg (FUNC_NAME, 0, port, - "R6RS custom binary port does not " - "support `port-position'"); - - offset += scm_to_int (result); - /* Fall through. */ - } - - case SEEK_SET: - { - SCM set_position_proc; - - set_position_proc = SCM_CBP_SET_POSITION_PROC (port); - if (SCM_LIKELY (scm_is_true (set_position_proc))) - result = scm_call_1 (set_position_proc, scm_from_int (offset)); - else - scm_wrong_type_arg_msg (FUNC_NAME, 0, port, - "R6RS custom binary port does not " - "support `set-port-position!'"); - - /* Assuming setting the position succeeded. */ - c_result = offset; - break; - } - - default: - /* `SEEK_END' cannot be supported. */ - scm_wrong_type_arg_msg (FUNC_NAME, 0, port, - "R6RS custom binary ports do not " - "support `SEEK_END'"); - } - - return c_result; -} -#undef FUNC_NAME - -static int -cbp_close (SCM port) -{ - SCM close_proc; - - close_proc = SCM_CBP_CLOSE_PROC (port); - if (scm_is_true (close_proc)) - /* Invoke the `close' thunk. */ - scm_call_0 (close_proc); - - return 1; -} - - -/* Custom binary input port ("cbip" for short). */ - -static scm_t_bits custom_binary_input_port_type = 0; - -/* Size of the buffer embedded in custom binary input ports. */ -#define CBIP_BUFFER_SIZE 4096 - -/* Return the bytevector associated with PORT. */ -#define SCM_CBIP_BYTEVECTOR(_port) \ - SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 4) - -/* Return the various procedures of PORT. */ -#define SCM_CBIP_READ_PROC(_port) \ - SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0) - - -static inline SCM -make_cbip (SCM read_proc, SCM get_position_proc, - SCM set_position_proc, SCM close_proc) -{ - SCM port, bv, method_vector; - char *c_bv; - unsigned c_len; - scm_t_port *c_port; - const unsigned long mode_bits = SCM_OPN | SCM_RDNG; - - /* Use a bytevector as the underlying buffer. */ - c_len = CBIP_BUFFER_SIZE; - bv = scm_c_make_bytevector (c_len); - c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); - - /* Store the various methods and bytevector in a vector. */ - method_vector = scm_c_make_vector (5, SCM_BOOL_F); - SCM_SIMPLE_VECTOR_SET (method_vector, 4, bv); - SCM_SIMPLE_VECTOR_SET (method_vector, 0, read_proc); - SCM_SIMPLE_VECTOR_SET (method_vector, 1, 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->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; - - /* 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; -} - -static int -cbip_fill_input (SCM port) -#define FUNC_NAME "cbip_fill_input" -{ - int result; - scm_t_port *c_port = SCM_PTAB_ENTRY (port); - - again: - if (c_port->read_pos >= c_port->read_end) - { - /* Invoke the user's `read!' procedure. */ - unsigned c_octets; - SCM bv, read_proc, octets; - - /* Use the bytevector associated with PORT as the buffer passed to the - `read!' procedure, thereby avoiding additional allocations. */ - bv = SCM_CBIP_BYTEVECTOR (port); - read_proc = SCM_CBIP_READ_PROC (port); - - /* The assumption here is that C_PORT's internal buffer wasn't changed - behind our back. */ - assert (c_port->read_buf == - (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv)); - assert ((unsigned) c_port->read_buf_size - == SCM_BYTEVECTOR_LENGTH (bv)); - - octets = scm_call_3 (read_proc, bv, SCM_INUM0, - SCM_I_MAKINUM (CBIP_BUFFER_SIZE)); - c_octets = scm_to_uint (octets); - - c_port->read_pos = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv); - c_port->read_end = (unsigned char *) c_port->read_pos + c_octets; - - if (c_octets > 0) - goto again; - else - result = EOF; - } - else - result = (int) *c_port->read_pos; - - return result; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_make_custom_binary_input_port, - "make-custom-binary-input-port", 5, 0, 0, - (SCM id, SCM read_proc, SCM get_position_proc, - SCM set_position_proc, SCM close_proc), - "Return a new custom binary input port whose input is drained " - "by invoking @var{read_proc} and passing it a bytevector, an " - "index where octets should be written, and an octet count.") -#define FUNC_NAME s_scm_make_custom_binary_input_port -{ - SCM_VALIDATE_STRING (1, id); - SCM_VALIDATE_PROC (2, read_proc); - - if (!scm_is_false (get_position_proc)) - SCM_VALIDATE_PROC (3, get_position_proc); - - if (!scm_is_false (set_position_proc)) - SCM_VALIDATE_PROC (4, set_position_proc); - - if (!scm_is_false (close_proc)) - SCM_VALIDATE_PROC (5, close_proc); - - return (make_cbip (read_proc, get_position_proc, set_position_proc, - close_proc)); -} -#undef FUNC_NAME - - -/* Instantiate the custom binary input port type. */ -static inline void -initialize_custom_binary_input_ports (void) -{ - custom_binary_input_port_type = - scm_make_port_type ("r6rs-custom-binary-input-port", - cbip_fill_input, NULL); - - scm_set_port_seek (custom_binary_input_port_type, cbp_seek); - scm_set_port_close (custom_binary_input_port_type, cbp_close); -} - - - -/* Binary input. */ - -/* We currently don't support specific binary input ports. */ -#define SCM_VALIDATE_BINARY_INPUT_PORT SCM_VALIDATE_OPINPORT - -SCM_DEFINE (scm_get_u8, "get-u8", 1, 0, 0, - (SCM port), - "Read an octet from @var{port}, a binary input port, " - "blocking as necessary.") -#define FUNC_NAME s_scm_get_u8 -{ - SCM result; - int c_result; - - SCM_VALIDATE_BINARY_INPUT_PORT (1, port); - - c_result = scm_get_byte_or_eof (port); - if (c_result == EOF) - result = SCM_EOF_VAL; - else - result = SCM_I_MAKINUM ((unsigned char) c_result); - - return result; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_lookahead_u8, "lookahead-u8", 1, 0, 0, - (SCM port), - "Like @code{get-u8} but does not update @var{port} to " - "point past the octet.") -#define FUNC_NAME s_scm_lookahead_u8 -{ - int u8; - SCM result; - - SCM_VALIDATE_BINARY_INPUT_PORT (1, port); - - 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; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_get_bytevector_n, "get-bytevector-n", 2, 0, 0, - (SCM port, SCM count), - "Read @var{count} octets from @var{port}, blocking as " - "necessary and return a bytevector containing the octets " - "read. If fewer bytes are available, a bytevector smaller " - "than @var{count} is returned.") -#define FUNC_NAME s_scm_get_bytevector_n -{ - SCM result; - char *c_bv; - unsigned c_count; - size_t c_read; - - SCM_VALIDATE_BINARY_INPUT_PORT (1, port); - c_count = scm_to_uint (count); - - result = scm_c_make_bytevector (c_count); - c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (result); - - if (SCM_LIKELY (c_count > 0)) - /* XXX: `scm_c_read ()' does not update the port position. */ - c_read = scm_c_read (port, c_bv, c_count); - else - /* Don't invoke `scm_c_read ()' since it may block. */ - c_read = 0; - - if ((c_read == 0) && (c_count > 0)) - { - if (SCM_EOF_OBJECT_P (scm_peek_char (port))) - result = SCM_EOF_VAL; - else - result = scm_null_bytevector; - } - else - { - if (c_read < c_count) - result = scm_c_shrink_bytevector (result, c_read); - } - - return result; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_get_bytevector_n_x, "get-bytevector-n!", 4, 0, 0, - (SCM port, SCM bv, SCM start, SCM count), - "Read @var{count} bytes from @var{port} and store them " - "in @var{bv} starting at index @var{start}. Return either " - "the number of bytes actually read or the end-of-file " - "object.") -#define FUNC_NAME s_scm_get_bytevector_n_x -{ - SCM result; - char *c_bv; - unsigned c_start, c_count, c_len; - size_t c_read; - - SCM_VALIDATE_BINARY_INPUT_PORT (1, port); - SCM_VALIDATE_BYTEVECTOR (2, bv); - c_start = scm_to_uint (start); - c_count = scm_to_uint (count); - - c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); - c_len = SCM_BYTEVECTOR_LENGTH (bv); - - if (SCM_UNLIKELY (c_start + c_count > c_len)) - scm_out_of_range (FUNC_NAME, count); - - if (SCM_LIKELY (c_count > 0)) - c_read = scm_c_read (port, c_bv + c_start, c_count); - else - /* Don't invoke `scm_c_read ()' since it may block. */ - c_read = 0; - - if ((c_read == 0) && (c_count > 0)) - { - if (SCM_EOF_OBJECT_P (scm_peek_char (port))) - result = SCM_EOF_VAL; - else - result = SCM_I_MAKINUM (0); - } - else - result = scm_from_size_t (c_read); - - return result; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0, - (SCM port), - "Read from @var{port}, blocking as necessary, until data " - "are available or and end-of-file is reached. Return either " - "a new bytevector containing the data read or the " - "end-of-file object.") -#define FUNC_NAME s_scm_get_bytevector_some -{ - /* Read at least one byte, unless the end-of-file is already reached, and - read while characters are available (buffered). */ - - SCM result; - char *c_bv; - unsigned c_len; - size_t c_total; - - SCM_VALIDATE_BINARY_INPUT_PORT (1, port); - - c_len = 4096; - c_bv = (char *) scm_gc_malloc_pointerless (c_len, SCM_GC_BYTEVECTOR); - c_total = 0; - - do - { - int c_chr; - - if (c_total + 1 > c_len) - { - /* Grow the bytevector. */ - c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2, - SCM_GC_BYTEVECTOR); - c_len *= 2; - } - - /* We can't use `scm_c_read ()' since it blocks. */ - c_chr = scm_getc (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)))); - - if (c_total == 0) - { - result = SCM_EOF_VAL; - scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR); - } - else - { - if (c_len > c_total) - { - /* Shrink the bytevector. */ - c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total, - SCM_GC_BYTEVECTOR); - c_len = (unsigned) c_total; - } - - result = scm_c_take_gc_bytevector ((signed char *) c_bv, c_len); - } - - return result; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 0, - (SCM port), - "Read from @var{port}, blocking as necessary, until " - "the end-of-file is reached. Return either " - "a new bytevector containing the data read or the " - "end-of-file object (if no data were available).") -#define FUNC_NAME s_scm_get_bytevector_all -{ - SCM result; - char *c_bv; - unsigned c_len, c_count; - size_t c_read, c_total; - - SCM_VALIDATE_BINARY_INPUT_PORT (1, port); - - c_len = c_count = 4096; - c_bv = (char *) scm_gc_malloc_pointerless (c_len, SCM_GC_BYTEVECTOR); - c_total = c_read = 0; - - do - { - if (c_total + c_read > c_len) - { - /* Grow the bytevector. */ - c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2, - SCM_GC_BYTEVECTOR); - c_count = c_len; - c_len *= 2; - } - - /* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is - reached. */ - 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))); - - if (c_total == 0) - { - result = SCM_EOF_VAL; - scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR); - } - else - { - if (c_len > c_total) - { - /* Shrink the bytevector. */ - c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total, - SCM_GC_BYTEVECTOR); - c_len = (unsigned) c_total; - } - - result = scm_c_take_gc_bytevector ((signed char *) c_bv, c_len); - } - - return result; -} -#undef FUNC_NAME - - - -/* Binary output. */ - -/* We currently don't support specific binary input ports. */ -#define SCM_VALIDATE_BINARY_OUTPUT_PORT SCM_VALIDATE_OPOUTPORT - - -SCM_DEFINE (scm_put_u8, "put-u8", 2, 0, 0, - (SCM port, SCM octet), - "Write @var{octet} to binary port @var{port}.") -#define FUNC_NAME s_scm_put_u8 -{ - scm_t_uint8 c_octet; - - SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port); - c_octet = scm_to_uint8 (octet); - - scm_putc ((char) c_octet, port); - - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_put_bytevector, "put-bytevector", 2, 2, 0, - (SCM port, SCM bv, SCM start, SCM count), - "Write the contents of @var{bv} to @var{port}, optionally " - "starting at index @var{start} and limiting to @var{count} " - "octets.") -#define FUNC_NAME s_scm_put_bytevector -{ - char *c_bv; - unsigned c_start, c_count, c_len; - - SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port); - SCM_VALIDATE_BYTEVECTOR (2, bv); - - c_len = SCM_BYTEVECTOR_LENGTH (bv); - c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); - - if (!scm_is_eq (start, SCM_UNDEFINED)) - { - c_start = scm_to_uint (start); - - if (!scm_is_eq (count, SCM_UNDEFINED)) - { - c_count = scm_to_uint (count); - if (SCM_UNLIKELY (c_start + c_count > c_len)) - scm_out_of_range (FUNC_NAME, count); - } - else - { - if (SCM_UNLIKELY (c_start >= c_len)) - scm_out_of_range (FUNC_NAME, start); - else - c_count = c_len - c_start; - } - } - else - c_start = 0, c_count = c_len; - - scm_c_write (port, c_bv + c_start, c_count); - - return SCM_UNSPECIFIED; -} -#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_BOP_BUFFER(_port) \ - ((scm_t_bop_buffer *) SCM_STREAM (_port)) -#define SCM_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, size_t min_size) -{ - char *new_buf; - size_t new_size; - - for (new_size = buf->total_len - ? buf->total_len : SCM_BOP_BUFFER_INITIAL_SIZE; - new_size < min_size; - new_size *= 2); - - if (buf->buffer) - new_buf = scm_gc_realloc ((void *) buf->buffer, buf->total_len, - new_size, SCM_GC_BOP); - else - new_buf = scm_gc_malloc_pointerless (new_size, SCM_GC_BOP); - - buf->buffer = new_buf; - buf->total_len = new_size; -} - -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_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->write_buf = c_port->write_pos = c_port->write_end = NULL; - c_port->write_buf_size = 0; - - SCM_SET_BOP_BUFFER (port, buf); - - /* 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, buf); - - return (scm_values (scm_list_2 (port, bop_proc))); -} - -/* 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_BOP_BUFFER (port); - - if (buf->pos + size > buf->total_len) - bop_buffer_grow (buf, buf->pos + size); - - memcpy (buf->buffer + buf->pos, data, size); - buf->pos += size; - buf->len = (buf->len > buf->pos) ? buf->len : buf->pos; -} - -static scm_t_off -bop_seek (SCM port, scm_t_off offset, int whence) -#define FUNC_NAME "bop_seek" -{ - scm_t_bop_buffer *buf; - - buf = SCM_BOP_BUFFER (port); - switch (whence) - { - case SEEK_CUR: - offset += (scm_t_off) buf->pos; - /* Fall through. */ - - case SEEK_SET: - if (offset < 0 || (unsigned) offset > buf->len) - scm_out_of_range (FUNC_NAME, scm_from_int (offset)); - else - buf->pos = offset; - break; - - case SEEK_END: - if (offset < 0 || (unsigned) offset >= buf->len) - scm_out_of_range (FUNC_NAME, scm_from_int (offset)); - else - buf->pos = buf->len - (offset + 1); - 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 bv; - scm_t_bop_buffer *buf, result_buf; - - 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_gc_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_c_take_gc_bytevector ((signed char *) result_buf.buffer, - result_buf.len); - } - - return bv; -} - -SCM_DEFINE (scm_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 s_scm_open_bytevector_output_port -{ - if (!SCM_UNBNDP (transcoder) && !scm_is_false (transcoder)) - 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); -} - - -/* Custom binary output port ("cbop" for short). */ - -static scm_t_bits custom_binary_output_port_type; - -/* Return the various procedures of PORT. */ -#define SCM_CBOP_WRITE_PROC(_port) \ - SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0) - - -static inline SCM -make_cbop (SCM write_proc, SCM get_position_proc, - SCM set_position_proc, SCM close_proc) -{ - SCM port, method_vector; - scm_t_port *c_port; - const unsigned long mode_bits = SCM_OPN | SCM_WRTNG; - - /* Store the various methods and bytevector in a vector. */ - method_vector = scm_c_make_vector (4, SCM_BOOL_F); - SCM_SIMPLE_VECTOR_SET (method_vector, 0, write_proc); - SCM_SIMPLE_VECTOR_SET (method_vector, 1, 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->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; -} - -/* Write SIZE octets from DATA to PORT. */ -static void -cbop_write (SCM port, const void *data, size_t size) -#define FUNC_NAME "cbop_write" -{ - long int c_result; - size_t c_written; - SCM bv, write_proc, result; - - /* XXX: Allocating a new bytevector at each `write' call is inefficient, - but necessary since (1) we don't control the lifetime of the buffer - pointed to by DATA, and (2) the `write!' procedure could capture the - bytevector it is passed. */ - bv = scm_c_make_bytevector (size); - memcpy (SCM_BYTEVECTOR_CONTENTS (bv), data, size); - - write_proc = SCM_CBOP_WRITE_PROC (port); - - /* Since the `write' procedure of Guile's ports has type `void', it must - try hard to write exactly SIZE bytes, regardless of how many bytes the - sink can handle. */ - for (c_written = 0; - c_written < size; - c_written += c_result) - { - result = scm_call_3 (write_proc, bv, - scm_from_size_t (c_written), - scm_from_size_t (size - c_written)); - - c_result = scm_to_long (result); - if (SCM_UNLIKELY (c_result < 0 - || (size_t) c_result > (size - c_written))) - scm_wrong_type_arg_msg (FUNC_NAME, 0, result, - "R6RS custom binary output port `write!' " - "returned a incorrect integer"); - } -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_make_custom_binary_output_port, - "make-custom-binary-output-port", 5, 0, 0, - (SCM id, SCM write_proc, SCM get_position_proc, - SCM set_position_proc, SCM close_proc), - "Return a new custom binary output port whose output is drained " - "by invoking @var{write_proc} and passing it a bytevector, an " - "index where octets should be written, and an octet count.") -#define FUNC_NAME s_scm_make_custom_binary_output_port -{ - SCM_VALIDATE_STRING (1, id); - SCM_VALIDATE_PROC (2, write_proc); - - if (!scm_is_false (get_position_proc)) - SCM_VALIDATE_PROC (3, get_position_proc); - - if (!scm_is_false (set_position_proc)) - SCM_VALIDATE_PROC (4, set_position_proc); - - if (!scm_is_false (close_proc)) - SCM_VALIDATE_PROC (5, close_proc); - - return (make_cbop (write_proc, get_position_proc, set_position_proc, - close_proc)); -} -#undef FUNC_NAME - - -/* Instantiate the custom binary output port type. */ -static inline void -initialize_custom_binary_output_ports (void) -{ - custom_binary_output_port_type = - scm_make_port_type ("r6rs-custom-binary-output-port", - NULL, cbop_write); - - 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). */ @@ -1240,46 +175,6 @@ SCM_DEFINE (scm_i_make_transcoded_port, #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 @@ -1296,9 +191,5 @@ scm_init_r6rs_ports (void) { #include "libguile/r6rs-ports.x" - initialize_bytevector_input_ports (); - initialize_custom_binary_input_ports (); - initialize_bytevector_output_ports (); - initialize_custom_binary_output_ports (); initialize_transcoded_ports (); } diff --git a/libguile/r6rs-ports.h b/libguile/r6rs-ports.h index 2ae3e76..682abcf 100644 --- a/libguile/r6rs-ports.h +++ b/libguile/r6rs-ports.h @@ -1,7 +1,7 @@ #ifndef SCM_R6RS_PORTS_H #define SCM_R6RS_PORTS_H -/* Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc. +/* Copyright (C) 2009, 2010, 2011, 2012 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 @@ -21,24 +21,7 @@ -#include "libguile/__scm.h" - -/* R6RS I/O Ports. */ - -SCM_API SCM scm_eof_object (void); -SCM_API SCM scm_open_bytevector_input_port (SCM, SCM); -SCM_API SCM scm_make_custom_binary_input_port (SCM, SCM, SCM, SCM, SCM); -SCM_API SCM scm_get_u8 (SCM); -SCM_API SCM scm_lookahead_u8 (SCM); -SCM_API SCM scm_get_bytevector_n (SCM, SCM); -SCM_API SCM scm_get_bytevector_n_x (SCM, SCM, SCM, SCM); -SCM_API SCM scm_get_bytevector_some (SCM); -SCM_API SCM scm_get_bytevector_all (SCM); -SCM_API SCM scm_put_u8 (SCM, SCM); -SCM_API SCM scm_put_bytevector (SCM, SCM, SCM, SCM); -SCM_API SCM scm_open_bytevector_output_port (SCM); -SCM_API SCM scm_make_custom_binary_output_port (SCM, SCM, SCM, SCM, SCM); -SCM_API SCM scm_get_string_n_x (SCM, SCM, SCM, SCM); +#include "libguile/binary-ports.h" SCM_API void scm_init_r6rs_ports (void); SCM_INTERNAL void scm_register_r6rs_ports (void); diff --git a/module/ice-9/binary-ports.scm b/module/ice-9/binary-ports.scm index c07900b..59450ac 100644 --- a/module/ice-9/binary-ports.scm +++ b/module/ice-9/binary-ports.scm @@ -1,6 +1,6 @@ ;;;; binary-ports.scm --- Binary IO on ports -;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 2009, 2010, 2011, 2012 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 @@ -43,8 +43,5 @@ open-bytevector-output-port make-custom-binary-output-port)) -;; 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") + "scm_init_binary_ports") diff --git a/module/rnrs/io/ports.scm b/module/rnrs/io/ports.scm index 7c17b0c..ee8c05a 100644 --- a/module/rnrs/io/ports.scm +++ b/module/rnrs/io/ports.scm @@ -1,6 +1,6 @@ ;;;; ports.scm --- R6RS port API -*- coding: utf-8 -*- -;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 2009, 2010, 2011, 2012 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 @@ -118,6 +118,10 @@ guile:)) +(eval-when (load eval compile) + (load-extension (string-append "libguile-" (effective-version)) + "scm_init_r6rs_ports")) + ;;; ;;; Auxiliary types @@ -253,8 +257,7 @@ Guile." "Return a new textual port based on @var{port}, using @var{transcoder} to encode and decode data written to or read from its underlying binary port @var{port}." - ;; Hackily get at %make-transcoded-port. - (let ((result ((@@ (ice-9 binary-ports) %make-transcoded-port) port))) + (let ((result (%make-transcoded-port port))) (set-port-encoding! result (transcoder-codec transcoder)) (case (transcoder-error-handling-mode transcoder) ((raise) -- 1.7.10.4