123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417 |
- /* Copyright 1995,1996,1998-2003,2005-2006,2009-2014,2016-2019
- 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 <intprops.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)
- #define FUNC_NAME "string_port_write"
- {
- struct string_port *stream = (void *) SCM_STREAM (port);
- size_t old_size = SCM_BYTEVECTOR_LENGTH (stream->bytevector);
- if (count > old_size - stream->pos)
- {
- SCM new_bv;
- size_t new_size;
- if (INT_ADD_OVERFLOW (stream->pos, count))
- scm_num_overflow (FUNC_NAME);
- /* If (old_size * 2) overflows, it's harmless. */
- new_size = MAX (old_size * 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;
- }
- #undef FUNC_NAME
- 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);
- size_t base;
- scm_t_off target;
- if (whence == SEEK_CUR)
- base = stream->pos;
- else if (whence == SEEK_SET)
- base = 0;
- else if (whence == SEEK_END)
- base = stream->len;
- else
- scm_wrong_type_arg_msg (FUNC_NAME, 0, port, "invalid `seek' parameter");
- if (base > SCM_T_OFF_MAX
- || INT_ADD_OVERFLOW ((scm_t_off) base, offset))
- scm_num_overflow (FUNC_NAME);
- target = (scm_t_off) base + offset;
- if (target >= 0 && target <= stream->len)
- stream->pos = target;
- else
- scm_out_of_range (FUNC_NAME, scm_from_off_t (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 (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. */
- byte_pos = scm_c_string_utf8_length
- (scm_substring (str, SCM_INUM0, 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_utf8_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"
- }
|