mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
416 lines
11 KiB
C
416 lines
11 KiB
C
/* 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"
|
||
}
|
||
|