code:
/* classes: h_files */

#ifndef SCM_STRINGS_H
#define SCM_STRINGS_H

/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2004, 2005, 2006, 2008, 2009, 2010 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 3 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"

/* String representation.

   A string is a piece of a stringbuf.  A stringbuf can be used by
   more than one string.  When a string is written to and the
   stringbuf of that string is used by more than one string, a new
   stringbuf is created.  That is, strings are copy-on-write.  This
   behavior can be used to make the substring operation quite
   efficient.

   The implementation is tuned so that mutating a string is costly,
   but just reading it is cheap and lock-free.

   There are also mutation-sharing strings.  They refer to a part of
   an ordinary string.  Writing to a mutation-sharing string just
   writes to the ordinary string.

   Internal, low level interface to the character arrays

   - Use scm_is_narrow_string to determine is the string is narrow or
     wide.

   - Use scm_i_string_chars or scm_i_string_wide_chars to get a
     pointer to the byte or scm_t_wchar array of a string for reading.
     Use scm_i_string_length to get the number of characters in that
     array.  The array is not null-terminated.

   - The array is valid as long as the corresponding SCM object is
     protected but only until the next SCM_TICK.  During such a 'safe
     point', strings might change their representation.

   - Use scm_i_string_start_writing to get a version of the string
     ready for reading and writing.  This is a potentially costly
     operation since it implements the copy-on-write behavior.  When
     done with the writing, call scm_i_string_stop_writing.  You must
     do this before the next SCM_TICK.  (This means, before calling
     almost any other scm_ function and you can't allow throws, of
     course.)

   - New strings can be created with scm_i_make_string or
     scm_i_make_wide_string.  This gives access to a writable pointer
     that remains valid as long as nobody else makes a copy-on-write
     substring of the string.  Do not call scm_i_string_stop_writing
     for this pointer.

   - Alternately, scm_i_string_ref and scm_i_string_set_x can be used
     to read and write strings without worrying about whether the
     string is narrow or wide.  scm_i_string_set_x still needs to be
     bracketed by scm_i_string_start_writing and
     scm_i_string_stop_writing.

   Legacy interface

   - SCM_STRINGP is just scm_is_string.

   - SCM_STRING_CHARS uses scm_i_string_writable_chars and immediately
     calls scm_i_stop_writing, hoping for the best.  SCM_STRING_LENGTH
     is the same as scm_i_string_length.  SCM_STRING_CHARS will throw
     an error for for strings that are not null-terminated.  There is
     no wide version of this interface.
*/

/* A type indicating what strategy to take when string locale
   conversion is unsuccessful.  */
typedef enum
{
  SCM_FAILED_CONVERSION_ERROR = SCM_ICONVEH_ERROR,
  SCM_FAILED_CONVERSION_QUESTION_MARK = SCM_ICONVEH_QUESTION_MARK,
  SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE = SCM_ICONVEH_ESCAPE_SEQUENCE
} scm_t_string_failed_conversion_handler;

SCM_INTERNAL SCM scm_nullstr;

SCM_API SCM scm_string_p (SCM x);
SCM_API SCM scm_string (SCM chrs);
SCM_API SCM scm_make_string (SCM k, SCM chr);
SCM_API SCM scm_string_length (SCM str);
SCM_API SCM scm_string_bytes_per_char (SCM str);
SCM_API SCM scm_string_ref (SCM str, SCM k);
SCM_API SCM scm_string_set_x (SCM str, SCM k, SCM chr);
SCM_API SCM scm_substring (SCM str, SCM start, SCM end);
SCM_API SCM scm_substring_read_only (SCM str, SCM start, SCM end);
SCM_API SCM scm_substring_shared (SCM str, SCM start, SCM end);
SCM_API SCM scm_substring_copy (SCM str, SCM start, SCM end);
SCM_API SCM scm_string_append (SCM args);

SCM_API SCM scm_from_stringn (const char *str, size_t len,
                                     const char *encoding,
                                     scm_t_string_failed_conversion_handler
                                     handler);
SCM_API SCM scm_c_make_string (size_t len, SCM chr);
SCM_API size_t scm_c_string_length (SCM str);
SCM_API size_t scm_c_symbol_length (SCM sym);
SCM_API SCM scm_c_string_ref (SCM str, size_t pos);
SCM_API void scm_c_string_set_x (SCM str, size_t pos, SCM chr);
SCM_API SCM scm_c_substring (SCM str, size_t start, size_t end);
SCM_API SCM scm_c_substring_read_only (SCM str, size_t start, size_t end);
SCM_API SCM scm_c_substring_shared (SCM str, size_t start, size_t end);
SCM_API SCM scm_c_substring_copy (SCM str, size_t start, size_t end);

SCM_API int scm_is_string (SCM x);
SCM_API SCM scm_from_locale_string (const char *str);
SCM_API SCM scm_from_locale_stringn (const char *str, size_t len);
SCM_INTERNAL SCM scm_i_from_utf8_string (const scm_t_uint8 *str);
SCM_API SCM scm_take_locale_string (char *str);
SCM_API SCM scm_take_locale_stringn (char *str, size_t len);
SCM_API char *scm_to_locale_string (SCM str);
SCM_API char *scm_to_locale_stringn (SCM str, size_t *lenp);
SCM_INTERNAL char *scm_to_stringn (SCM str, size_t *lenp,
                                   const char *encoding,
                                   scm_t_string_failed_conversion_handler
                                   handler);
SCM_INTERNAL scm_t_uint8 *scm_i_to_utf8_string (SCM str);
SCM_API size_t scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len);

SCM_API SCM scm_string_normalize_nfd (SCM str);
SCM_API SCM scm_string_normalize_nfkd (SCM str);
SCM_API SCM scm_string_normalize_nfc (SCM str);
SCM_API SCM scm_string_normalize_nfkc (SCM str);

SCM_API SCM scm_makfromstrs (int argc, char **argv);

/* internal constants */

/* Type tag for read-only strings.  */
#define scm_tc7_ro_string             (scm_tc7_string + 0x200)

/* Flags for shared and wide strings.  */
#define SCM_I_STRINGBUF_F_SHARED      0x100
#define SCM_I_STRINGBUF_F_WIDE        0x400

/* internal accessor functions.  Arguments must be valid. */

SCM_INTERNAL SCM scm_i_make_string (size_t len, char **datap);
SCM_INTERNAL SCM scm_i_make_wide_string (size_t len, scm_t_wchar **datap);
SCM_INTERNAL SCM scm_i_substring (SCM str, size_t start, size_t end);
SCM_INTERNAL SCM scm_i_substring_read_only (SCM str, size_t start, size_t end);
SCM_INTERNAL SCM scm_i_substring_shared (SCM str, size_t start, size_t end);
SCM_INTERNAL SCM scm_i_substring_copy (SCM str, size_t start, size_t end);
SCM_INTERNAL size_t scm_i_string_length (SCM str);
SCM_API /* FIXME: not internal */ const char *scm_i_string_chars (SCM str);
SCM_API /* FIXME: not internal */ char *scm_i_string_writable_chars (SCM str);
SCM_INTERNAL const scm_t_wchar *scm_i_string_wide_chars (SCM str);
SCM_INTERNAL const void *scm_i_string_data (SCM str);

SCM_INTERNAL SCM scm_i_string_start_writing (SCM str);
SCM_INTERNAL void scm_i_string_stop_writing (void);
SCM_INTERNAL int scm_i_is_narrow_string (SCM str);
SCM_INTERNAL scm_t_wchar scm_i_string_ref (SCM str, size_t x);
SCM_INTERNAL int scm_i_string_contains_char (SCM str, char c);
SCM_INTERNAL int scm_i_string_strcmp (SCM sstr, size_t start_x, const char *cstr);
SCM_INTERNAL void scm_i_string_set_x (SCM str, size_t p, scm_t_wchar chr);
/* internal functions related to symbols. */

SCM_INTERNAL SCM scm_i_make_symbol (SCM name, scm_t_bits flags,
				    unsigned long hash, SCM props);
SCM_INTERNAL SCM
scm_i_c_make_symbol (const char *name, size_t len,
		     scm_t_bits flags, unsigned long hash, SCM props);
SCM_INTERNAL const char *scm_i_symbol_chars (SCM sym);
SCM_INTERNAL const scm_t_wchar *scm_i_symbol_wide_chars (SCM sym);
SCM_INTERNAL size_t scm_i_symbol_length (SCM sym);
SCM_INTERNAL int scm_i_is_narrow_symbol (SCM str);
SCM_INTERNAL int scm_i_try_narrow_string (SCM str);
SCM_INTERNAL SCM scm_i_symbol_substring (SCM sym, size_t start, size_t end);
SCM_INTERNAL scm_t_wchar scm_i_symbol_ref (SCM sym, size_t x);
SCM_INTERNAL void scm_encoding_error (const char *subr, int err,
				      const char *message,
				      const char *from, const char *to,
				      SCM string_or_bv);

/* internal utility functions. */

SCM_INTERNAL char **scm_i_allocate_string_pointers (SCM list);
SCM_INTERNAL void scm_i_get_substring_spec (size_t len,
					    SCM start, size_t *cstart,
					    SCM end, size_t *cend);

/* Debugging functions */

SCM_API SCM scm_sys_string_dump (SCM);
SCM_API SCM scm_sys_symbol_dump (SCM);
#ifdef SCM_STRING_LENGTH_HISTOGRAM
SCM_API SCM scm_sys_stringbuf_hist (void);
#endif

/* deprecated stuff */

#if SCM_ENABLE_DEPRECATED

SCM_DEPRECATED int scm_i_deprecated_stringp (SCM obj);
SCM_DEPRECATED char *scm_i_deprecated_string_chars (SCM str);
SCM_DEPRECATED size_t scm_i_deprecated_string_length (SCM str);

#define SCM_STRINGP(x)       scm_i_deprecated_stringp(x)
#define SCM_STRING_CHARS(x)  scm_i_deprecated_string_chars(x)
#define SCM_STRING_LENGTH(x) scm_i_deprecated_string_length(x)
#define SCM_STRING_UCHARS(str) ((unsigned char *)SCM_STRING_CHARS (str))

#endif

SCM_INTERNAL void scm_init_strings (void);

#endif  /* SCM_STRINGS_H */

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


code:
/*	Copyright (C) 1995, 1996, 1999, 2000, 2004, 2006, 2008, 2009, 2010 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 3 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;
}

static SCM scm_i_string_equal_p (SCM s1, SCM s2, SCM rest);
SCM_DEFINE (scm_i_string_equal_p, "string=?", 0, 2, 1,
            (SCM s1, SCM s2, SCM rest),
	    "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_i_string_equal_p
{
  if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
    return SCM_BOOL_T;
  while (!scm_is_null (rest))
    {
      if (scm_is_false (srfi13_cmp (s1, s2, scm_string_eq)))
        return SCM_BOOL_F;
      s1 = s2;
      s2 = scm_car (rest);
      rest = scm_cdr (rest);
    }
  return srfi13_cmp (s1, s2, scm_string_eq);
}
#undef FUNC_NAME

SCM scm_string_equal_p (SCM s1, SCM s2)
#define FUNC_NAME s_scm_i_string_equal_p
{
  return srfi13_cmp (s1, s2, scm_string_eq);
}
#undef FUNC_NAME

static SCM scm_i_string_ci_equal_p (SCM s1, SCM s2, SCM rest);
SCM_DEFINE (scm_i_string_ci_equal_p, "string-ci=?", 0, 2, 1,
            (SCM s1, SCM s2, SCM rest),
	    "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_i_string_ci_equal_p
{
  if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
    return SCM_BOOL_T;
  while (!scm_is_null (rest))
    {
      if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_eq)))
        return SCM_BOOL_F;
      s1 = s2;
      s2 = scm_car (rest);
      rest = scm_cdr (rest);
    }
  return srfi13_cmp (s1, s2, scm_string_ci_eq);
}
#undef FUNC_NAME

SCM scm_string_ci_equal_p (SCM s1, SCM s2)
#define FUNC_NAME s_scm_i_string_ci_equal_p
{
  return srfi13_cmp (s1, s2, scm_string_ci_eq);
}
#undef FUNC_NAME

static SCM scm_i_string_less_p (SCM s1, SCM s2, SCM rest);
SCM_DEFINE (scm_i_string_less_p, "string<?", 0, 2, 1,
            (SCM s1, SCM s2, SCM rest),
	    "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
	    "is lexicographically less than @var{s2}.")
#define FUNC_NAME s_scm_i_string_less_p
{
  if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
    return SCM_BOOL_T;
  while (!scm_is_null (rest))
    {
      if (scm_is_false (srfi13_cmp (s1, s2, scm_string_lt)))
        return SCM_BOOL_F;
      s1 = s2;
      s2 = scm_car (rest);
      rest = scm_cdr (rest);
    }
  return srfi13_cmp (s1, s2, scm_string_lt);
}
#undef FUNC_NAME

SCM scm_string_less_p (SCM s1, SCM s2)
#define FUNC_NAME s_scm_i_string_less_p
{
  return srfi13_cmp (s1, s2, scm_string_lt);
}
#undef FUNC_NAME

static SCM scm_i_string_leq_p (SCM s1, SCM s2, SCM rest);
SCM_DEFINE (scm_i_string_leq_p, "string<=?", 0, 2, 1,
            (SCM s1, SCM s2, SCM rest),
	    "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
	    "is lexicographically less than or equal to @var{s2}.")
#define FUNC_NAME s_scm_i_string_leq_p
{
  if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
    return SCM_BOOL_T;
  while (!scm_is_null (rest))
    {
      if (scm_is_false (srfi13_cmp (s1, s2, scm_string_le)))
        return SCM_BOOL_F;
      s1 = s2;
      s2 = scm_car (rest);
      rest = scm_cdr (rest);
    }
  return srfi13_cmp (s1, s2, scm_string_le);
}
#undef FUNC_NAME

SCM scm_string_leq_p (SCM s1, SCM s2)
#define FUNC_NAME s_scm_i_string_leq_p
{
  return srfi13_cmp (s1, s2, scm_string_le);
}
#undef FUNC_NAME

static SCM scm_i_string_gr_p (SCM s1, SCM s2, SCM rest);
SCM_DEFINE (scm_i_string_gr_p, "string>?", 0, 2, 1,
            (SCM s1, SCM s2, SCM rest),
	    "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
	    "is lexicographically greater than @var{s2}.")
#define FUNC_NAME s_scm_i_string_gr_p
{
  if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
    return SCM_BOOL_T;
  while (!scm_is_null (rest))
    {
      if (scm_is_false (srfi13_cmp (s1, s2, scm_string_gt)))
        return SCM_BOOL_F;
      s1 = s2;
      s2 = scm_car (rest);
      rest = scm_cdr (rest);
    }
  return srfi13_cmp (s1, s2, scm_string_gt);
}
#undef FUNC_NAME

SCM scm_string_gr_p (SCM s1, SCM s2)
#define FUNC_NAME s_scm_i_string_gr_p
{
  return srfi13_cmp (s1, s2, scm_string_gt);
}
#undef FUNC_NAME

static SCM scm_i_string_geq_p (SCM s1, SCM s2, SCM rest);
SCM_DEFINE (scm_i_string_geq_p, "string>=?", 0, 2, 1,
            (SCM s1, SCM s2, SCM rest),
	    "Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
	    "is lexicographically greater than or equal to @var{s2}.")
#define FUNC_NAME s_scm_i_string_geq_p
{
  if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
    return SCM_BOOL_T;
  while (!scm_is_null (rest))
    {
      if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ge)))
        return SCM_BOOL_F;
      s1 = s2;
      s2 = scm_car (rest);
      rest = scm_cdr (rest);
    }
  return srfi13_cmp (s1, s2, scm_string_ge);
}
#undef FUNC_NAME

SCM scm_string_geq_p (SCM s1, SCM s2)
#define FUNC_NAME s_scm_i_string_geq_p
{
  return srfi13_cmp (s1, s2, scm_string_ge);
}
#undef FUNC_NAME

static SCM scm_i_string_ci_less_p (SCM s1, SCM s2, SCM rest);
SCM_DEFINE (scm_i_string_ci_less_p, "string-ci<?", 0, 2, 1,
            (SCM s1, SCM s2, SCM rest),
	    "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_i_string_ci_less_p
{
  if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
    return SCM_BOOL_T;
  while (!scm_is_null (rest))
    {
      if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_lt)))
        return SCM_BOOL_F;
      s1 = s2;
      s2 = scm_car (rest);
      rest = scm_cdr (rest);
    }
  return srfi13_cmp (s1, s2, scm_string_ci_lt);
}
#undef FUNC_NAME

SCM scm_string_ci_less_p (SCM s1, SCM s2)
#define FUNC_NAME s_scm_i_string_ci_less_p
{
  return srfi13_cmp (s1, s2, scm_string_ci_lt);
}
#undef FUNC_NAME

static SCM scm_i_string_ci_leq_p (SCM s1, SCM s2, SCM rest);
SCM_DEFINE (scm_i_string_ci_leq_p, "string-ci<=?", 0, 2, 1,
            (SCM s1, SCM s2, SCM rest),
	    "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_i_string_ci_leq_p
{
  if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
    return SCM_BOOL_T;
  while (!scm_is_null (rest))
    {
      if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_le)))
        return SCM_BOOL_F;
      s1 = s2;
      s2 = scm_car (rest);
      rest = scm_cdr (rest);
    }
  return srfi13_cmp (s1, s2, scm_string_ci_le);
}
#undef FUNC_NAME

SCM scm_string_ci_leq_p (SCM s1, SCM s2)
#define FUNC_NAME s_scm_i_string_ci_leq_p
{
  return srfi13_cmp (s1, s2, scm_string_ci_le);
}
#undef FUNC_NAME

static SCM scm_i_string_ci_gr_p (SCM s1, SCM s2, SCM rest);
SCM_DEFINE (scm_i_string_ci_gr_p, "string-ci>?", 0, 2, 1,
            (SCM s1, SCM s2, SCM rest),
	    "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_i_string_ci_gr_p
{
  if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
    return SCM_BOOL_T;
  while (!scm_is_null (rest))
    {
      if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_gt)))
        return SCM_BOOL_F;
      s1 = s2;
      s2 = scm_car (rest);
      rest = scm_cdr (rest);
    }
  return srfi13_cmp (s1, s2, scm_string_ci_gt);
}
#undef FUNC_NAME

SCM scm_string_ci_gr_p (SCM s1, SCM s2)
#define FUNC_NAME s_scm_i_string_ci_gr_p
{
  return srfi13_cmp (s1, s2, scm_string_ci_gt);
}
#undef FUNC_NAME

static SCM scm_i_string_ci_geq_p (SCM s1, SCM s2, SCM rest);
SCM_DEFINE (scm_i_string_ci_geq_p, "string-ci>=?", 0, 2, 1,
            (SCM s1, SCM s2, SCM rest),
	    "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_i_string_ci_geq_p
{
  if (SCM_UNBNDP (s1) || SCM_UNBNDP (s2))
    return SCM_BOOL_T;
  while (!scm_is_null (rest))
    {
      if (scm_is_false (srfi13_cmp (s1, s2, scm_string_ci_ge)))
        return SCM_BOOL_F;
      s1 = s2;
      s2 = scm_car (rest);
      rest = scm_cdr (rest);
    }
  return srfi13_cmp (s1, s2, scm_string_ci_ge);
}
#undef FUNC_NAME

SCM scm_string_ci_geq_p (SCM s1, SCM s2)
#define FUNC_NAME s_scm_i_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:
*/

license: mit


code:
/* classes: h_files */

#ifndef SCM_STRORDER_H
#define SCM_STRORDER_H

/* Copyright (C) 1995,1996,2000, 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 3 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_INTERNAL void scm_init_strorder (void);

#endif  /* SCM_STRORDER_H */

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


code:
/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2005, 2006, 2009, 2010 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 3 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/arrays.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/srfi-4.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, scm_t_off 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;

  scm_t_off 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 scm_t_off
st_seek (SCM port, scm_t_off offset, int whence)
{
  scm_t_port *pt = SCM_PTAB_ENTRY (port);
  scm_t_off 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, scm_t_off 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;
  char *buf, *c_str;

  SCM_ASSERT (scm_is_string (str), str, SCM_ARG1, caller);
  c_pos = scm_to_unsigned_integer (pos, 0, scm_i_string_length (str));

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

  scm_dynwind_begin (0);
  scm_i_dynwind_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);

  /* Create a copy of STR in the encoding of Z.  */
  buf = scm_to_stringn (str, &str_len, pt->encoding,
			SCM_FAILED_CONVERSION_ERROR);
  c_str = scm_gc_malloc (str_len, "strport");
  memcpy (c_str, buf, str_len);
  free (buf);

  pt->write_buf = pt->read_buf = (unsigned char *) c_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_dynwind_end ();

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

  scm_i_set_conversion_strategy_x (z, SCM_FAILED_CONVERSION_ERROR);
  return z;
}

/* 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)
{
  SCM str;
  scm_t_port *pt = SCM_PTAB_ENTRY (port);

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

  if (pt->read_buf_size == 0)
    return scm_nullstr;

  if (pt->encoding == NULL)
    {
      char *buf;
      str = scm_i_make_string (pt->read_buf_size, &buf);
      memcpy (buf, pt->read_buf, pt->read_buf_size);
    }
  else
    str = scm_from_stringn ((char *)pt->read_buf, pt->read_buf_size,
                            pt->encoding, pt->ilseq_handler);
  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)
{
  /* FIXME: the c string gets packed into a string, only to get
     immediately unpacked in scm_mkstrport.  */
  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_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, 2008, 2010 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 3 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_INTERNAL 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, 2008, 2009, 2010 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 3 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 <alloca.h>
#include <assert.h>

#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/srfi-13.h"

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

#include "libguile/eq.h"

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

#include "libguile/bdw-gc.h"

/* A needlessly obscure test. */
#define SCM_LAYOUT_TAILP(X)		(((X) & 32) == 0) /* R, W or O */

static SCM required_vtable_fields = SCM_BOOL_F;
static SCM required_applicable_fields = SCM_BOOL_F;
static SCM required_applicable_with_setter_fields = SCM_BOOL_F;
SCM scm_struct_table = SCM_BOOL_F;
SCM scm_applicable_struct_vtable_vtable;
SCM scm_applicable_struct_with_setter_vtable_vtable;
SCM scm_standard_vtable_vtable;

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, 'h' for hidden fields, 'r' for read-only\n"
            "fields, and 'o' for opaque fields.\n\n"
            "Hidden fields are writable, but they will not consume an initializer arg\n"
            "passed to @code{make-struct}. They are useful to add slots to a struct\n"
            "in a way that preserves backward-compatibility with existing calls to\n"
            "@code{make-struct}, especially for derived vtables.\n\n"
            "The last field protection specification may be capitalized to indicate\n"
	    "that the field is a tail-array.")
#define FUNC_NAME s_scm_make_struct_layout
{
  SCM new_sym;
  scm_t_wchar c;

  SCM_VALIDATE_STRING (1, fields);

  { /* scope */
    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));

    for (x = 0; x < len; x += 2)
      {
	switch (c = scm_i_string_ref (fields, 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 (c)));
	  }

	switch (c = scm_i_string_ref (fields, x + 1))
	  {
	  case 'w':
	  case 'h':
	    if (scm_i_string_ref (fields, x) == 's')
	      SCM_MISC_ERROR ("self fields not writable", SCM_EOL);
	  case 'r':
	  case 'o':
	    break;
	  case 'R':
	  case 'W':
	  case 'O':
	    if (scm_i_string_ref (fields, 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 (c)));
	  }
#if 0
	if (scm_i_string_ref (fields, x, 'd'))
	  {
	    if (!scm_i_string_ref (fields, 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

/* Check whether VTABLE instances have a simple layout (i.e., either only "pr"
   or only "pw" fields) and update its flags accordingly.  */
static void
set_vtable_layout_flags (SCM vtable)
{
  size_t len, field;
  SCM layout;
  const char *c_layout;
  scm_t_bits flags = SCM_VTABLE_FLAG_SIMPLE;

  layout = SCM_VTABLE_LAYOUT (vtable);
  c_layout = scm_i_symbol_chars (layout);
  len = scm_i_symbol_length (layout);

  assert (len % 2 == 0);

  /* Update FLAGS according to LAYOUT.  */
  for (field = 0;
       field < len && flags & SCM_VTABLE_FLAG_SIMPLE;
       field += 2)
    {
      if (c_layout[field] != 'p')
	flags = 0;
      else
	switch (c_layout[field + 1])
	  {
	  case 'w':
	  case 'W':
	    if (field == 0)
	      flags |= SCM_VTABLE_FLAG_SIMPLE_RW;
	    break;

	  case 'r':
	  case 'R':
	    flags &= ~SCM_VTABLE_FLAG_SIMPLE_RW;
	    break;

	  default:
	    flags = 0;
	  }
    }

  if (flags & SCM_VTABLE_FLAG_SIMPLE)
    {
      /* VTABLE is simple so update its flags and record the size of its
	 instances.  */
      SCM_SET_VTABLE_FLAGS (vtable, flags);
      SCM_STRUCT_DATA_SET (vtable, scm_vtable_index_size, len / 2);
    }
}

static int
scm_is_valid_vtable_layout (SCM layout)
{
  size_t len, n;
  const char *c_layout;

  c_layout = scm_i_symbol_chars (layout);
  len = scm_i_symbol_length (layout);

  if (len % 2)
    return 0;

  for (n = 0; n < len; n += 2)
    switch (c_layout[n])
      {
      case 'u':
      case 'p':
      case 's':
        switch (c_layout[n+1])
          {
          case 'W':
          case 'R':
          case 'O':
            if (n + 2 != len)
              return 0;
          case 'w':
          case 'h':
          case 'r':
          case 'o':
            break;
          default:
            return 0;
          }
        break;
      default:
        return 0;
      }
  return 1;
}

/* Have OBJ, a newly created vtable, inherit flags from VTABLE.  VTABLE is a
   vtable-vtable and OBJ is an instance of VTABLE.  */
void
scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj)
#define FUNC_NAME "%inherit-vtable-magic"
{
  /* Verily, what is the deal here, you ask? Basically, we need to know a couple
     of properties of structures at runtime. For example, "is this structure a
     vtable of vtables (a metaclass)?"; also, "is this structure applicable?".
     Both of these questions also imply a certain layout of the structure. So
     instead of checking the layout at runtime, what we do is pre-verify the
     layout -- so that at runtime we can just check the applicable flag and
     dispatch directly to the Scheme procedure in slot 0.  */
  SCM olayout;

  /* Verify that OBJ is a valid vtable.  */
  if (! scm_is_valid_vtable_layout (SCM_VTABLE_LAYOUT (obj)))
    scm_misc_error (FUNC_NAME, "invalid layout for new vtable: ~a",
                    scm_list_1 (SCM_VTABLE_LAYOUT (obj)));

  set_vtable_layout_flags (obj);

  /* If OBJ's vtable is compatible with the required vtable (class) layout, it
     is a metaclass.  */
  olayout = scm_symbol_to_string (SCM_VTABLE_LAYOUT (obj));
  if (scm_is_true (scm_leq_p (scm_string_length (required_vtable_fields),
                              scm_string_length (olayout)))
      && scm_is_true (scm_string_eq (olayout, required_vtable_fields,
                                     scm_from_size_t (0),
                                     scm_string_length (required_vtable_fields),
                                     scm_from_size_t (0),
                                     scm_string_length (required_vtable_fields))))
    SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_VTABLE);

  /* Finally, if OBJ is an applicable class, verify that its vtable is
     compatible with the required applicable layout.  */
  if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SETTER_VTABLE))
    {
      if (scm_is_false (scm_string_eq (olayout, required_applicable_with_setter_fields,
                                       scm_from_size_t (0),
                                       scm_from_size_t (4),
                                       scm_from_size_t (0),
                                       scm_from_size_t (4))))
        scm_misc_error (FUNC_NAME, "invalid applicable-with-setter struct layout",
                        scm_list_1 (olayout));
      SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_APPLICABLE | SCM_VTABLE_FLAG_SETTER);
    }
  else if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_APPLICABLE_VTABLE))
    {
      if (scm_is_false (scm_string_eq (olayout, required_applicable_fields,
                                       scm_from_size_t (0),
                                       scm_from_size_t (2),
                                       scm_from_size_t (0),
                                       scm_from_size_t (2))))
        scm_misc_error (FUNC_NAME, "invalid applicable struct layout",
                        scm_list_1 (olayout));
      SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_APPLICABLE);
    }
}
#undef FUNC_NAME

static void
scm_struct_init (SCM handle, SCM layout, size_t n_tail,
                 size_t n_inits, scm_t_bits *inits)
{
  SCM vtable;
  scm_t_bits *mem;

  vtable = SCM_STRUCT_VTABLE (handle);
  mem = SCM_STRUCT_DATA (handle);

  if (SCM_UNPACK (vtable) != 0
      && SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)
      && n_tail == 0
      && n_inits == SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size))
    /* The fast path: HANDLE has N_INITS "p" fields.  */
    memcpy (mem, inits, n_inits * sizeof (SCM));
  else
    {
      scm_t_wchar prot = 0;
      int n_fields = scm_i_symbol_length (layout) / 2;
      int tailp = 0;
      int i;
      size_t inits_idx = 0;

      i = -2;
      while (n_fields)
	{
	  if (!tailp)
	    {
	      i += 2;
	      prot = scm_i_symbol_ref (layout, i+1);
	      if (SCM_LAYOUT_TAILP (prot))
		{
		  tailp = 1;
		  prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o';
		  *mem++ = (scm_t_bits)n_tail;
		  n_fields += n_tail - 1;
		  if (n_fields == 0)
		    break;
		}
	    }
	  switch (scm_i_symbol_ref (layout, i))
	    {
	    case 'u':
	      if ((prot != 'r' && prot != 'w') || inits_idx == n_inits)
		*mem = 0;
	      else
		{
		  *mem = scm_to_ulong (SCM_PACK (inits[inits_idx]));
		  inits_idx++;
		}
	      break;

	    case 'p':
	      if ((prot != 'r' && prot != 'w') || inits_idx == n_inits)
		*mem = SCM_UNPACK (SCM_BOOL_F);
	      else
		{
		  *mem = inits[inits_idx];
		  inits_idx++;
		}

	      break;

	    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
{
  return scm_from_bool
    (SCM_STRUCTP (x)
     && SCM_STRUCT_VTABLE_FLAG_IS_SET (x, SCM_VTABLE_FLAG_VTABLE));
}
#undef FUNC_NAME

/* Finalization: invoke the finalizer of the struct pointed to by PTR.  */
static void
struct_finalizer_trampoline (GC_PTR ptr, GC_PTR unused_data)
{
  SCM obj = PTR2SCM (ptr);
  scm_t_struct_finalize finalize = SCM_STRUCT_FINALIZER (obj);

  if (finalize)
    finalize (obj);
}

/* 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.

   I suppose we should make it clear here that, the data must be 8-byte aligned,
   *within* the struct, and the struct itself should be 8-byte aligned. In
   practice we ensure this because the data starts two words into a struct.

   This function allocates an 8-byte aligned block of memory, whose first word
   points to the given vtable data, then a data pointer, then n_words of data.
 */
SCM
scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words)
{
  SCM ret;

  ret = scm_words ((scm_t_bits)vtable_data | scm_tc3_struct, n_words + 2);
  SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)SCM_CELL_OBJECT_LOC (ret, 2));

  /* vtable_data can be null when making a vtable vtable */
  if (vtable_data && vtable_data[scm_vtable_index_instance_finalize])
    {
      /* Register a finalizer for the newly created instance.  */
      GC_finalization_proc prev_finalizer;
      GC_PTR prev_finalizer_data;
      GC_REGISTER_FINALIZER_NO_ORDER (SCM2PTR (ret),
				      struct_finalizer_trampoline,
				      NULL,
				      &prev_finalizer,
				      &prev_finalizer_data);
    }

  return ret;
}

SCM
scm_c_make_structv (SCM vtable, size_t n_tail, size_t n_init, scm_t_bits *init)
#define FUNC_NAME "make-struct"
{
  SCM layout;
  size_t basic_size;
  SCM obj;

  SCM_VALIDATE_VTABLE (1, vtable);

  layout = SCM_VTABLE_LAYOUT (vtable);
  basic_size = scm_i_symbol_length (layout) / 2;

  if (n_tail != 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;
    }

  obj = scm_i_alloc_struct (SCM_STRUCT_DATA (vtable), basic_size + n_tail);

  scm_struct_init (obj, layout, n_tail, n_init, init);

  /* only check things and inherit magic if the layout was passed as an initarg.
     something of a hack, but it's for back-compatibility. */
  if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_VTABLE)
      && scm_is_true (SCM_VTABLE_LAYOUT (obj)))
    scm_i_struct_inherit_vtable_magic (vtable, obj);

  return obj;
}
#undef FUNC_NAME

SCM
scm_c_make_struct (SCM vtable, size_t n_tail, size_t n_init, scm_t_bits init, ...)
{
  va_list foo;
  scm_t_bits *v;
  size_t i;

  v = alloca (sizeof (scm_t_bits) * n_init);

  va_start (foo, init);
  for (i = 0; i < n_init; i++)
    {
      v[i] = init;
      init = va_arg (foo, scm_t_bits);
    }
  va_end (foo);

  return scm_c_make_structv (vtable, n_tail, n_init, v);
}

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"
	    "For more information, see the documentation for @code{make-vtable-vtable}.")
#define FUNC_NAME s_scm_make_struct
{
  size_t i, n_init;
  long ilen;
  scm_t_bits *v;

  SCM_VALIDATE_VTABLE (1, vtable);
  ilen = scm_ilength (init);
  if (ilen < 0)
    SCM_MISC_ERROR ("Rest arguments do not form a proper list.", SCM_EOL);

  n_init = (size_t)ilen;

  /* best to use alloca, but init could be big, so hack to avoid a possible
     stack overflow */
  if (n_init < 64)
    v = alloca (n_init * sizeof(scm_t_bits));
  else
    v = scm_gc_malloc (n_init * sizeof(scm_t_bits), "struct");

  for (i = 0; i < n_init; i++, init = SCM_CDR (init))
    v[i] = SCM_UNPACK (SCM_CAR (init));

  return scm_c_make_structv (vtable, scm_to_size_t (tail_array_size), n_init, v);
}
#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, layout, obj;
  size_t basic_size, n_tail, i, n_init;
  long ilen;
  scm_t_bits *v;

  SCM_VALIDATE_STRING (1, user_fields);
  ilen = scm_ilength (init);
  if (ilen < 0)
    SCM_MISC_ERROR ("Rest arguments do not form a proper list.", SCM_EOL);

  n_init = (size_t)ilen + 1; /* + 1 for the layout */

  /* best to use alloca, but init could be big, so hack to avoid a possible
     stack overflow */
  if (n_init < 64)
    v = alloca (n_init * sizeof(scm_t_bits));
  else
    v = scm_gc_malloc (n_init * sizeof(scm_t_bits), "struct");

  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;
  n_tail = scm_to_size_t (tail_array_size);

  i = 0;
  v[i++] = SCM_UNPACK (layout);
  for (; i < n_init; i++, init = SCM_CDR (init))
    v[i] = SCM_UNPACK (SCM_CAR (init));

  SCM_CRITICAL_SECTION_START;
  obj = scm_i_alloc_struct (NULL, basic_size + n_tail);
  /* Make it so that the vtable of OBJ is itself.  */
  SCM_SET_CELL_WORD_0 (obj, (scm_t_bits) SCM_STRUCT_DATA (obj) | scm_tc3_struct);
  SCM_CRITICAL_SECTION_END;

  scm_struct_init (obj, layout, n_tail, n_init, v);
  SCM_SET_VTABLE_FLAGS (obj, SCM_VTABLE_FLAG_VTABLE);

  return obj;
}
#undef FUNC_NAME

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_standard_vtable_vtable, 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),
	    "Access 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 vtable, answer = SCM_UNDEFINED;
  scm_t_bits *data;
  size_t p;

  SCM_VALIDATE_STRUCT (1, handle);

  vtable = SCM_STRUCT_VTABLE (handle);
  data = SCM_STRUCT_DATA (handle);
  p = scm_to_size_t (pos);

  if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)
  		  && p < SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size)))
    /* The fast path: HANDLE is a struct with only "p" fields.  */
    answer = SCM_PACK (data[p]);
  else
    {
      SCM layout;
      size_t layout_len, n_fields;
      scm_t_wchar field_type = 0;

      layout = SCM_STRUCT_LAYOUT (handle);
      layout_len = scm_i_symbol_length (layout);
      n_fields = layout_len / 2;

      if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout, layout_len - 1)))
	n_fields += data[n_fields - 1];

      SCM_ASSERT_RANGE (1, pos, p < n_fields);

      if (p * 2 < layout_len)
	{
	  scm_t_wchar ref;
	  field_type = scm_i_symbol_ref (layout, p * 2);
	  ref = scm_i_symbol_ref (layout, p * 2 + 1);
	  if ((ref != 'r') && (ref != 'w') && (ref != 'h'))
	    {
	      if ((ref == 'R') || (ref == 'W'))
		field_type = 'u';
	      else
		SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos));
	    }
	}
      else if (scm_i_symbol_ref (layout, layout_len - 1) != 'O')
	field_type = scm_i_symbol_ref(layout, 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 vtable;
  scm_t_bits *data;
  size_t p;

  SCM_VALIDATE_STRUCT (1, handle);

  vtable = SCM_STRUCT_VTABLE (handle);
  data = SCM_STRUCT_DATA (handle);
  p = scm_to_size_t (pos);

  if (SCM_LIKELY (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE)
  		  && SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_SIMPLE_RW)
  		  && p < SCM_STRUCT_DATA_REF (vtable, scm_vtable_index_size)))
    /* The fast path: HANDLE is a struct with only "pw" fields.  */
    data[p] = SCM_UNPACK (val);
  else
    {
      SCM layout;
      size_t layout_len, n_fields;
      scm_t_wchar field_type = 0;

      layout = SCM_STRUCT_LAYOUT (handle);
      layout_len = scm_i_symbol_length (layout);
      n_fields = layout_len / 2;

      if (SCM_LAYOUT_TAILP (scm_i_symbol_ref (layout, layout_len - 1)))
	n_fields += data[n_fields - 1];

      SCM_ASSERT_RANGE (1, pos, p < n_fields);

      if (p * 2 < layout_len)
	{
	  char set_x;
	  field_type = scm_i_symbol_ref (layout, p * 2);
	  set_x = scm_i_symbol_ref (layout, p * 2 + 1);
	  if (set_x != 'w' && set_x != 'h')
	    SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos));
	}
      else if (scm_i_symbol_ref (layout, layout_len - 1) == 'W')
	field_type = scm_i_symbol_ref (layout, 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, void *closure)
{
  /* 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_t_assoc_fn) 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);
          scm_putc (' ', port);
        }
      else
	{
          if (SCM_VTABLE_FLAG_IS_SET (vtable, SCM_VTABLE_FLAG_VTABLE))
            scm_puts ("vtable:", port);
          else
            scm_puts ("struct:", port);
          scm_uintprint (SCM_UNPACK (vtable), 16, port);
          scm_putc (' ', port);
          scm_write (SCM_VTABLE_LAYOUT (vtable), port);
          scm_putc (' ', port);
        }
      scm_uintprint (SCM_UNPACK (exp), 16, port);
      /* hackety hack */
      if (SCM_STRUCT_APPLICABLE_P (exp))
        {
          if (scm_is_true (SCM_STRUCT_PROCEDURE (exp)))
            {
              scm_puts (" proc: ", port);
              if (scm_is_true (scm_procedure_p (SCM_STRUCT_PROCEDURE (exp))))
                scm_write (SCM_STRUCT_PROCEDURE (exp), port);
              else
                scm_puts ("(not a procedure?)", port);
            }
          if (SCM_STRUCT_SETTER_P (exp))
            {
              scm_puts (" setter: ", port);
              scm_write (SCM_STRUCT_SETTER (exp), port);
            }
        }
      scm_putc ('>', port);
    }
}

void
scm_init_struct ()
{
  /* The first word of a struct is equal to `SCM_STRUCT_DATA (vtable) +
     scm_tc3_struct', and `SCM_STRUCT_DATA (vtable)' is 2 words after VTABLE by
     default.  */
  GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits) + scm_tc3_struct);

  /* In the general case, `SCM_STRUCT_DATA (obj)' points 2 words after the
     beginning of a GC-allocated region; that region is different from that of
     OBJ once OBJ has undergone class redefinition.  */
  GC_REGISTER_DISPLACEMENT (2 * sizeof (scm_t_bits));

  scm_struct_table = scm_make_weak_key_hash_table (scm_from_int (31));
  required_vtable_fields = scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT);
  required_applicable_fields = scm_from_locale_string (SCM_APPLICABLE_BASE_LAYOUT);
  required_applicable_with_setter_fields = scm_from_locale_string (SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT);

  scm_standard_vtable_vtable =
    scm_make_vtable_vtable (scm_nullstr, SCM_INUM0, SCM_EOL);

  scm_applicable_struct_vtable_vtable =
    scm_make_struct (scm_standard_vtable_vtable, SCM_INUM0,
                     scm_list_1 (scm_make_struct_layout (required_vtable_fields)));
  SCM_SET_VTABLE_FLAGS (scm_applicable_struct_vtable_vtable,
                        SCM_VTABLE_FLAG_APPLICABLE_VTABLE);
  scm_c_define ("<applicable-struct-vtable>", scm_applicable_struct_vtable_vtable);

  scm_applicable_struct_with_setter_vtable_vtable =
    scm_make_struct (scm_standard_vtable_vtable, SCM_INUM0,
                     scm_list_1 (scm_make_struct_layout (required_vtable_fields)));
  SCM_SET_VTABLE_FLAGS (scm_applicable_struct_with_setter_vtable_vtable,
                        SCM_VTABLE_FLAG_APPLICABLE_VTABLE | SCM_VTABLE_FLAG_SETTER_VTABLE);
  scm_c_define ("<applicable-struct-with-setter-vtable>", scm_applicable_struct_with_setter_vtable_vtable);

  scm_c_define ("vtable-index-layout", scm_from_int (scm_vtable_index_layout));
  scm_c_define ("vtable-index-printer",
		scm_from_int (scm_vtable_index_instance_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, 2008, 2009, 2010 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 3 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"

/* The relationship between a struct and its vtable is a bit complicated,
   because we want structs to be used as GOOPS' native representation -- which
   in turn means we need support for changing the "class" (vtable) of an
   "instance" (struct). This necessitates some indirection and trickery.

   To summarize, structs are laid out this way:

                  .-------.
                  |       |
     .----------------+---v------------- -
     | vtable | data  | slot0 | slot1 |
     `----------------+----------------- -
         |        .-------.
         |        |       |
     .---v------------+---v------------- -
     | vtable | data  | slot0 | slot1 |
     `----------------+----------------- -
         |
         v

        ...
                  .-------.
         |        |       |
     .---v------------+---v------------- -
   .-| vtable | data  | slot0 | slot1 |
   | `----------------+----------------- -
   |     ^
   `-----'

   The DATA indirection (which corresponds to `SCM_STRUCT_DATA ()') is necessary
   to implement class redefinition.

   For more details, see:

     http://wingolog.org/archives/2009/11/09/class-redefinition-in-guile

 */

/* All vtables have the following fields. */
#define SCM_VTABLE_BASE_LAYOUT                                          \
  "pr" /* layout */                                                     \
  "uh" /* flags */							\
  "sr" /* self */                                                       \
  "uh" /* finalizer */                                                  \
  "pw" /* printer */                                                    \
  "ph" /* name (hidden from make-struct for back-compat reasons) */     \
  "uh" /* size */							\
  "uh" /* reserved */

#define scm_vtable_index_layout            0 /* A symbol describing the physical arrangement of this type. */
#define scm_vtable_index_flags	           1 /* Class flags */
#define scm_vtable_index_self	           2 /* A pointer to the vtable itself */
#define scm_vtable_index_instance_finalize 3 /* Finalizer for instances of this struct type. */
#define scm_vtable_index_instance_printer  4 /* A printer for this struct type. */
#define scm_vtable_index_name              5 /* Name of this vtable. */
#define scm_vtable_index_size              6 /* Number of fields, for simple structs.  */
#define scm_vtable_index_reserved_7        7
#define scm_vtable_offset_user             8 /* Where do user fields start in the vtable? */

/* All applicable structs have the following fields. */
#define SCM_APPLICABLE_BASE_LAYOUT              \
  "pw" /* procedure */
#define SCM_APPLICABLE_WITH_SETTER_BASE_LAYOUT  \
  "pw" /* procedure */                          \
  "pw" /* setter */
#define scm_applicable_struct_index_procedure 0 /* The procedure of an applicable
                                                   struct. Only valid if the
                                                   struct's vtable has the
                                                   applicable flag set. */
#define scm_applicable_struct_index_setter    1 /* The setter of an applicable
                                                   struct. Only valid if the
                                                   struct's vtable has the
                                                   setter flag set. */

#define SCM_VTABLE_FLAG_VTABLE (1L << 0) /* instances of this vtable are themselves vtables? */
#define SCM_VTABLE_FLAG_APPLICABLE_VTABLE (1L << 1) /* instances of this vtable are applicable vtables? */
#define SCM_VTABLE_FLAG_APPLICABLE (1L << 2) /* instances of this vtable are applicable? */
#define SCM_VTABLE_FLAG_SETTER_VTABLE (1L << 3) /* instances of this vtable are applicable-with-setter vtables? */
#define SCM_VTABLE_FLAG_SETTER (1L << 4) /* instances of this vtable are applicable-with-setters? */
#define SCM_VTABLE_FLAG_SIMPLE (1L << 5) /* instances of this vtable have only "p" fields */
#define SCM_VTABLE_FLAG_SIMPLE_RW (1L << 6) /* instances of this vtable have only "pw" fields */
#define SCM_VTABLE_FLAG_SMOB_0 (1L << 7)
#define SCM_VTABLE_FLAG_GOOPS_0 (1L << 8)
#define SCM_VTABLE_FLAG_GOOPS_1 (1L << 9)
#define SCM_VTABLE_FLAG_GOOPS_2 (1L << 10)
#define SCM_VTABLE_FLAG_GOOPS_3 (1L << 11)
#define SCM_VTABLE_FLAG_GOOPS_4 (1L << 12)
#define SCM_VTABLE_FLAG_GOOPS_5 (1L << 13)
#define SCM_VTABLE_FLAG_GOOPS_6 (1L << 14)
#define SCM_VTABLE_FLAG_GOOPS_7 (1L << 15)
#define SCM_VTABLE_USER_FLAG_SHIFT 16

typedef void (*scm_t_struct_finalize) (SCM obj);

#define SCM_STRUCTP(X)  		(!SCM_IMP(X) && (SCM_TYP3(X) == scm_tc3_struct))
#define SCM_STRUCT_SLOTS(X) 		((SCM*)SCM_CELL_WORD_1 ((X)))
#define SCM_STRUCT_SLOT_REF(X,I) 	(SCM_STRUCT_SLOTS (X)[(I)])
#define SCM_STRUCT_SLOT_SET(X,I,V) 	SCM_STRUCT_SLOTS (X)[(I)]=(V)
#define SCM_STRUCT_DATA(X) 		((scm_t_bits*)SCM_CELL_WORD_1 (X))
#define SCM_STRUCT_DATA_REF(X,I) 	(SCM_STRUCT_DATA (X)[(I)])
#define SCM_STRUCT_DATA_SET(X,I,V) 	SCM_STRUCT_DATA (X)[(I)]=(V)

/* The SCM_VTABLE_* macros assume that you're passing them a struct which is a
   valid vtable. */
#define SCM_VTABLE_LAYOUT(X)            (SCM_STRUCT_SLOT_REF ((X), scm_vtable_index_layout))
#define SCM_SET_VTABLE_LAYOUT(X,L)      (SCM_STRUCT_SLOT_SET ((X), scm_vtable_index_layout, L))
#define SCM_VTABLE_FLAGS(X)             (SCM_STRUCT_DATA_REF (X, scm_vtable_index_flags))
#define SCM_SET_VTABLE_FLAGS(X,F)       (SCM_STRUCT_DATA_REF (X, scm_vtable_index_flags) |= (F))
#define SCM_CLEAR_VTABLE_FLAGS(X,F)     (SCM_STRUCT_DATA_REF (X, scm_vtable_index_flags) &= (~(F)))
#define SCM_VTABLE_FLAG_IS_SET(X,F)     (SCM_STRUCT_DATA_REF (X, scm_vtable_index_flags) & (F))
#define SCM_VTABLE_INSTANCE_FINALIZER(X) ((scm_t_struct_finalize)SCM_STRUCT_DATA_REF (X, scm_vtable_index_instance_finalize))
#define SCM_SET_VTABLE_INSTANCE_FINALIZER(X,P) (SCM_STRUCT_DATA_SET (X, scm_vtable_index_instance_finalize, (scm_t_bits)(P)))
#define SCM_VTABLE_INSTANCE_PRINTER(X)  (SCM_STRUCT_SLOT_REF (X, scm_vtable_index_instance_printer))
#define SCM_SET_VTABLE_INSTANCE_PRINTER(X,P) (SCM_STRUCT_SLOT_SET (X, scm_vtable_index_instance_printer, (P)))
#define SCM_VTABLE_NAME(X)              (SCM_STRUCT_SLOT_REF (X, scm_vtable_index_name))
#define SCM_SET_VTABLE_NAME(X,V)        (SCM_STRUCT_SLOT_SET (X, scm_vtable_index_name, V))

/* Structs hold a pointer to their vtable's data, not the vtable itself. To get
   the vtable we have to do an indirection through the self slot. */
#define SCM_STRUCT_VTABLE_DATA(X)       ((scm_t_bits*)(SCM_CELL_WORD_0 (X) - scm_tc3_struct))
#define SCM_STRUCT_VTABLE_SLOTS(X)      ((SCM*)(SCM_CELL_WORD_0 (X) - scm_tc3_struct))
#define SCM_STRUCT_VTABLE(X)            (SCM_STRUCT_VTABLE_SLOTS(X)[scm_vtable_index_self])
/* But often we just need to access the vtable's data; we can do that without
   the data->self->data indirection. */
#define SCM_STRUCT_LAYOUT(X) 	        (SCM_STRUCT_VTABLE_SLOTS (X)[scm_vtable_index_layout])
#define SCM_STRUCT_PRINTER(X) 	        (SCM_STRUCT_VTABLE_SLOTS (X)[scm_vtable_index_instance_printer])
#define SCM_STRUCT_FINALIZER(X)         ((scm_t_struct_finalize)SCM_STRUCT_VTABLE_DATA (X)[scm_vtable_index_instance_finalize])
#define SCM_STRUCT_VTABLE_FLAGS(X) 	(SCM_STRUCT_VTABLE_DATA (X)[scm_vtable_index_flags])
#define SCM_STRUCT_VTABLE_FLAG_IS_SET(X,F) (SCM_STRUCT_VTABLE_DATA (X)[scm_vtable_index_flags]&(F))

#define SCM_STRUCT_APPLICABLE_P(X) 	(SCM_STRUCT_VTABLE_FLAG_IS_SET ((X), SCM_VTABLE_FLAG_APPLICABLE))
#define SCM_STRUCT_SETTER_P(X) 	        (SCM_STRUCT_VTABLE_FLAG_IS_SET ((X), SCM_VTABLE_FLAG_SETTER))
#define SCM_STRUCT_PROCEDURE(X) 	(SCM_STRUCT_SLOT_REF (X, scm_applicable_struct_index_procedure))
#define SCM_SET_STRUCT_PROCEDURE(X,P) 	(SCM_STRUCT_SLOT_SET (X, scm_applicable_struct_index_procedure, P))
#define SCM_STRUCT_SETTER(X)            (SCM_STRUCT_SLOT_REF (X, scm_applicable_struct_index_setter))
#define SCM_SET_STRUCT_SETTER(X,P) 	(SCM_STRUCT_SLOT_SET (X, scm_applicable_struct_index_setter, P))

#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;

SCM_API SCM scm_standard_vtable_vtable;
SCM_API SCM scm_applicable_struct_vtable_vtable;
SCM_API SCM scm_applicable_struct_with_setter_vtable_vtable;

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_c_make_struct (SCM vtable, size_t n_tail, size_t n_inits,
                               scm_t_bits init, ...);
SCM_API SCM scm_c_make_structv (SCM vtable, size_t n_tail, size_t n_inits,
                                scm_t_bits 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_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 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_INTERNAL SCM scm_i_struct_equalp (SCM s1, SCM s2);
SCM_INTERNAL unsigned long scm_struct_ihashq (SCM, unsigned long, void *);
SCM_INTERNAL SCM scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words);
SCM_INTERNAL void scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj);
SCM_INTERNAL 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 3 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"

#include "libguile/private-options.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 (SCM name, unsigned long raw_hash)
{
  /* Try to find the symbol in the symbols table */
  SCM result = SCM_BOOL_F;
  SCM bucket, elt, previous_elt;
  size_t len;
  unsigned long hash = raw_hash % SCM_HASHTABLE_N_BUCKETS (symbols);

  len = scm_i_string_length (name);
  bucket = SCM_HASHTABLE_BUCKET (symbols, hash);

  for (elt = bucket, previous_elt = SCM_BOOL_F;
       !scm_is_null (elt);
       previous_elt = elt, elt = SCM_CDR (elt))
    {
      SCM pair, sym;

      pair = SCM_CAR (elt);
      if (!scm_is_pair (pair))
	abort ();

      if (SCM_WEAK_PAIR_CAR_DELETED_P (pair))
	{
	  /* PAIR is a weak pair whose key got nullified: remove it from
	     BUCKET.  */
	  /* FIXME: Since this is done lazily, i.e., only when a new symbol
	     is to be inserted in a bucket containing deleted symbols, the
	     number of items in the hash table may remain erroneous for some
	     time, thus precluding proper rehashing.  */
	  if (previous_elt != SCM_BOOL_F)
	    SCM_SETCDR (previous_elt, SCM_CDR (elt));
	  else
	    bucket = SCM_CDR (elt);

	  SCM_HASHTABLE_DECREMENT (symbols);
	  continue;
	}

      sym = SCM_CAR (pair);

      if (scm_i_symbol_hash (sym) == raw_hash
	  && scm_i_symbol_length (sym) == len)
	{
          size_t i = len;

          /* Slightly faster path for comparing narrow to narrow.  */
          if (scm_i_is_narrow_string (name) && scm_i_is_narrow_symbol (sym))
            {
              const char *chrs = scm_i_symbol_chars (sym);
              const char *str = scm_i_string_chars (name);

              while (i != 0)
                {
                  --i;
                  if (str[i] != chrs[i])
                    goto next_symbol;
                }
            }
          else
            {
              /* Somewhat slower path for comparing narrow to wide or
                 wide to wide.  */
              while (i != 0)
                {
                  --i;
                  if (scm_i_string_ref (name, i) != scm_i_symbol_ref (sym, i))
                    goto next_symbol;
                }
            }

	  /* We found it.  */
	  result = sym;
	  break;
	}
    next_symbol:
      ;
    }

  if (SCM_HASHTABLE_N_ITEMS (symbols) < SCM_HASHTABLE_LOWER (symbols))
    /* We removed many symbols in this pass so trigger a rehashing.  */
    scm_i_rehash (symbols, scm_i_hash_symbol, 0, "lookup_interned_symbol");

  return result;
}

/* 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_str2symbol (SCM str)
{
  SCM symbol;
  size_t raw_hash = scm_i_string_hash (str);

  symbol = lookup_interned_symbol (str, 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_str2uninterned_symbol (SCM str)
{
  size_t raw_hash = scm_i_string_hash (str);

  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_str2uninterned_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_str2symbol (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_from_locale_symboln (sym, -1);
}

SCM
scm_from_locale_symboln (const char *sym, size_t len)
{
  SCM str = scm_from_locale_stringn (sym, len);
  return scm_i_str2symbol (str);
}

SCM
scm_take_locale_symboln (char *sym, size_t len)
{
  SCM str;

  str = scm_take_locale_stringn (sym, len);
  return scm_i_str2symbol (str);
}

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));
}

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

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