code:
/*	Copyright (C) 1995, 1996, 1999, 2000, 2004, 2006, 2008 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 2.1 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 <config.h>
#endif

#include "libguile/_scm.h"
#include "libguile/chars.h"
#include "libguile/strings.h"
#include "libguile/symbols.h"

#include "libguile/validate.h"
#include "libguile/strorder.h"
#include "libguile/srfi-13.h"

SCM_C_INLINE_KEYWORD static SCM
srfi13_cmp (SCM s1, SCM s2, SCM (*cmp) (SCM, SCM, SCM, SCM, SCM, SCM))
{
  if (scm_is_true (cmp (s1, s2,
			SCM_UNDEFINED, SCM_UNDEFINED,
			SCM_UNDEFINED, SCM_UNDEFINED)))
    return SCM_BOOL_T;
  else
    return SCM_BOOL_F;
}

SCM_DEFINE1 (scm_string_equal_p, "string=?", scm_tc7_rpsubr,
             (SCM s1, SCM s2),
	    "Lexicographic equality predicate; return @code{#t} if the two\n"
	    "strings are the same length and contain the same characters in\n"
	    "the same positions, otherwise return @code{#f}.\n"
	    "\n"
	    "The procedure @code{string-ci=?} treats upper and lower case\n"
	    "letters as though they were the same character, but\n"
	    "@code{string=?} treats upper and lower case as distinct\n"
	    "characters.")
#define FUNC_NAME s_scm_string_equal_p
{
  return srfi13_cmp (s1, s2, scm_string_eq);
}
#undef FUNC_NAME

SCM_DEFINE1 (scm_string_ci_equal_p, "string-ci=?", scm_tc7_rpsubr,
             (SCM s1, SCM s2),
	    "Case-insensitive string equality predicate; return @code{#t} if\n"
	    "the two strings are the same length and their component\n"
	    "characters match (ignoring case) at each position; otherwise\n"
	    "return @code{#f}.")
#define FUNC_NAME s_scm_string_ci_equal_p
{
  return srfi13_cmp (s1, s2, scm_string_ci_eq);
}
#undef FUNC_NAME

SCM_DEFINE1 (scm_string_less_p, "string<?", scm_tc7_rpsubr,
             (SCM s1, SCM s2),
	    "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
	    "is lexicographically less than @var{s2}.")
#define FUNC_NAME s_scm_string_less_p
{
  return srfi13_cmp (s1, s2, scm_string_lt);
}
#undef FUNC_NAME

SCM_DEFINE1 (scm_string_leq_p, "string<=?", scm_tc7_rpsubr,
             (SCM s1, SCM s2),
	    "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
	    "is lexicographically less than or equal to @var{s2}.")
#define FUNC_NAME s_scm_string_leq_p
{
  return srfi13_cmp (s1, s2, scm_string_le);
}
#undef FUNC_NAME

SCM_DEFINE1 (scm_string_gr_p, "string>?", scm_tc7_rpsubr,
             (SCM s1, SCM s2),
	    "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
	    "is lexicographically greater than @var{s2}.")
#define FUNC_NAME s_scm_string_gr_p
{
  return srfi13_cmp (s1, s2, scm_string_gt);
}
#undef FUNC_NAME

SCM_DEFINE1 (scm_string_geq_p, "string>=?", scm_tc7_rpsubr,
             (SCM s1, SCM s2),
	    "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
	    "is lexicographically greater than or equal to @var{s2}.")
#define FUNC_NAME s_scm_string_geq_p
{
  return srfi13_cmp (s1, s2, scm_string_ge);
}
#undef FUNC_NAME

SCM_DEFINE1 (scm_string_ci_less_p, "string-ci<?", scm_tc7_rpsubr,
             (SCM s1, SCM s2),
	    "Case insensitive lexicographic ordering predicate; return\n"
	    "@code{#t} if @var{s1} is lexicographically less than @var{s2}\n"
	    "regardless of case.")
#define FUNC_NAME s_scm_string_ci_less_p
{
  return srfi13_cmp (s1, s2, scm_string_ci_lt);
}
#undef FUNC_NAME

SCM_DEFINE1 (scm_string_ci_leq_p, "string-ci<=?", scm_tc7_rpsubr,
             (SCM s1, SCM s2),
	    "Case insensitive lexicographic ordering predicate; return\n"
	    "@code{#t} if @var{s1} is lexicographically less than or equal\n"
	    "to @var{s2} regardless of case.")
#define FUNC_NAME s_scm_string_ci_leq_p
{
  return srfi13_cmp (s1, s2, scm_string_ci_le);
}
#undef FUNC_NAME

SCM_DEFINE1 (scm_string_ci_gr_p, "string-ci>?", scm_tc7_rpsubr,
             (SCM s1, SCM s2),
	    "Case insensitive lexicographic ordering predicate; return\n"
	    "@code{#t} if @var{s1} is lexicographically greater than\n"
	    "@var{s2} regardless of case.")
#define FUNC_NAME s_scm_string_ci_gr_p
{
  return srfi13_cmp (s1, s2, scm_string_ci_gt);
}
#undef FUNC_NAME

SCM_DEFINE1 (scm_string_ci_geq_p, "string-ci>=?", scm_tc7_rpsubr,
             (SCM s1, SCM s2),
	    "Case insensitive lexicographic ordering predicate; return\n"
	    "@code{#t} if @var{s1} is lexicographically greater than or\n"
	    "equal to @var{s2} regardless of case.")
#define FUNC_NAME s_scm_string_ci_geq_p
{
  return srfi13_cmp (s1, s2, scm_string_ci_ge);
}
#undef FUNC_NAME

void
scm_init_strorder ()
{
#include "libguile/strorder.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_STRORDER_H
#define SCM_STRORDER_H

/* Copyright (C) 1995,1996,2000, 2006 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 2.1 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"

SCM_API SCM scm_string_equal_p (SCM s1, SCM s2);
SCM_API SCM scm_string_ci_equal_p (SCM s1, SCM s2);
SCM_API SCM scm_string_less_p (SCM s1, SCM s2);
SCM_API SCM scm_string_leq_p (SCM s1, SCM s2);
SCM_API SCM scm_string_gr_p (SCM s1, SCM s2);
SCM_API SCM scm_string_geq_p (SCM s1, SCM s2);
SCM_API SCM scm_string_ci_less_p (SCM s1, SCM s2);
SCM_API SCM scm_string_ci_leq_p (SCM s1, SCM s2);
SCM_API SCM scm_string_ci_gr_p (SCM s1, SCM s2);
SCM_API SCM scm_string_ci_geq_p (SCM s1, SCM s2);
SCM_API void scm_init_strorder (void);

#endif  /* SCM_STRORDER_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/

license: unknown


code:
/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2005, 2006 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 2.1 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 <config.h>
#endif

#include "libguile/_scm.h"

#include <stdio.h>
#ifdef HAVE_UNISTD_H
#include <unistd.h>
#endif

#include "libguile/unif.h"
#include "libguile/eval.h"
#include "libguile/ports.h"
#include "libguile/read.h"
#include "libguile/root.h"
#include "libguile/strings.h"
#include "libguile/modules.h"
#include "libguile/validate.h"
#include "libguile/deprecation.h"

#include "libguile/strports.h"

#ifdef HAVE_STRING_H
#include <string.h>
#endif

/* {Ports - string ports}
 *
 */

/* NOTES:

   We break the rules set forth by strings.h about accessing the
   internals of strings here.  We can do this since we can guarantee
   that the string used as pt->stream is not in use by anyone else.
   Thus, it's representation will not change asynchronously.

   (Ports aren't thread-safe yet anyway...)

   write_buf/write_end point to the ends of the allocated string.
   read_buf/read_end in principle point to the part of the string which
   has been written to, but this is only updated after a flush.
   read_pos and write_pos in principle should be equal, but this is only true
   when rw_active is SCM_PORT_NEITHER.

   ENHANCE-ME - output blocks:

   The current code keeps an output string as a single block.  That means
   when the size is increased the entire old contents must be copied.  It'd
   be more efficient to begin a new block when the old one is full, so
   there's no re-copying of previous data.

   To make seeking efficient, keeping the pieces in a vector might be best,
   though appending is probably the most common operation.  The size of each
   block could be progressively increased, so the bigger the string the
   bigger the blocks.

   When `get-output-string' is called the blocks have to be coalesced into a
   string, the result could be kept as a single big block.  If blocks were
   strings then `get-output-string' could notice when there's just one and
   return that with a copy-on-write (though repeated calls to
   `get-output-string' are probably unlikely).

   Another possibility would be to extend the port mechanism to let SCM
   strings come through directly from `display' and friends.  That way if a
   big string is written it can be kept as a copy-on-write, saving time
   copying and maybe saving some space.  */

scm_t_bits scm_tc16_strport;

static int
stfill_buffer (SCM port)
{
  scm_t_port *pt = SCM_PTAB_ENTRY (port);

  if (pt->read_pos >= pt->read_end)
    return EOF;
  else
    return scm_return_first_int (*pt->read_pos, port);
}

/* change the size of a port's string to new_size.  this doesn't
   change read_buf_size.  */
static void
st_resize_port (scm_t_port *pt, off_t new_size)
{
  SCM old_stream = SCM_PACK (pt->stream);
  const char *src = scm_i_string_chars (old_stream);
  char *dst;
  SCM new_stream = scm_i_make_string (new_size, &dst);
  unsigned long int old_size = scm_i_string_length (old_stream);
  unsigned long int min_size = min (old_size, new_size);
  unsigned long int i;

  off_t index = pt->write_pos - pt->write_buf;

  pt->write_buf_size = new_size;

  for (i = 0; i != min_size; ++i)
    dst[i] = src[i];

  scm_remember_upto_here_1 (old_stream);

  /* reset buffer. */
  {
    pt->stream = SCM_UNPACK (new_stream);
    pt->read_buf = pt->write_buf = (unsigned char *)dst;
    pt->read_pos = pt->write_pos = pt->write_buf + index;
    pt->write_end = pt->write_buf + pt->write_buf_size;
    pt->read_end = pt->read_buf + pt->read_buf_size;
  }
}

/* amount by which write_buf is expanded.  */
#define SCM_WRITE_BLOCK 80

/* ensure that write_pos < write_end by enlarging the buffer when
   necessary.  update read_buf to account for written chars.

   The buffer is enlarged by 1.5 times, plus SCM_WRITE_BLOCK.  Adding just a
   fixed amount is no good, because there's a block copy for each increment,
   and that copying would take quadratic time.  In the past it was found to
   be very slow just adding 80 bytes each time (eg. about 10 seconds for
   writing a 100kbyte string).  */

static void
st_flush (SCM port)
{
  scm_t_port *pt = SCM_PTAB_ENTRY (port);

  if (pt->write_pos == pt->write_end)
    {
      st_resize_port (pt, pt->write_buf_size * 3 / 2 + SCM_WRITE_BLOCK);
    }
  pt->read_pos = pt->write_pos;
  if (pt->read_pos > pt->read_end)
    {
      pt->read_end = (unsigned char *) pt->read_pos;
      pt->read_buf_size = pt->read_end - pt->read_buf;
    }
  pt->rw_active = SCM_PORT_NEITHER;
}

static void
st_write (SCM port, const void *data, size_t size)
{
  scm_t_port *pt = SCM_PTAB_ENTRY (port);
  const char *input = (char *) data;

  while (size > 0)
    {
      int space = pt->write_end - pt->write_pos;
      int write_len = (size > space) ? space : size;

      memcpy ((char *) pt->write_pos, input, write_len);
      pt->write_pos += write_len;
      size -= write_len;
      input += write_len;
      if (write_len == space)
	st_flush (port);
    }
}

static void
st_end_input (SCM port, int offset)
{
  scm_t_port *pt = SCM_PTAB_ENTRY (port);

  if (pt->read_pos - pt->read_buf < offset)
    scm_misc_error ("st_end_input", "negative position", SCM_EOL);

  pt->write_pos = (unsigned char *) (pt->read_pos = pt->read_pos - offset);
  pt->rw_active = SCM_PORT_NEITHER;
}

static off_t
st_seek (SCM port, off_t offset, int whence)
{
  scm_t_port *pt = SCM_PTAB_ENTRY (port);
  off_t target;

  if (pt->rw_active == SCM_PORT_READ && offset == 0 && whence == SEEK_CUR)
    /* special case to avoid disturbing the unread-char buffer.  */
    {
      if (pt->read_buf == pt->putback_buf)
	{
	  target = pt->saved_read_pos - pt->saved_read_buf
	    - (pt->read_end - pt->read_pos);
	}
      else
	{
	  target = pt->read_pos - pt->read_buf;
	}
    }
  else
    /* all other cases.  */
    {
      if (pt->rw_active == SCM_PORT_WRITE)
	st_flush (port);

      if (pt->rw_active == SCM_PORT_READ)
	scm_end_input (port);

      switch (whence)
	{
	case SEEK_CUR:
	  target = pt->read_pos - pt->read_buf + offset;
	  break;
	case SEEK_END:
	  target = pt->read_end - pt->read_buf + offset;
	  break;
	default: /* SEEK_SET */
	  target = offset;
	  break;
	}

      if (target < 0)
	scm_misc_error ("st_seek", "negative offset", SCM_EOL);

      if (target >= pt->write_buf_size)
	{
	  if (!(SCM_CELL_WORD_0 (port) & SCM_WRTNG))
	    {
	      if (target > pt->write_buf_size)
		{
		  scm_misc_error ("st_seek",
				  "seek past end of read-only strport",
				  SCM_EOL);
		}
	    }
	  else
	    {
	      st_resize_port (pt, target + (target == pt->write_buf_size
					    ? SCM_WRITE_BLOCK
					    : 0));
	    }
	}
      pt->read_pos = pt->write_pos = pt->read_buf + target;
      if (pt->read_pos > pt->read_end)
	{
	  pt->read_end = (unsigned char *) pt->read_pos;
	  pt->read_buf_size = pt->read_end - pt->read_buf;
	}
    }
  return target;
}

static void
st_truncate (SCM port, off_t length)
{
  scm_t_port *pt = SCM_PTAB_ENTRY (port);

  if (length > pt->write_buf_size)
    st_resize_port (pt, length);

  pt->read_buf_size = length;
  pt->read_end = pt->read_buf + length;
  if (pt->read_pos > pt->read_end)
    pt->read_pos = pt->read_end;

  if (pt->write_pos > pt->read_end)
    pt->write_pos = pt->read_end;
}

SCM
scm_mkstrport (SCM pos, SCM str, long modes, const char *caller)
{
  SCM z;
  scm_t_port *pt;
  size_t str_len, c_pos;

  SCM_ASSERT (scm_is_string (str), str, SCM_ARG1, caller);

  str_len = scm_i_string_length (str);
  c_pos = scm_to_unsigned_integer (pos, 0, str_len);

  if (!((modes & SCM_WRTNG) || (modes & SCM_RDNG)))
    scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL);

  /* XXX

     Make a new string to isolate us from changes to the original.
     This is done so that we can rely on scm_i_string_chars to stay in
     place even across SCM_TICKs.

     Additionally, when we are going to write to the string, we make a
     copy so that we can write to it without having to use
     scm_i_string_writable_chars.
  */

  if (modes & SCM_WRTNG)
    str = scm_c_substring_copy (str, 0, str_len);
  else
    str = scm_c_substring (str, 0, str_len);

  scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex);
  z = scm_new_port_table_entry (scm_tc16_strport);
  pt = SCM_PTAB_ENTRY(z);
  SCM_SETSTREAM (z, SCM_UNPACK (str));
  SCM_SET_CELL_TYPE(z, scm_tc16_strport|modes);
  /* see above why we can use scm_i_string_chars here. */
  pt->write_buf = pt->read_buf = (unsigned char *) scm_i_string_chars (str);
  pt->read_pos = pt->write_pos = pt->read_buf + c_pos;
  pt->write_buf_size = pt->read_buf_size = str_len;
  pt->write_end = pt->read_end = pt->read_buf + pt->read_buf_size;

  pt->rw_random = 1;

  scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex);

  /* ensure write_pos is writable. */
  if ((modes & SCM_WRTNG) && pt->write_pos == pt->write_end)
    st_flush (z);
  return z;
}

/* create a new string from a string port's buffer.  */
SCM scm_strport_to_string (SCM port)
{
  scm_t_port *pt = SCM_PTAB_ENTRY (port);
  SCM str;
  char *dst;

  if (pt->rw_active == SCM_PORT_WRITE)
    st_flush (port);

  str = scm_i_make_string (pt->read_buf_size, &dst);
  memcpy (dst, (char *) pt->read_buf, pt->read_buf_size);
  scm_remember_upto_here_1 (port);
  return str;
}

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 str, port;

  if (!SCM_UNBNDP (printer))
    SCM_VALIDATE_PROC (2, printer);

  str = scm_c_make_string (0, SCM_UNDEFINED);
  port = scm_mkstrport (SCM_INUM0, str, SCM_OPN | SCM_WRTNG, FUNC_NAME);

  if (SCM_UNBNDP (printer))
    scm_write (obj, port);
  else
    scm_call_2 (printer, obj, port);

  return scm_strport_to_string (port);
}
#undef FUNC_NAME

SCM_DEFINE (scm_call_with_output_string, "call-with-output-string", 1, 0, 0,
           (SCM proc),
	    "Calls the one-argument procedure @var{proc} with a newly created output\n"
	    "port.  When the function returns, the string composed of the characters\n"
	    "written into the port is returned.")
#define FUNC_NAME s_scm_call_with_output_string
{
  SCM p;

  p = scm_mkstrport (SCM_INUM0,
		     scm_make_string (SCM_INUM0, SCM_UNDEFINED),
		     SCM_OPN | SCM_WRTNG,
                     FUNC_NAME);
  scm_call_1 (proc, p);

  return scm_get_output_string (p);
}
#undef FUNC_NAME

SCM_DEFINE (scm_call_with_input_string, "call-with-input-string", 2, 0, 0,
           (SCM string, SCM proc),
	    "Calls the one-argument procedure @var{proc} with a newly\n"
	    "created input port from which @var{string}'s contents may be\n"
	    "read.  The value yielded by the @var{proc} is returned.")
#define FUNC_NAME s_scm_call_with_input_string
{
  SCM p = scm_mkstrport(SCM_INUM0, string, SCM_OPN | SCM_RDNG, FUNC_NAME);
  return scm_call_1 (proc, p);
}
#undef FUNC_NAME

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
{
  SCM p = scm_mkstrport(SCM_INUM0, str, SCM_OPN | SCM_RDNG, FUNC_NAME);
  return p;
}
#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
{
  SCM p;

  p = scm_mkstrport (SCM_INUM0,
		     scm_make_string (SCM_INUM0, SCM_UNDEFINED),
		     SCM_OPN | SCM_WRTNG,
                     FUNC_NAME);
  return p;
}
#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 = scm_mkstrport (SCM_INUM0,
			    scm_from_locale_string (expr),
			    SCM_OPN | SCM_RDNG,
			    "scm_c_read_string");
  SCM form;

  /* Read expressions from that port; ignore the values.  */
  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
inner_eval_string (void *data)
{
  SCM port = (SCM)data;
  SCM form;
  SCM ans = SCM_UNSPECIFIED;

  /* Read expressions from that port; ignore the values.  */
  while (!SCM_EOF_OBJECT_P (form = scm_read (port)))
    ans = scm_primitive_eval_x (form);

  /* Don't close the port here; if we re-enter this function via a
     continuation, then the next time we enter it, we'll get an error.
     It's a string port anyway, so there's no advantage to closing it
     early.  */

  return ans;
}

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
{
  SCM port = scm_mkstrport (SCM_INUM0, string, SCM_OPN | SCM_RDNG,
			    FUNC_NAME);
  if (SCM_UNBNDP (module))
    module = scm_current_module ();
  else
    SCM_VALIDATE_MODULE (2, module);
  return scm_c_call_with_current_module (module,
					 inner_eval_string, (void *)port);
}
#undef FUNC_NAME

SCM
scm_eval_string (SCM string)
{
  return scm_eval_string_in_module (string, SCM_UNDEFINED);
}

static scm_t_bits
scm_make_stptob ()
{
  scm_t_bits tc = scm_make_port_type ("string", stfill_buffer, st_write);

  scm_set_port_mark        (tc, scm_markstream);
  scm_set_port_end_input   (tc, st_end_input);
  scm_set_port_flush       (tc, st_flush);
  scm_set_port_seek        (tc, st_seek);
  scm_set_port_truncate    (tc, st_truncate);

  return tc;
}

void
scm_init_strports ()
{
  scm_tc16_strport = scm_make_stptob ();

#include "libguile/strports.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_STRPORTS_H
#define SCM_STRPORTS_H

/* Copyright (C) 1995,1996,2000,2001,2002, 2006 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 2.1 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"

#define SCM_STRPORTP(x)      (!SCM_IMP (x) && \
                              (SCM_TYP16 (x) == scm_tc16_strport))
#define SCM_OPSTRPORTP(x)    (SCM_STRPORTP (x) && \
                              (SCM_CELL_WORD_0 (x) & SCM_OPN))
#define SCM_OPINSTRPORTP(x)  (SCM_OPSTRPORTP (x) && \
 			      (SCM_CELL_WORD_0 (x) & SCM_RDNG))
#define SCM_OPOUTSTRPORTP(x) (SCM_OPSTRPORTP (x) && \
                              (SCM_CELL_WORD_0 (x) & SCM_WRTNG))

SCM_API scm_t_bits scm_tc16_strport;

SCM_API SCM scm_mkstrport (SCM pos, SCM str, long modes, const char * caller);
SCM_API SCM scm_strport_to_string (SCM port);
SCM_API SCM scm_object_to_string (SCM obj, SCM printer);
SCM_API SCM scm_call_with_output_string (SCM proc);
SCM_API SCM scm_call_with_input_string (SCM str, SCM proc);
SCM_API SCM scm_open_input_string (SCM str);
SCM_API SCM scm_open_output_string (void);
SCM_API SCM scm_get_output_string (SCM port);
SCM_API SCM scm_c_read_string (const char *expr);
SCM_API SCM scm_c_eval_string (const char *expr);
SCM_API SCM scm_c_eval_string_in_module (const char *expr, SCM module);
SCM_API SCM scm_eval_string (SCM string);
SCM_API SCM scm_eval_string_in_module (SCM string, SCM module);
SCM_API void scm_init_strports (void);

#endif  /* SCM_STRPORTS_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007 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 2.1 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 <config.h>
#endif

#include "libguile/_scm.h"
#include "libguile/async.h"
#include "libguile/chars.h"
#include "libguile/eval.h"
#include "libguile/alist.h"
#include "libguile/weaks.h"
#include "libguile/hashtab.h"
#include "libguile/ports.h"
#include "libguile/strings.h"

#include "libguile/validate.h"
#include "libguile/struct.h"

#include "libguile/eq.h"

#ifdef HAVE_STRING_H
#include <string.h>
#endif

static SCM required_vtable_fields = SCM_BOOL_F;
SCM scm_struct_table;

SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
            (SCM fields),
	    "Return a new structure layout object.\n\n"
	    "@var{fields} must be a string made up of pairs of characters\n"
	    "strung together.  The first character of each pair describes a field\n"
	    "type, the second a field protection.  Allowed types are 'p' for\n"
	    "GC-protected Scheme data, 'u' for unprotected binary data, and 's' for\n"
	    "a field that points to the structure itself.    Allowed protections\n"
	    "are 'w' for mutable fields, 'r' for read-only fields, and 'o' for opaque\n"
	    "fields.  The last field protection specification may be capitalized to\n"
	    "indicate that the field is a tail-array.")
#define FUNC_NAME s_scm_make_struct_layout
{
  SCM new_sym;
  SCM_VALIDATE_STRING (1, fields);

  { /* scope */
    const char * field_desc;
    size_t len;
    int x;

    len = scm_i_string_length (fields);
    if (len % 2 == 1)
      SCM_MISC_ERROR ("odd length field specification: ~S",
		      scm_list_1 (fields));

    field_desc = scm_i_string_chars (fields);

    for (x = 0; x < len; x += 2)
      {
	switch (field_desc[x])
	  {
	  case 'u':
	  case 'p':
#if 0
	  case 'i':
	  case 'd':
#endif
	  case 's':
	    break;
	  default:
	    SCM_MISC_ERROR ("unrecognized field type: ~S",
			    scm_list_1 (SCM_MAKE_CHAR (field_desc[x])));
	  }

	switch (field_desc[x + 1])
	  {
	  case 'w':
	    if (field_desc[x] == 's')
	      SCM_MISC_ERROR ("self fields not writable", SCM_EOL);
	  case 'r':
	  case 'o':
	    break;
	  case 'R':
	  case 'W':
	  case 'O':
	    if (field_desc[x] == 's')
	      SCM_MISC_ERROR ("self fields not allowed in tail array",
			      SCM_EOL);
	    if (x != len - 2)
	      SCM_MISC_ERROR ("tail array field must be last field in layout",
			      SCM_EOL);
	    break;
	  default:
	    SCM_MISC_ERROR ("unrecognized ref specification: ~S",
			    scm_list_1 (SCM_MAKE_CHAR (field_desc[x + 1])));
	  }
#if 0
	if (field_desc[x] == 'd')
	  {
	    if (field_desc[x + 2] != '-')
	      SCM_MISC_ERROR ("missing dash field at position ~A",
			      scm_list_1 (scm_from_int (x / 2)));
	    x += 2;
	    goto recheck_ref;
	  }
#endif
      }
    new_sym = scm_string_to_symbol (fields);
  }
  scm_remember_upto_here_1 (fields);
  return new_sym;
}
#undef FUNC_NAME

static void
scm_struct_init (SCM handle, SCM layout, scm_t_bits * mem, int tail_elts, SCM inits)
{
  unsigned const char *fields_desc =
    (unsigned const char *) scm_i_symbol_chars (layout) - 2;
  unsigned char prot = 0;
  int n_fields = scm_i_symbol_length (layout) / 2;
  int tailp = 0;

  while (n_fields)
    {
      if (!tailp)
	{
	  fields_desc += 2;
	  prot = fields_desc[1];
	  if (SCM_LAYOUT_TAILP (prot))
	    {
	      tailp = 1;
	      prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o';
	      *mem++ = tail_elts;
	      n_fields += tail_elts - 1;
	      if (n_fields == 0)
		break;
	    }
	}

      switch (*fields_desc)
	{
#if 0
	case 'i':
	  if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
	    *mem = 0;
	  else
	    {
	      *mem = scm_to_long (SCM_CAR (inits));
	      inits = SCM_CDR (inits);
	    }
	  break;
#endif

	case 'u':
	  if ((prot != 'r' && prot != 'w') || scm_is_null (inits))
	    *mem = 0;
	  else
	    {
	      *mem = scm_to_ulong (SCM_CAR (inits));
	      inits = SCM_CDR (inits);
	    }
	  break;

	case 'p':
	  if ((prot != 'r' && prot != 'w') || scm_is_null (inits))
	    *mem = SCM_UNPACK (SCM_BOOL_F);
	  else
	    {
	      *mem = SCM_UNPACK (SCM_CAR (inits));
	      inits = SCM_CDR (inits);
	    }

	  break;

#if 0
	case 'd':
	  if ((prot != 'r' && prot != 'w') || inits == SCM_EOL)
	    *((double *)mem) = 0.0;
	  else
	    {
	      *mem = scm_num2dbl (SCM_CAR (inits), "scm_struct_init");
	      inits = SCM_CDR (inits);
	    }
	  fields_desc += 2;
	  break;
#endif

	case 's':
	  *mem = SCM_UNPACK (handle);
	  break;
	}

      n_fields--;
      mem++;
    }
}

SCM_DEFINE (scm_struct_p, "struct?", 1, 0, 0,
            (SCM x),
	    "Return @code{#t} iff @var{x} is a structure object, else\n"
	    "@code{#f}.")
#define FUNC_NAME s_scm_struct_p
{
  return scm_from_bool(SCM_STRUCTP (x));
}
#undef FUNC_NAME

SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0,
            (SCM x),
	    "Return @code{#t} iff @var{x} is a vtable structure.")
#define FUNC_NAME s_scm_struct_vtable_p
{
  SCM layout;
  scm_t_bits * mem;
  int tmp;

  if (!SCM_STRUCTP (x))
    return SCM_BOOL_F;

  layout = SCM_STRUCT_LAYOUT (x);

  if (scm_i_symbol_length (layout)
      < scm_i_string_length (required_vtable_fields))
    return SCM_BOOL_F;

  tmp = strncmp (scm_i_symbol_chars (layout),
		 scm_i_string_chars (required_vtable_fields),
		 scm_i_string_length (required_vtable_fields));
  scm_remember_upto_here_1 (required_vtable_fields);
  if (tmp)
    return SCM_BOOL_F;

  mem = SCM_STRUCT_DATA (x);

  return scm_from_bool (scm_is_symbol (SCM_PACK (mem[scm_vtable_index_layout])));
}
#undef FUNC_NAME

/* All struct data must be allocated at an address whose bottom three
   bits are zero.  This is because the tag for a struct lives in the
   bottom three bits of the struct's car, and the upper bits point to
   the data of its vtable, which is a struct itself.  Thus, if the
   address of that data doesn't end in three zeros, tagging it will
   destroy the pointer.

   This function allocates a block of memory, and returns a pointer at
   least scm_struct_n_extra_words words into the block.  Furthermore,
   it guarantees that that pointer's least three significant bits are
   all zero.

   The argument n_words should be the number of words that should
   appear after the returned address.  (That is, it shouldn't include
   scm_struct_n_extra_words.)

   This function initializes the following fields of the struct:

     scm_struct_i_ptr --- the actual start of the block of memory; the
	 address you should pass to 'free' to dispose of the block.
	 This field allows us to both guarantee that the returned
	 address is divisible by eight, and allow the GC to free the
	 block.

     scm_struct_i_n_words --- the number of words allocated to the
         block, including the extra fields.  This is used by the GC.

     Ugh.  */

scm_t_bits *
scm_alloc_struct (int n_words, int n_extra, const char *what)
{
  int size = sizeof (scm_t_bits) * (n_words + n_extra) + 7;
  void * block = scm_gc_malloc (size, what);

  /* Adjust the pointer to hide the extra words.  */
  scm_t_bits * p = (scm_t_bits *) block + n_extra;

  /* Adjust it even further so it's aligned on an eight-byte boundary.  */
  p = (scm_t_bits *) (((scm_t_bits) p + 7) & ~7);

  /* Initialize a few fields as described above.  */
  p[scm_struct_i_free] = (scm_t_bits) scm_struct_free_standard;
  p[scm_struct_i_ptr] = (scm_t_bits) block;
  p[scm_struct_i_n_words] = n_words;
  p[scm_struct_i_flags] = 0;

  return p;
}

void
scm_struct_free_0 (scm_t_bits * vtable SCM_UNUSED,
		   scm_t_bits * data SCM_UNUSED)
{
}

void
scm_struct_free_light (scm_t_bits * vtable, scm_t_bits * data)
{
  size_t n = vtable [scm_struct_i_size] & ~SCM_STRUCTF_MASK;
  scm_gc_free (data, n, "struct");
}

void
scm_struct_free_standard (scm_t_bits * vtable SCM_UNUSED, scm_t_bits * data)
{
  size_t n = (data[scm_struct_i_n_words] + scm_struct_n_extra_words)
	     * sizeof (scm_t_bits) + 7;
  scm_gc_free ((void *) data[scm_struct_i_ptr], n, "heavy struct");
}

void
scm_struct_free_entity (scm_t_bits * vtable SCM_UNUSED, scm_t_bits * data)
{
  size_t n = (data[scm_struct_i_n_words] + scm_struct_entity_n_extra_words)
	     * sizeof (scm_t_bits) + 7;
  scm_gc_free ((void *) data[scm_struct_i_ptr], n, "entity struct");
}

static void *
scm_struct_gc_init (void *dummy1 SCM_UNUSED,
		    void *dummy2 SCM_UNUSED,
		    void *dummy3 SCM_UNUSED)
{
  scm_i_structs_to_free = SCM_EOL;
  return 0;
}

static void *
scm_free_structs (void *dummy1 SCM_UNUSED,
		  void *dummy2 SCM_UNUSED,
		  void *dummy3 SCM_UNUSED)
{
  SCM newchain = scm_i_structs_to_free;
  do
    {
      /* Mark vtables in GC chain.  GC mark set means delay freeing. */
      SCM chain = newchain;
      while (!scm_is_null (chain))
	{
	  SCM vtable = SCM_STRUCT_VTABLE (chain);
	  if (SCM_STRUCT_GC_CHAIN (vtable) != 0 && vtable != chain)
	    SCM_SET_GC_MARK (vtable);
	  chain = SCM_STRUCT_GC_CHAIN (chain);
	}
      /* Free unmarked structs.  */
      chain = newchain;
      newchain = SCM_EOL;
      while (!scm_is_null (chain))
	{
	  SCM obj = chain;
	  chain = SCM_STRUCT_GC_CHAIN (chain);
	  if (SCM_GC_MARK_P (obj))
	    {
	      SCM_CLEAR_GC_MARK (obj);
	      SCM_SET_STRUCT_GC_CHAIN (obj, newchain);
	      newchain = obj;
	    }
	  else
	    {
	      scm_t_bits * vtable_data = SCM_STRUCT_VTABLE_DATA (obj);
	      scm_t_bits * data = SCM_STRUCT_DATA (obj);
	      scm_t_struct_free free_struct_data
		= ((scm_t_struct_free) vtable_data[scm_struct_i_free]);
	      SCM_SET_CELL_TYPE (obj, scm_tc_free_cell);
	      free_struct_data (vtable_data, data);
	    }
	}
    }
  while (!scm_is_null (newchain));
  return 0;
}

SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
            (SCM vtable, SCM tail_array_size, SCM init),
	    "Create a new structure.\n\n"
	    "@var{type} must be a vtable structure (@pxref{Vtables}).\n\n"
	    "@var{tail-elts} must be a non-negative integer.  If the layout\n"
	    "specification indicated by @var{type} includes a tail-array,\n"
	    "this is the number of elements allocated to that array.\n\n"
	    "The @var{init1}, @dots{} are optional arguments describing how\n"
	    "successive fields of the structure should be initialized.  Only fields\n"
	    "with protection 'r' or 'w' can be initialized, except for fields of\n"
	    "type 's', which are automatically initialized to point to the new\n"
	    "structure itself; fields with protection 'o' can not be initialized by\n"
	    "Scheme programs.\n\n"
	    "If fewer optional arguments than initializable fields are supplied,\n"
	    "fields of type 'p' get default value #f while fields of type 'u' are\n"
	    "initialized to 0.\n\n"
	    "Structs are currently the basic representation for record-like data\n"
	    "structures in Guile.  The plan is to eventually replace them with a\n"
	    "new representation which will at the same time be easier to use and\n"
	    "more powerful.\n\n"
	    "For more information, see the documentation for @code{make-vtable-vtable}.")
#define FUNC_NAME s_scm_make_struct
{
  SCM layout;
  size_t basic_size;
  size_t tail_elts;
  scm_t_bits * data;
  SCM handle;

  SCM_VALIDATE_VTABLE (1, vtable);
  SCM_VALIDATE_REST_ARGUMENT (init);

  layout = SCM_PACK (SCM_STRUCT_DATA (vtable) [scm_vtable_index_layout]);
  basic_size = scm_i_symbol_length (layout) / 2;
  tail_elts = scm_to_size_t (tail_array_size);

  /* A tail array is only allowed if the layout fields string ends in "R",
     "W" or "O". */
  if (tail_elts != 0)
    {
      SCM layout_str, last_char;

      if (basic_size == 0)
        {
        bad_tail:
          SCM_MISC_ERROR ("tail array not allowed unless layout ends R, W, or O", SCM_EOL);
        }

      layout_str = scm_symbol_to_string (layout);
      last_char = scm_string_ref (layout_str,
                                  scm_from_size_t (2 * basic_size - 1));
      if (! SCM_LAYOUT_TAILP (SCM_CHAR (last_char)))
        goto bad_tail;
    }

  /* In guile 1.8.5 and earlier, everything below was covered by a
     CRITICAL_SECTION lock.  This can lead to deadlocks in garbage
     collection, since other threads might be holding the heap_mutex, while
     sleeping on the CRITICAL_SECTION lock.  There does not seem to be any
     need for a lock on the section below, as it does not access or update
     any globals, so the critical section has been removed. */

  if (SCM_STRUCT_DATA (vtable)[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
    {
      data = scm_alloc_struct (basic_size + tail_elts,
			       scm_struct_entity_n_extra_words,
			       "entity struct");
      data[scm_struct_i_procedure] = SCM_UNPACK (SCM_BOOL_F);
      data[scm_struct_i_setter] = SCM_UNPACK (SCM_BOOL_F);
    }
  else
    data = scm_alloc_struct (basic_size + tail_elts,
			     scm_struct_n_extra_words,
			     "struct");
  handle = scm_double_cell ((((scm_t_bits) SCM_STRUCT_DATA (vtable))
			     + scm_tc3_struct),
			    (scm_t_bits) data, 0, 0);

  scm_struct_init (handle, layout, data, tail_elts, init);

  return handle;
}
#undef FUNC_NAME

SCM_DEFINE (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1,
            (SCM user_fields, SCM tail_array_size, SCM init),
	    "Return a new, self-describing vtable structure.\n\n"
	    "@var{user-fields} is a string describing user defined fields of the\n"
	    "vtable beginning at index @code{vtable-offset-user}\n"
	    "(see @code{make-struct-layout}).\n\n"
	    "@var{tail-size} specifies the size of the tail-array (if any) of\n"
	    "this vtable.\n\n"
	    "@var{init1}, @dots{} are the optional initializers for the fields of\n"
	    "the vtable.\n\n"
	    "Vtables have one initializable system field---the struct printer.\n"
	    "This field comes before the user fields in the initializers passed\n"
	    "to @code{make-vtable-vtable} and @code{make-struct}, and thus works as\n"
	    "a third optional argument to @code{make-vtable-vtable} and a fourth to\n"
	    "@code{make-struct} when creating vtables:\n\n"
	    "If the value is a procedure, it will be called instead of the standard\n"
	    "printer whenever a struct described by this vtable is printed.\n"
	    "The procedure will be called with arguments STRUCT and PORT.\n\n"
	    "The structure of a struct is described by a vtable, so the vtable is\n"
	    "in essence the type of the struct.  The vtable is itself a struct with\n"
	    "a vtable.  This could go on forever if it weren't for the\n"
	    "vtable-vtables which are self-describing vtables, and thus terminate\n"
	    "the chain.\n\n"
	    "There are several potential ways of using structs, but the standard\n"
	    "one is to use three kinds of structs, together building up a type\n"
	    "sub-system: one vtable-vtable working as the root and one or several\n"
	    "\"types\", each with a set of \"instances\".  (The vtable-vtable should be\n"
	    "compared to the class <class> which is the class of itself.)\n\n"
	    "@lisp\n"
	    "(define ball-root (make-vtable-vtable \"pr\" 0))\n\n"
	    "(define (make-ball-type ball-color)\n"
	    "  (make-struct ball-root 0\n"
	    "	       (make-struct-layout \"pw\")\n"
	    "               (lambda (ball port)\n"
	    "                 (format port \"#<a ~A ball owned by ~A>\"\n"
	    "                         (color ball)\n"
	    "                         (owner ball)))\n"
	    "               ball-color))\n"
	    "(define (color ball) (struct-ref (struct-vtable ball) vtable-offset-user))\n"
	    "(define (owner ball) (struct-ref ball 0))\n\n"
	    "(define red (make-ball-type 'red))\n"
	    "(define green (make-ball-type 'green))\n\n"
	    "(define (make-ball type owner) (make-struct type 0 owner))\n\n"
	    "(define ball (make-ball green 'Nisse))\n"
	    "ball @result{} #<a green ball owned by Nisse>\n"
	    "@end lisp")
#define FUNC_NAME s_scm_make_vtable_vtable
{
  SCM fields;
  SCM layout;
  size_t basic_size;
  size_t tail_elts;
  scm_t_bits *data;
  SCM handle;

  SCM_VALIDATE_STRING (1, user_fields);
  SCM_VALIDATE_REST_ARGUMENT (init);

  fields = scm_string_append (scm_list_2 (required_vtable_fields,
					  user_fields));
  layout = scm_make_struct_layout (fields);
  basic_size = scm_i_symbol_length (layout) / 2;
  tail_elts = scm_to_size_t (tail_array_size);
  SCM_CRITICAL_SECTION_START;
  data = scm_alloc_struct (basic_size + tail_elts,
			   scm_struct_n_extra_words,
			   "struct");
  handle = scm_double_cell ((scm_t_bits) data + scm_tc3_struct,
			    (scm_t_bits) data, 0, 0);
  data [scm_vtable_index_layout] = SCM_UNPACK (layout);
  scm_struct_init (handle, layout, data, tail_elts, scm_cons (layout, init));
  SCM_CRITICAL_SECTION_END;
  return handle;
}
#undef FUNC_NAME

static SCM scm_i_vtable_vtable_no_extra_fields;

SCM_DEFINE (scm_make_vtable, "make-vtable", 1, 1, 0,
            (SCM fields, SCM printer),
	    "Create a vtable, for creating structures with the given\n"
	    "@var{fields}.\n"
	    "\n"
	    "The optional @var{printer} argument is a function to be called\n"
	    "@code{(@var{printer} struct port)} on the structures created.\n"
	    "It should look at @var{struct} and write to @var{port}.")
#define FUNC_NAME s_scm_make_vtable
{
  if (SCM_UNBNDP (printer))
    printer = SCM_BOOL_F;

  return scm_make_struct (scm_i_vtable_vtable_no_extra_fields, SCM_INUM0,
                          scm_list_2 (scm_make_struct_layout (fields),
                                      printer));
}
#undef FUNC_NAME

/* Return true if S1 and S2 are equal structures, i.e., if their vtable and
   contents are the same.  Field protections are honored.  Thus, it is an
   error to test the equality of structures that contain opaque fields.  */
SCM
scm_i_struct_equalp (SCM s1, SCM s2)
#define FUNC_NAME "scm_i_struct_equalp"
{
  SCM vtable1, vtable2, layout;
  size_t struct_size, field_num;

  SCM_VALIDATE_STRUCT (1, s1);
  SCM_VALIDATE_STRUCT (2, s2);

  vtable1 = SCM_STRUCT_VTABLE (s1);
  vtable2 = SCM_STRUCT_VTABLE (s2);

  if (!scm_is_eq (vtable1, vtable2))
    return SCM_BOOL_F;

  layout = SCM_STRUCT_LAYOUT (s1);
  struct_size = scm_i_symbol_length (layout) / 2;

  for (field_num = 0; field_num < struct_size; field_num++)
    {
      SCM s_field_num;
      SCM field1, field2;

      /* We have to use `scm_struct_ref ()' here so that fields are accessed
	 consistently, notably wrt. field types and access rights.  */
      s_field_num = scm_from_size_t (field_num);
      field1 = scm_struct_ref (s1, s_field_num);
      field2 = scm_struct_ref (s2, s_field_num);

      /* Self-referencing fields (type `s') must be skipped to avoid infinite
	 recursion.  */
      if (!(scm_is_eq (field1, s1) && (scm_is_eq (field2, s2))))
	if (scm_is_false (scm_equal_p (field1, field2)))
	  return SCM_BOOL_F;
    }

  /* FIXME: Tail elements should be tested for equality.  */

  return SCM_BOOL_T;
}
#undef FUNC_NAME

SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0,
            (SCM handle, SCM pos),
	    "@deffnx {Scheme Procedure} struct-set! struct n value\n"
	    "Access (or modify) the @var{n}th field of @var{struct}.\n\n"
	    "If the field is of type 'p', then it can be set to an arbitrary value.\n\n"
	    "If the field is of type 'u', then it can only be set to a non-negative\n"
	    "integer value small enough to fit in one machine word.")
#define FUNC_NAME s_scm_struct_ref
{
  SCM answer = SCM_UNDEFINED;
  scm_t_bits * data;
  SCM layout;
  size_t layout_len;
  size_t p;
  scm_t_bits n_fields;
  const char *fields_desc;
  char field_type = 0;

  SCM_VALIDATE_STRUCT (1, handle);

  layout = SCM_STRUCT_LAYOUT (handle);
  data = SCM_STRUCT_DATA (handle);
  p = scm_to_size_t (pos);

  fields_desc = scm_i_symbol_chars (layout);
  layout_len = scm_i_symbol_length (layout);
  if (SCM_STRUCT_VTABLE_FLAGS (handle) & SCM_STRUCTF_LIGHT)
    /* no extra words */
    n_fields = layout_len / 2;
  else
    n_fields = data[scm_struct_i_n_words];

  SCM_ASSERT_RANGE(1, pos, p < n_fields);

  if (p * 2 < layout_len)
    {
      char ref;
      field_type = fields_desc[p * 2];
      ref = fields_desc[p * 2 + 1];
      if ((ref != 'r') && (ref != 'w'))
	{
	  if ((ref == 'R') || (ref == 'W'))
	    field_type = 'u';
	  else
	    SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos));
	}
    }
  else if (fields_desc[layout_len - 1] != 'O')
    field_type = fields_desc[layout_len - 2];
  else
    SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos));

  switch (field_type)
    {
    case 'u':
      answer = scm_from_ulong (data[p]);
      break;

#if 0
    case 'i':
      answer = scm_from_long (data[p]);
      break;

    case 'd':
      answer = scm_make_real (*((double *)&(data[p])));
      break;
#endif

    case 's':
    case 'p':
      answer = SCM_PACK (data[p]);
      break;

    default:
      SCM_MISC_ERROR ("unrecognized field type: ~S",
		      scm_list_1 (SCM_MAKE_CHAR (field_type)));
    }

  return answer;
}
#undef FUNC_NAME

SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0,
            (SCM handle, SCM pos, SCM val),
	    "Set the slot of the structure @var{handle} with index @var{pos}\n"
	    "to @var{val}.  Signal an error if the slot can not be written\n"
	    "to.")
#define FUNC_NAME s_scm_struct_set_x
{
  scm_t_bits * data;
  SCM layout;
  size_t layout_len;
  size_t p;
  int n_fields;
  const char *fields_desc;
  char field_type = 0;

  SCM_VALIDATE_STRUCT (1, handle);

  layout = SCM_STRUCT_LAYOUT (handle);
  data = SCM_STRUCT_DATA (handle);
  p = scm_to_size_t (pos);

  fields_desc = scm_i_symbol_chars (layout);
  layout_len = scm_i_symbol_length (layout);
  if (SCM_STRUCT_VTABLE_FLAGS (handle) & SCM_STRUCTF_LIGHT)
    /* no extra words */
    n_fields = layout_len / 2;
  else
    n_fields = data[scm_struct_i_n_words];

  SCM_ASSERT_RANGE (1, pos, p < n_fields);

  if (p * 2 < layout_len)
    {
      char set_x;
      field_type = fields_desc[p * 2];
      set_x = fields_desc [p * 2 + 1];
      if (set_x != 'w')
	SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos));
    }
  else if (fields_desc[layout_len - 1] == 'W')
    field_type = fields_desc[layout_len - 2];
  else
    SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos));

  switch (field_type)
    {
    case 'u':
      data[p] = SCM_NUM2ULONG (3, val);
      break;

#if 0
    case 'i':
      data[p] = SCM_NUM2LONG (3, val);
      break;

    case 'd':
      *((double *)&(data[p])) = scm_num2dbl (val, (char *)SCM_ARG3);
      break;
#endif

    case 'p':
      data[p] = SCM_UNPACK (val);
      break;

    case 's':
      SCM_MISC_ERROR ("self fields immutable", SCM_EOL);

    default:
      SCM_MISC_ERROR ("unrecognized field type: ~S",
		      scm_list_1 (SCM_MAKE_CHAR (field_type)));
    }

  return val;
}
#undef FUNC_NAME

SCM_DEFINE (scm_struct_vtable, "struct-vtable", 1, 0, 0,
            (SCM handle),
	    "Return the vtable structure that describes the type of @var{struct}.")
#define FUNC_NAME s_scm_struct_vtable
{
  SCM_VALIDATE_STRUCT (1, handle);
  return SCM_STRUCT_VTABLE (handle);
}
#undef FUNC_NAME

SCM_DEFINE (scm_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0,
            (SCM handle),
	    "Return the vtable tag of the structure @var{handle}.")
#define FUNC_NAME s_scm_struct_vtable_tag
{
  SCM_VALIDATE_VTABLE (1, handle);
  return scm_from_ulong (((unsigned long)SCM_STRUCT_DATA (handle)) >> 3);
}
#undef FUNC_NAME

/* {Associating names and classes with vtables}
 *
 * The name of a vtable should probably be stored as a slot.  This is
 * a backward compatible solution until agreement has been achieved on
 * how to associate names with vtables.
 */

unsigned long
scm_struct_ihashq (SCM obj, unsigned long n)
{
  /* The length of the hash table should be a relative prime it's not
     necessary to shift down the address.  */
  return SCM_UNPACK (obj) % n;
}

SCM
scm_struct_create_handle (SCM obj)
{
  SCM handle = scm_hash_fn_create_handle_x (scm_struct_table,
					    obj,
					    SCM_BOOL_F,
					    scm_struct_ihashq,
					    scm_sloppy_assq,
					    0);
  if (scm_is_false (SCM_CDR (handle)))
    SCM_SETCDR (handle, scm_cons (SCM_BOOL_F, SCM_BOOL_F));
  return handle;
}

SCM_DEFINE (scm_struct_vtable_name, "struct-vtable-name", 1, 0, 0,
            (SCM vtable),
	    "Return the name of the vtable @var{vtable}.")
#define FUNC_NAME s_scm_struct_vtable_name
{
  SCM_VALIDATE_VTABLE (1, vtable);
  return SCM_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)));
}
#undef FUNC_NAME

SCM_DEFINE (scm_set_struct_vtable_name_x, "set-struct-vtable-name!", 2, 0, 0,
            (SCM vtable, SCM name),
	    "Set the name of the vtable @var{vtable} to @var{name}.")
#define FUNC_NAME s_scm_set_struct_vtable_name_x
{
  SCM_VALIDATE_VTABLE (1, vtable);
  SCM_VALIDATE_SYMBOL (2, name);
  SCM_SET_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)),
			     name);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

void
scm_print_struct (SCM exp, SCM port, scm_print_state *pstate)
{
  if (scm_is_true (scm_procedure_p (SCM_STRUCT_PRINTER (exp))))
    scm_printer_apply (SCM_STRUCT_PRINTER (exp), exp, port, pstate);
  else
    {
      SCM vtable = SCM_STRUCT_VTABLE (exp);
      SCM name = scm_struct_vtable_name (vtable);
      scm_puts ("#<", port);
      if (scm_is_true (name))
	scm_display (name, port);
      else
	scm_puts ("struct", port);
      scm_putc (' ', port);
      scm_uintprint (SCM_UNPACK (vtable), 16, port);
      scm_putc (':', port);
      scm_uintprint (SCM_UNPACK (exp), 16, port);
      scm_putc ('>', port);
    }
}

void
scm_struct_prehistory ()
{
  scm_i_structs_to_free = SCM_EOL;
  scm_c_hook_add (&scm_before_sweep_c_hook, scm_struct_gc_init, 0, 0);
  /* With the new lazy sweep GC, the point at which the entire heap is
     swept is just before the mark phase. */
  scm_c_hook_add (&scm_before_mark_c_hook, scm_free_structs, 0, 0);
}

void
scm_init_struct ()
{
  scm_struct_table
    = scm_permanent_object (scm_make_weak_key_hash_table (scm_from_int (31)));
  required_vtable_fields = scm_from_locale_string ("prsrpw");
  scm_permanent_object (required_vtable_fields);

  scm_i_vtable_vtable_no_extra_fields =
    scm_permanent_object
    (scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL));

  scm_c_define ("vtable-index-layout", scm_from_int (scm_vtable_index_layout));
  scm_c_define ("vtable-index-vtable", scm_from_int (scm_vtable_index_vtable));
  scm_c_define ("vtable-index-printer",
		scm_from_int (scm_vtable_index_printer));
  scm_c_define ("vtable-offset-user", scm_from_int (scm_vtable_offset_user));
#include "libguile/struct.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_STRUCT_H
#define SCM_STRUCT_H

/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007 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 2.1 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"
#include "libguile/print.h"

/* Number of words with negative index */
#define scm_struct_n_extra_words 4
#define scm_struct_entity_n_extra_words 6

/* These are how the initial words of a vtable are allocated. */
#define scm_struct_i_setter	-6 /* Setter */
#define scm_struct_i_procedure	-5 /* Optional procedure slot */
#define scm_struct_i_free	-4 /* Destructor */
#define scm_struct_i_ptr	-3 /* Start of block (see alloc_struct) */
#define scm_struct_i_n_words	-2 /* How many words allocated to this struct? */
#define scm_struct_i_size	-1 /* Instance size */
#define scm_struct_i_flags	-1 /* Upper 12 bits used as flags */

/* These indices must correspond to required_vtable_fields in
   struct.c. */
#define scm_vtable_index_layout  0 /* A symbol describing the physical arrangement of this type. */
#define scm_vtable_index_vtable  1 /* A pointer to the handle for this vtable. */
#define scm_vtable_index_printer 2 /* A printer for this struct type. */
#define scm_vtable_offset_user   3 /* Where do user fields start? */

typedef void (*scm_t_struct_free) (scm_t_bits * vtable, scm_t_bits * data);

#define SCM_STRUCTF_MASK   (0xFFF << 20)
#define SCM_STRUCTF_ENTITY (1L << 30) /* Indicates presence of proc slots */
#define SCM_STRUCTF_LIGHT  (1L << 31) /* Light representation
					 (no hidden words) */

#define SCM_STRUCTP(X)  		(!SCM_IMP(X) && (SCM_TYP3(X) == scm_tc3_struct))
#define SCM_STRUCT_DATA(X) 		((scm_t_bits *) SCM_CELL_WORD_1 (X))
#define SCM_STRUCT_VTABLE_DATA(X)       ((scm_t_bits *) (SCM_CELL_WORD_0 (X) - scm_tc3_struct))

#define SCM_STRUCT_LAYOUT(X) 	        (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_layout]))
#define SCM_SET_STRUCT_LAYOUT(X, v)     (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_layout] = SCM_UNPACK (v))

#define SCM_STRUCT_VTABLE(X) 	        (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_vtable]))
#define SCM_STRUCT_VTABLE_FLAGS(X) \
  (SCM_STRUCT_VTABLE_DATA (X) [scm_struct_i_flags])
#define SCM_STRUCT_PRINTER(X) 	        (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_printer]))
#define SCM_SET_STRUCT_PRINTER(x, v)\
   (SCM_STRUCT_VTABLE_DATA (x) [scm_vtable_index_printer] = SCM_UNPACK (v))
#define SCM_SET_VTABLE_DESTRUCTOR(X, D) (SCM_STRUCT_DATA (X) [scm_struct_i_free] = (scm_t_bits) (D))
/* Efficiency is important in the following macro, since it's used in GC */
#define SCM_LAYOUT_TAILP(X)		(((X) & 32) == 0) /* R, W or O */

#define SCM_STRUCT_TABLE_NAME(X) SCM_CAR (X)
#define SCM_SET_STRUCT_TABLE_NAME(X, NAME) SCM_SETCAR (X, NAME)
#define SCM_STRUCT_TABLE_CLASS(X) SCM_CDR (X)
#define SCM_SET_STRUCT_TABLE_CLASS(X, CLASS) SCM_SETCDR (X, CLASS)
SCM_API SCM scm_struct_table;

#define SCM_STRUCT_GC_CHAIN(X) SCM_CELL_OBJECT_3 (X)
#define SCM_SET_STRUCT_GC_CHAIN(X, Y) SCM_SET_CELL_OBJECT_3 (X, Y)
SCM_API SCM scm_i_structs_to_free;

SCM_API scm_t_bits * scm_alloc_struct (int n_words, int n_extra,
				       const char *what);
SCM_API void scm_struct_free_0 (scm_t_bits * vtable, scm_t_bits * data);
SCM_API void scm_struct_free_light (scm_t_bits * vtable, scm_t_bits * data);
SCM_API void scm_struct_free_standard (scm_t_bits * vtable, scm_t_bits * data);
SCM_API void scm_struct_free_entity (scm_t_bits * vtable, scm_t_bits * data);
SCM_API SCM scm_make_struct_layout (SCM fields);
SCM_API SCM scm_struct_p (SCM x);
SCM_API SCM scm_struct_vtable_p (SCM x);
SCM_API SCM scm_make_struct (SCM vtable, SCM tail_array_size, SCM init);
SCM_API SCM scm_make_vtable (SCM fields, SCM printer);
SCM_API SCM scm_make_vtable_vtable (SCM extra_fields, SCM tail_array_size, SCM init);
SCM_API SCM scm_i_struct_equalp (SCM s1, SCM s2);
SCM_API SCM scm_struct_ref (SCM handle, SCM pos);
SCM_API SCM scm_struct_set_x (SCM handle, SCM pos, SCM val);
SCM_API SCM scm_struct_vtable (SCM handle);
SCM_API SCM scm_struct_vtable_tag (SCM handle);
SCM_API unsigned long scm_struct_ihashq (SCM obj, unsigned long n);
SCM_API SCM scm_struct_create_handle (SCM obj);
SCM_API SCM scm_struct_vtable_name (SCM vtable);
SCM_API SCM scm_set_struct_vtable_name_x (SCM vtable, SCM name);
SCM_API void scm_print_struct (SCM exp, SCM port, scm_print_state *);
SCM_API void scm_struct_prehistory (void);
SCM_API void scm_init_struct (void);

#endif  /* SCM_STRUCT_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2009 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 2.1 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 <config.h>
#endif

#include "libguile/_scm.h"
#include "libguile/chars.h"
#include "libguile/eval.h"
#include "libguile/hash.h"
#include "libguile/smob.h"
#include "libguile/variable.h"
#include "libguile/alist.h"
#include "libguile/fluids.h"
#include "libguile/strings.h"
#include "libguile/vectors.h"
#include "libguile/hashtab.h"
#include "libguile/weaks.h"
#include "libguile/modules.h"
#include "libguile/read.h"
#include "libguile/srfi-13.h"

#include "libguile/validate.h"
#include "libguile/symbols.h"

#ifdef HAVE_STRING_H
#include <string.h>
#endif

static SCM symbols;

#ifdef GUILE_DEBUG
SCM_DEFINE (scm_sys_symbols, "%symbols", 0, 0, 0,
	    (),
	    "Return the system symbol obarray.")
#define FUNC_NAME s_scm_sys_symbols
{
  return symbols;
}
#undef FUNC_NAME
#endif

/* {Symbols}
 */

/* In order to optimize reading speed, this function breaks part of
 * the hashtable abstraction.  The optimizations are:
 *
 * 1. The argument string can be compared directly to symbol objects
 *    without first creating an SCM string object.  (This would have
 *    been necessary if we had used the hashtable API in hashtab.h.)
 *
 * 2. We can use the raw hash value stored in scm_i_symbol_hash (sym)
 *    to speed up lookup.
 *
 * Both optimizations might be possible without breaking the
 * abstraction if the API in hashtab.c is improved.
 */

unsigned long
scm_i_hash_symbol (SCM obj, unsigned long n, void *closure)
{
  return scm_i_symbol_hash (obj) % n;
}

static SCM
lookup_interned_symbol (const char *name, size_t len,
			unsigned long raw_hash)
{
  /* Try to find the symbol in the symbols table */
  SCM l;
  unsigned long hash = raw_hash % SCM_HASHTABLE_N_BUCKETS (symbols);

  for (l = SCM_HASHTABLE_BUCKET (symbols, hash);
       !scm_is_null (l);
       l = SCM_CDR (l))
    {
      SCM sym = SCM_CAAR (l);
      if (scm_i_symbol_hash (sym) == raw_hash
	  && scm_i_symbol_length (sym) == len)
	{
	  const char *chrs = scm_i_symbol_chars (sym);
	  size_t i = len;

	  while (i != 0)
	    {
	      --i;
	      if (name[i] != chrs[i])
		goto next_symbol;
	    }

	  return sym;
	}
    next_symbol:
      ;
    }

  return SCM_BOOL_F;
}

/* Intern SYMBOL, an uninterned symbol.  */
static void
intern_symbol (SCM symbol)
{
  SCM slot, cell;
  unsigned long hash;

  hash = scm_i_symbol_hash (symbol) % SCM_HASHTABLE_N_BUCKETS (symbols);
  slot = SCM_HASHTABLE_BUCKET (symbols, hash);
  cell = scm_cons (symbol, SCM_UNDEFINED);

  SCM_SET_HASHTABLE_BUCKET (symbols, hash, scm_cons (cell, slot));
  SCM_HASHTABLE_INCREMENT (symbols);

  if (SCM_HASHTABLE_N_ITEMS (symbols) > SCM_HASHTABLE_UPPER (symbols))
    scm_i_rehash (symbols, scm_i_hash_symbol, 0, "intern_symbol");
}

static SCM
scm_i_c_mem2symbol (const char *name, size_t len)
{
  SCM symbol;
  size_t raw_hash = scm_string_hash ((const unsigned char *) name, len);

  symbol = lookup_interned_symbol (name, len, raw_hash);
  if (scm_is_false (symbol))
    {
      /* The symbol was not found, create it.  */
      symbol = scm_i_c_make_symbol (name, len, 0, raw_hash,
				    scm_cons (SCM_BOOL_F, SCM_EOL));
      intern_symbol (symbol);
    }

  return symbol;
}

static SCM
scm_i_mem2symbol (SCM str)
{
  SCM symbol;
  const char *name = scm_i_string_chars (str);
  size_t len = scm_i_string_length (str);
  size_t raw_hash = scm_string_hash ((const unsigned char *) name, len);

  symbol = lookup_interned_symbol (name, len, raw_hash);
  if (scm_is_false (symbol))
    {
      /* The symbol was not found, create it.  */
      symbol = scm_i_make_symbol (str, 0, raw_hash,
				  scm_cons (SCM_BOOL_F, SCM_EOL));
      intern_symbol (symbol);
    }

  return symbol;
}

static SCM
scm_i_mem2uninterned_symbol (SCM str)
{
  const char *name = scm_i_string_chars (str);
  size_t len = scm_i_string_length (str);
  size_t raw_hash = scm_string_hash ((const unsigned char *) name, len);

  return scm_i_make_symbol (str, SCM_I_F_SYMBOL_UNINTERNED,
			    raw_hash, scm_cons (SCM_BOOL_F, SCM_EOL));
}

SCM_DEFINE (scm_symbol_p, "symbol?", 1, 0, 0,
	    (SCM obj),
	    "Return @code{#t} if @var{obj} is a symbol, otherwise return\n"
	    "@code{#f}.")
#define FUNC_NAME s_scm_symbol_p
{
  return scm_from_bool (scm_is_symbol (obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_symbol_interned_p, "symbol-interned?", 1, 0, 0,
	    (SCM symbol),
	    "Return @code{#t} if @var{symbol} is interned, otherwise return\n"
	    "@code{#f}.")
#define FUNC_NAME s_scm_symbol_interned_p
{
  SCM_VALIDATE_SYMBOL (1, symbol);
  return scm_from_bool (scm_i_symbol_is_interned (symbol));
}
#undef FUNC_NAME

SCM_DEFINE (scm_make_symbol, "make-symbol", 1, 0, 0,
	    (SCM name),
	    "Return a new uninterned symbol with the name @var{name}.  "
	    "The returned symbol is guaranteed to be unique and future "
	    "calls to @code{string->symbol} will not return it.")
#define FUNC_NAME s_scm_make_symbol
{
  SCM_VALIDATE_STRING (1, name);
  return scm_i_mem2uninterned_symbol (name);
}
#undef FUNC_NAME

SCM_DEFINE (scm_symbol_to_string, "symbol->string", 1, 0, 0,
           (SCM s),
	    "Return the name of @var{symbol} as a string.  If the symbol was\n"
	    "part of an object returned as the value of a literal expression\n"
	    "(section @pxref{Literal expressions,,,r5rs, The Revised^5\n"
	    "Report on Scheme}) or by a call to the @code{read} procedure,\n"
	    "and its name contains alphabetic characters, then the string\n"
	    "returned will contain characters in the implementation's\n"
	    "preferred standard case---some implementations will prefer\n"
	    "upper case, others lower case.  If the symbol was returned by\n"
	    "@code{string->symbol}, the case of characters in the string\n"
	    "returned will be the same as the case in the string that was\n"
	    "passed to @code{string->symbol}.  It is an error to apply\n"
	    "mutation procedures like @code{string-set!} to strings returned\n"
	    "by this procedure.\n"
	    "\n"
	    "The following examples assume that the implementation's\n"
	    "standard case is lower case:\n"
	    "\n"
	    "@lisp\n"
	    "(symbol->string 'flying-fish)    @result{} \"flying-fish\"\n"
	    "(symbol->string 'Martin)         @result{}  \"martin\"\n"
	    "(symbol->string\n"
	    "   (string->symbol \"Malvina\")) @result{} \"Malvina\"\n"
	    "@end lisp")
#define FUNC_NAME s_scm_symbol_to_string
{
  SCM_VALIDATE_SYMBOL (1, s);
  return scm_i_symbol_substring (s, 0, scm_i_symbol_length (s));
}
#undef FUNC_NAME

SCM_DEFINE (scm_string_to_symbol, "string->symbol", 1, 0, 0,
	    (SCM string),
	    "Return the symbol whose name is @var{string}. This procedure\n"
	    "can create symbols with names containing special characters or\n"
	    "letters in the non-standard case, but it is usually a bad idea\n"
	    "to create such symbols because in some implementations of\n"
	    "Scheme they cannot be read as themselves.  See\n"
	    "@code{symbol->string}.\n"
	    "\n"
	    "The following examples assume that the implementation's\n"
	    "standard case is lower case:\n"
	    "\n"
	    "@lisp\n"
	    "(eq? 'mISSISSIppi 'mississippi) @result{} #t\n"
	    "(string->symbol \"mISSISSIppi\") @result{} @r{the symbol with name \"mISSISSIppi\"}\n"
	    "(eq? 'bitBlt (string->symbol \"bitBlt\")) @result{} #f\n"
	    "(eq? 'JollyWog\n"
	    "  (string->symbol (symbol->string 'JollyWog))) @result{} #t\n"
	    "(string=? \"K. Harper, M.D.\"\n"
	    "  (symbol->string\n"
	    "    (string->symbol \"K. Harper, M.D.\"))) @result{}#t\n"
	    "@end lisp")
#define FUNC_NAME s_scm_string_to_symbol
{
  SCM_VALIDATE_STRING (1, string);
  return scm_i_mem2symbol (string);
}
#undef FUNC_NAME

SCM_DEFINE (scm_string_ci_to_symbol, "string-ci->symbol", 1, 0, 0,
	    (SCM str),
	    "Return the symbol whose name is @var{str}.  @var{str} is\n"
	    "converted to lowercase before the conversion is done, if Guile\n"
	    "is currently reading symbols case-insensitively.")
#define FUNC_NAME s_scm_string_ci_to_symbol
{
  return scm_string_to_symbol (SCM_CASE_INSENSITIVE_P
			       ? scm_string_downcase(str)
			       : str);
}
#undef FUNC_NAME

#define MAX_PREFIX_LENGTH 30

SCM_DEFINE (scm_gensym, "gensym", 0, 1, 0,
            (SCM prefix),
	    "Create a new symbol with a name constructed from a prefix and\n"
	    "a counter value. The string @var{prefix} can be specified as\n"
	    "an optional argument. Default prefix is @code{ g}.  The counter\n"
	    "is increased by 1 at each call. There is no provision for\n"
	    "resetting the counter.")
#define FUNC_NAME s_scm_gensym
{
  static int gensym_counter = 0;

  SCM suffix, name;
  int n, n_digits;
  char buf[SCM_INTBUFLEN];

  if (SCM_UNBNDP (prefix))
    prefix = scm_from_locale_string (" g");

  /* mutex in case another thread looks and incs at the exact same moment */
  scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex);
  n = gensym_counter++;
  scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);

  n_digits = scm_iint2str (n, 10, buf);
  suffix = scm_from_locale_stringn (buf, n_digits);
  name = scm_string_append (scm_list_2 (prefix, suffix));
  return scm_string_to_symbol (name);
}
#undef FUNC_NAME

SCM_DEFINE (scm_symbol_hash, "symbol-hash", 1, 0, 0,
	    (SCM symbol),
	    "Return a hash value for @var{symbol}.")
#define FUNC_NAME s_scm_symbol_hash
{
  SCM_VALIDATE_SYMBOL (1, symbol);
  return scm_from_ulong (scm_i_symbol_hash (symbol));
}
#undef FUNC_NAME

SCM_DEFINE (scm_symbol_fref, "symbol-fref", 1, 0, 0,
           (SCM s),
	    "Return the contents of @var{symbol}'s @dfn{function slot}.")
#define FUNC_NAME s_scm_symbol_fref
{
  SCM_VALIDATE_SYMBOL (1, s);
  return SCM_CAR (SCM_CELL_OBJECT_3 (s));
}
#undef FUNC_NAME

SCM_DEFINE (scm_symbol_pref, "symbol-pref", 1, 0, 0,
           (SCM s),
	    "Return the @dfn{property list} currently associated with @var{symbol}.")
#define FUNC_NAME s_scm_symbol_pref
{
  SCM_VALIDATE_SYMBOL (1, s);
  return SCM_CDR (SCM_CELL_OBJECT_3 (s));
}
#undef FUNC_NAME

SCM_DEFINE (scm_symbol_fset_x, "symbol-fset!", 2, 0, 0,
           (SCM s, SCM val),
	    "Change the binding of @var{symbol}'s function slot.")
#define FUNC_NAME s_scm_symbol_fset_x
{
  SCM_VALIDATE_SYMBOL (1, s);
  SCM_SETCAR (SCM_CELL_OBJECT_3 (s), val);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM_DEFINE (scm_symbol_pset_x, "symbol-pset!", 2, 0, 0,
           (SCM s, SCM val),
	    "Change the binding of @var{symbol}'s property slot.")
#define FUNC_NAME s_scm_symbol_pset_x
{
  SCM_VALIDATE_SYMBOL (1, s);
  SCM_SETCDR (SCM_CELL_OBJECT_3 (s), val);
  return SCM_UNSPECIFIED;
}
#undef FUNC_NAME

SCM
scm_from_locale_symbol (const char *sym)
{
  return scm_i_c_mem2symbol (sym, strlen (sym));
}

SCM
scm_from_locale_symboln (const char *sym, size_t len)
{
  return scm_i_c_mem2symbol (sym, len);
}

SCM
scm_take_locale_symboln (char *sym, size_t len)
{
  SCM res;
  unsigned long raw_hash;

  if (len == (size_t)-1)
    len = strlen (sym);
  else
    {
      /* Ensure STR is null terminated.  A realloc for 1 extra byte should
         often be satisfied from the alignment padding after the block, with
         no actual data movement.  */
      sym = scm_realloc (sym, len+1);
      sym[len] = '\0';
    }

  raw_hash = scm_string_hash ((unsigned char *)sym, len);
  res = lookup_interned_symbol (sym, len, raw_hash);
  if (scm_is_false (res))
    {
      res = scm_i_c_take_symbol (sym, len, 0, raw_hash,
				 scm_cons (SCM_BOOL_F, SCM_EOL));
      intern_symbol (res);
    }
  else
    free (sym);

  return res;
}

SCM
scm_take_locale_symbol (char *sym)
{
  return scm_take_locale_symboln (sym, (size_t)-1);
}

void
scm_symbols_prehistory ()
{
  symbols = scm_make_weak_key_hash_table (scm_from_int (2139));
  scm_permanent_object (symbols);
}

void
scm_init_symbols ()
{
#include "libguile/symbols.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/


code:
/* classes: h_files */

#ifndef SCM_SYMBOLS_H
#define SCM_SYMBOLS_H

/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006 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 2.1 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"

#define scm_is_symbol(x)            (!SCM_IMP (x) \
                                     && (SCM_TYP7 (x) == scm_tc7_symbol))
#define scm_i_symbol_hash(x)        ((unsigned long) SCM_CELL_WORD_2 (x))
#define scm_i_symbol_is_interned(x) \
  (!(SCM_CELL_WORD_0 (x) & SCM_I_F_SYMBOL_UNINTERNED))

#define SCM_I_F_SYMBOL_UNINTERNED   0x100

#ifdef GUILE_DEBUG
SCM_API SCM scm_sys_symbols (void);
#endif

SCM_API SCM scm_symbol_p (SCM x);
SCM_API SCM scm_symbol_interned_p (SCM sym);
SCM_API SCM scm_make_symbol (SCM name);
SCM_API SCM scm_symbol_to_string (SCM s);
SCM_API SCM scm_string_to_symbol (SCM s);
SCM_API SCM scm_string_ci_to_symbol (SCM s);

SCM_API SCM scm_symbol_fref (SCM s);
SCM_API SCM scm_symbol_pref (SCM s);
SCM_API SCM scm_symbol_fset_x (SCM s, SCM val);
SCM_API SCM scm_symbol_pset_x (SCM s, SCM val);

SCM_API SCM scm_symbol_hash (SCM s);
SCM_API SCM scm_gensym (SCM prefix);

SCM_API SCM scm_from_locale_symbol (const char *str);
SCM_API SCM scm_from_locale_symboln (const char *str, size_t len);
SCM_API SCM scm_take_locale_symbol (char *sym);
SCM_API SCM scm_take_locale_symboln (char *sym, size_t len);

/* internal functions. */

SCM_API unsigned long scm_i_hash_symbol (SCM obj, unsigned long n,
					 void *closure);

SCM_API void scm_symbols_prehistory (void);
SCM_API void scm_init_symbols (void);

#endif  /* SCM_SYMBOLS_H */

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/