guile-3.0.7/libguile/strports.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"
}