diff options
Diffstat (limited to 'libguile/strports.c')
-rw-r--r-- | libguile/strports.c | 403 |
1 files changed, 403 insertions, 0 deletions
diff --git a/libguile/strports.c b/libguile/strports.c new file mode 100644 index 000000000..c23b0bac6 --- /dev/null +++ b/libguile/strports.c @@ -0,0 +1,403 @@ +/* Copyright 1995,1996,1998-2003,2005-2006,2009-2014,2018 + Free Software Foundation, Inc. + + This file is part of Guile. + + Guile 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. + + Guile 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 Guile. If not, see + <https://www.gnu.org/licenses/>. */ + + + + +#ifdef HAVE_CONFIG_H +# include <config.h> +#endif + +#include <stdio.h> +#include <string.h> +#include <unistd.h> + +#include "bytevectors.h" +#include "deprecation.h" +#include "eval.h" +#include "gsubr.h" +#include "keywords.h" +#include "modules.h" +#include "ports.h" +#include "procs.h" +#include "read.h" +#include "srfi-4.h" +#include "strings.h" +#include "symbols.h" +#include "syscalls.h" +#include "threads.h" +#include "variable.h" + +#include "strports.h" + + + + +/* {Ports - string ports} + * + */ + +SCM_SYMBOL (sym_UTF_8, "UTF-8"); + +scm_t_port_type *scm_string_port_type; + +struct string_port { + SCM bytevector; + size_t pos; + size_t len; +}; + +static size_t +string_port_read (SCM port, SCM dst, size_t start, size_t count) +{ + struct string_port *stream = (void *) SCM_STREAM (port); + + if (stream->pos >= stream->len) + return 0; + + if (count > stream->len - stream->pos) + count = stream->len - stream->pos; + + memcpy (SCM_BYTEVECTOR_CONTENTS (dst) + start, + SCM_BYTEVECTOR_CONTENTS (stream->bytevector) + stream->pos, + count); + + stream->pos += count; + return count; +} + +#define MAX(A, B) ((A) >= (B) ? (A) : (B)) + +static size_t +string_port_write (SCM port, SCM src, size_t start, size_t count) +{ + struct string_port *stream = (void *) SCM_STREAM (port); + + if (SCM_BYTEVECTOR_LENGTH (stream->bytevector) < stream->pos + count) + { + SCM new_bv; + size_t new_size; + + new_size = MAX (SCM_BYTEVECTOR_LENGTH (stream->bytevector) * 2, + stream->pos + count); + new_bv = scm_c_make_bytevector (new_size); + memcpy (SCM_BYTEVECTOR_CONTENTS (new_bv), + SCM_BYTEVECTOR_CONTENTS (stream->bytevector), + stream->len); + stream->bytevector = new_bv; + } + + memcpy (SCM_BYTEVECTOR_CONTENTS (stream->bytevector) + stream->pos, + SCM_BYTEVECTOR_CONTENTS (src) + start, + count); + stream->pos += count; + if (stream->pos > stream->len) + stream->len = stream->pos; + + return count; +} + +static scm_t_off +string_port_seek (SCM port, scm_t_off offset, int whence) +#define FUNC_NAME "string_port_seek" +{ + struct string_port *stream = (void *) SCM_STREAM (port); + scm_t_off target; + + if (whence == SEEK_CUR) + target = offset + stream->pos; + else if (whence == SEEK_SET) + target = offset; + else if (whence == SEEK_END) + target = offset + stream->len; + else + scm_wrong_type_arg_msg (FUNC_NAME, 0, port, "invalid `seek' parameter"); + + if (target >= 0 && target <= stream->len) + stream->pos = target; + else + scm_out_of_range (FUNC_NAME, scm_from_long (offset)); + + return target; +} +#undef FUNC_NAME + +static void +string_port_truncate (SCM port, scm_t_off length) +#define FUNC_NAME "string_port_truncate" +{ + struct string_port *stream = (void *) SCM_STREAM (port); + + if (0 <= length && stream->pos <= length && length <= stream->len) + stream->len = length; + else + scm_out_of_range (FUNC_NAME, scm_from_off_t_or_off64_t (length)); +} +#undef FUNC_NAME + + +/* The initial size in bytes of a string port's buffer. */ +#define INITIAL_BUFFER_SIZE 128 + +/* Return a new string port with MODES. If STR is #f, a new backing + buffer is allocated; otherwise STR must be a string and a copy of it + serves as the buffer for the new port. */ +SCM +scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) +{ + SCM buf; + size_t len, byte_pos; + struct string_port *stream; + + if (!((modes & SCM_WRTNG) || (modes & SCM_RDNG))) + scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL); + + if (scm_is_false (str)) + { + /* Allocate a new buffer to write to. */ + buf = scm_c_make_bytevector (INITIAL_BUFFER_SIZE); + len = byte_pos = 0; + } + else + { + SCM_ASSERT (scm_is_string (str), str, SCM_ARG1, caller); + + buf = scm_string_to_utf8 (str); + len = scm_c_bytevector_length (buf); + + if (scm_is_eq (pos, SCM_INUM0)) + byte_pos = 0; + else + /* Inefficient but simple way to convert the character position + POS into a byte position BYTE_POS. */ + free (scm_to_utf8_stringn (scm_substring (str, SCM_INUM0, pos), + &byte_pos)); + } + + stream = scm_gc_typed_calloc (struct string_port); + stream->bytevector = buf; + stream->pos = byte_pos; + stream->len = len; + + return + scm_c_make_port_with_encoding (scm_string_port_type, modes, sym_UTF_8, + scm_i_default_port_conversion_strategy (), + (scm_t_bits) stream); +} + +/* Create a new string from the buffer of PORT, a string port, converting from + PORT's encoding to the standard string representation. */ +SCM +scm_strport_to_string (SCM port) +{ + signed char *ptr; + struct string_port *stream = (void *) SCM_STREAM (port); + + scm_flush (port); + + if (stream->len == 0) + return scm_nullstr; + + ptr = SCM_BYTEVECTOR_CONTENTS (stream->bytevector); + return scm_from_port_stringn ((char *) ptr, stream->len, port); +} + +SCM_DEFINE (scm_object_to_string, "object->string", 1, 1, 0, + (SCM obj, SCM printer), + "Return a Scheme string obtained by printing @var{obj}.\n" + "Printing function can be specified by the optional second\n" + "argument @var{printer} (default: @code{write}).") +#define FUNC_NAME s_scm_object_to_string +{ + SCM port, result; + + if (!SCM_UNBNDP (printer)) + SCM_VALIDATE_PROC (2, printer); + + port = scm_mkstrport (SCM_INUM0, SCM_BOOL_F, SCM_WRTNG, FUNC_NAME); + + if (SCM_UNBNDP (printer)) + scm_write (obj, port); + else + scm_call_2 (printer, obj, port); + + result = scm_strport_to_string (port); + + /* Explicitly close PORT so that the iconv CDs associated with it are + deallocated right away. This is important because CDs use a lot of + memory that's not visible to the GC, so not freeing them can lead + to almost large heap usage. See + <http://wingolog.org/archives/2011/02/25/ports-weaks-gc-and-dark-matter> + for details. */ + scm_close_port (port); + + return result; +} +#undef FUNC_NAME + +SCM +scm_call_with_output_string (SCM proc) +{ + static SCM var = SCM_BOOL_F; + + if (scm_is_false (var)) + var = scm_c_private_lookup ("guile", "call-with-output-string"); + + return scm_call_1 (scm_variable_ref (var), proc); +} + +SCM +scm_call_with_input_string (SCM string, SCM proc) +{ + static SCM var = SCM_BOOL_F; + + if (scm_is_false (var)) + var = scm_c_private_lookup ("guile", "call-with-input-string"); + + return scm_call_2 (scm_variable_ref (var), string, proc); +} + +SCM_DEFINE (scm_open_input_string, "open-input-string", 1, 0, 0, + (SCM str), + "Take a string and return an input port that delivers characters\n" + "from the string. The port can be closed by\n" + "@code{close-input-port}, though its storage will be reclaimed\n" + "by the garbage collector if it becomes inaccessible.") +#define FUNC_NAME s_scm_open_input_string +{ + return scm_mkstrport (SCM_INUM0, str, SCM_RDNG, FUNC_NAME); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_open_output_string, "open-output-string", 0, 0, 0, + (void), + "Return an output port that will accumulate characters for\n" + "retrieval by @code{get-output-string}. The port can be closed\n" + "by the procedure @code{close-output-port}, though its storage\n" + "will be reclaimed by the garbage collector if it becomes\n" + "inaccessible.") +#define FUNC_NAME s_scm_open_output_string +{ + return scm_mkstrport (SCM_INUM0, SCM_BOOL_F, SCM_WRTNG, FUNC_NAME); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_get_output_string, "get-output-string", 1, 0, 0, + (SCM port), + "Given an output port created by @code{open-output-string},\n" + "return a string consisting of the characters that have been\n" + "output to the port so far.") +#define FUNC_NAME s_scm_get_output_string +{ + SCM_VALIDATE_OPOUTSTRPORT (1, port); + return scm_strport_to_string (port); +} +#undef FUNC_NAME + + +/* Given a null-terminated string EXPR containing a Scheme expression + read it, and return it as an SCM value. */ +SCM +scm_c_read_string (const char *expr) +{ + SCM port, form; + + port = scm_mkstrport (SCM_INUM0, scm_from_locale_string (expr), + SCM_RDNG, "scm_c_read_string"); + form = scm_read (port); + scm_close_port (port); + + return form; +} + +/* Given a null-terminated string EXPR containing Scheme program text, + evaluate it, and return the result of the last expression evaluated. */ +SCM +scm_c_eval_string (const char *expr) +{ + return scm_eval_string (scm_from_locale_string (expr)); +} + +SCM +scm_c_eval_string_in_module (const char *expr, SCM module) +{ + return scm_eval_string_in_module (scm_from_locale_string (expr), module); +} + + +static SCM eval_string_var; +static SCM k_module; + +static void +init_eval_string_var_and_k_module (void) +{ + eval_string_var = scm_c_public_variable ("ice-9 eval-string", "eval-string"); + k_module = scm_from_locale_keyword ("module"); +} + +SCM_DEFINE (scm_eval_string_in_module, "eval-string", 1, 1, 0, + (SCM string, SCM module), + "Evaluate @var{string} as the text representation of a Scheme\n" + "form or forms, and return whatever value they produce.\n" + "Evaluation takes place in the given module, or the current\n" + "module when no module is given.\n" + "While the code is evaluated, the given module is made the\n" + "current one. The current module is restored when this\n" + "procedure returns.") +#define FUNC_NAME s_scm_eval_string_in_module +{ + static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT; + scm_i_pthread_once (&once, init_eval_string_var_and_k_module); + + if (SCM_UNBNDP (module)) + module = scm_current_module (); + else + SCM_VALIDATE_MODULE (2, module); + + return scm_call_3 (scm_variable_ref (eval_string_var), + string, k_module, module); +} +#undef FUNC_NAME + +SCM +scm_eval_string (SCM string) +{ + return scm_eval_string_in_module (string, SCM_UNDEFINED); +} + +static scm_t_port_type * +scm_make_string_port_type () +{ + scm_t_port_type *ptob = scm_make_port_type ("string", + string_port_read, + string_port_write); + scm_set_port_seek (ptob, string_port_seek); + scm_set_port_truncate (ptob, string_port_truncate); + + return ptob; +} + +void +scm_init_strports () +{ + scm_string_port_type = scm_make_string_port_type (); + +#include "strports.x" +} + |