code:
/* Copyright (C) 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 "libguile/_scm.h"
#include "libguile/extensions.h"
#include "libguile/feature.h"
#include "libguile/i18n.h"
#include "libguile/strings.h"
#include "libguile/chars.h"
#include "libguile/dynwind.h"
#include "libguile/validate.h"
#include "libguile/values.h"
#include "libguile/threads.h"

#include <locale.h>
#include <string.h> /* `strcoll ()' */
#include <ctype.h>  /* `toupper ()' et al. */
#include <errno.h>
#include <unicase.h>
#include <unistr.h>

#if (defined HAVE_NEWLOCALE) && (defined HAVE_STRCOLL_L)
/* The GNU thread-aware locale API is documented in ``Thread-Aware Locale
   Model, a Proposal'', by Ulrich Drepper:

     http://people.redhat.com/drepper/tllocale.ps.gz

   It is now also implemented by Darwin:

     http://developer.apple.com/documentation/Darwin/Reference/ManPages/man3/newlocale.3.html

   The whole API was eventually standardized in the ``Open Group Base
   Specifications Issue 7'' (aka. "POSIX 2008"):

     http://www.opengroup.org/onlinepubs/9699919799/basedefs/locale.h.html  */
# define USE_GNU_LOCALE_API
#endif

#include "libguile/posix.h"  /* for `scm_i_locale_mutex' */

#ifdef HAVE_LANGINFO_H
# include <langinfo.h>
#endif
#ifdef HAVE_NL_TYPES_H
# include <nl_types.h>
#endif
#ifndef HAVE_NL_ITEM
/* Cygwin has <langinfo.h> but lacks <nl_types.h> and `nl_item'.  */
typedef int nl_item;
#endif

#ifndef HAVE_SETLOCALE
static inline char *
setlocale (int category, const char *name)
{
  errno = ENOSYS;
  return NULL;
}
#endif

/* Helper stringification macro.  */
#define SCM_I18N_STRINGIFY(_name)   # _name

/* Locale objects, string and character collation, and other locale-dependent
   string operations.

   A large part of the code here deals with emulating glibc's reentrant
   locale API on non-GNU systems.  The emulation is a bit "brute-force":
   Whenever a `-locale<?' procedure is passed a locale object, then:

   1. The `scm_i_locale_mutex' is locked.
   2. A series of `setlocale ()' call is performed to store the current
      locale for each category in an `scm_t_locale' object.
   3. A series of `setlocale ()' call is made to install each of the locale
      categories of each of the base locales of each locale object,
      recursively, starting from the last locale object of the chain.
   4. The settings captured in step (2) are restored.
   5. The `scm_i_locale_mutex' is released.

   Hopefully, the X/Open standard will eventually make this hack useless.

   Note: We don't wrap glibc's `uselocale ()' call because it sets the locale
   of the current _thread_ (unlike `setlocale ()') and doing so would require
   maintaining per-thread locale information on non-GNU systems and always
   re-installing this locale upon locale-dependent calls.  */

/* Return the category mask corresponding to CAT.  */
#define SCM_LOCALE_CATEGORY_MASK(_cat)    LC_ ## _cat ## _MASK

#ifndef USE_GNU_LOCALE_API

/* Provide the locale category masks as found in glibc.  This must be kept in
   sync with `locale-categories.h'.  */

# define LC_CTYPE_MASK		1
# define LC_COLLATE_MASK	2
# define LC_MESSAGES_MASK	4
# define LC_MONETARY_MASK	8
# define LC_NUMERIC_MASK	16
# define LC_TIME_MASK		32

# ifdef LC_PAPER
#   define LC_PAPER_MASK	64
# else
#   define LC_PAPER_MASK	0
# endif
# ifdef LC_NAME
#   define LC_NAME_MASK		128
# else
#   define LC_NAME_MASK		0
# endif
# ifdef LC_ADDRESS
#   define LC_ADDRESS_MASK	256
# else
#   define LC_ADDRESS_MASK	0
# endif
# ifdef LC_TELEPHONE
#   define LC_TELEPHONE_MASK	512
# else
#   define LC_TELEPHONE_MASK	0
# endif
# ifdef LC_MEASUREMENT
#   define LC_MEASUREMENT_MASK	1024
# else
#   define LC_MEASUREMENT_MASK	0
# endif
# ifdef LC_IDENTIFICATION
#   define LC_IDENTIFICATION_MASK 2048
# else
#   define LC_IDENTIFICATION_MASK 0
# endif

# define LC_ALL_MASK		(LC_CTYPE_MASK			\
				 | LC_NUMERIC_MASK		\
				 | LC_TIME_MASK			\
				 | LC_COLLATE_MASK		\
				 | LC_MONETARY_MASK		\
				 | LC_MESSAGES_MASK		\
				 | LC_PAPER_MASK		\
				 | LC_NAME_MASK			\
				 | LC_ADDRESS_MASK		\
				 | LC_TELEPHONE_MASK		\
				 | LC_MEASUREMENT_MASK		\
				 | LC_IDENTIFICATION_MASK	\
				 )

/* Locale objects as returned by `make-locale' on non-GNU systems.  */
typedef struct scm_locale
{
  SCM   base_locale; /* a `locale' object */
  char *locale_name;
  int   category_mask;
} *scm_t_locale;

/* Free the resources used by LOCALE.  */
static inline void
scm_i_locale_free (scm_t_locale locale)
{
  free (locale->locale_name);
  locale->locale_name = NULL;
}

#else /* USE_GNU_LOCALE_API */

/* Alias for glibc's locale type.  */
typedef locale_t scm_t_locale;

#define scm_i_locale_free freelocale

#endif /* USE_GNU_LOCALE_API */

/* A locale object denoting the global locale.  */
SCM_GLOBAL_VARIABLE (scm_global_locale, "%global-locale");

/* Validate parameter ARG as a locale object and set C_LOCALE to the
   corresponding C locale object.  */
#define SCM_VALIDATE_LOCALE_COPY(_pos, _arg, _c_locale)		\
  do								\
    {								\
      SCM_VALIDATE_SMOB ((_pos), (_arg), locale_smob_type);	\
      (_c_locale) = (scm_t_locale)SCM_SMOB_DATA (_arg);		\
    }								\
  while (0)

/* Validate optional parameter ARG as either undefined or bound to a locale
   object.  Set C_LOCALE to the corresponding C locale object or NULL.  */
#define SCM_VALIDATE_OPTIONAL_LOCALE_COPY(_pos, _arg, _c_locale)	\
  do									\
    {									\
      if ((_arg) != SCM_UNDEFINED)					\
	SCM_VALIDATE_LOCALE_COPY (_pos, _arg, _c_locale);		\
      else								\
	(_c_locale) = NULL;						\
    }									\
  while (0)

SCM_SMOB (scm_tc16_locale_smob_type, "locale", 0);

SCM_SMOB_FREE (scm_tc16_locale_smob_type, smob_locale_free, locale)
{
  scm_t_locale c_locale;

  c_locale = (scm_t_locale) SCM_SMOB_DATA (locale);
  scm_i_locale_free (c_locale);

  return 0;
}

static void inline scm_locale_error (const char *, int) SCM_NORETURN;

/* Throw an exception corresponding to error ERR.  */
static void inline
scm_locale_error (const char *func_name, int err)
{
  scm_syserror_msg (func_name,
		    "Failed to install locale",
		    SCM_EOL, err);
}

/* Emulating GNU's reentrant locale API.  */
#ifndef USE_GNU_LOCALE_API

/* Maximum number of chained locales (via `base_locale').  */
#define LOCALE_STACK_SIZE_MAX  256

typedef struct
{
#define SCM_DEFINE_LOCALE_CATEGORY(_name)  char * _name;
#include "locale-categories.h"
#undef SCM_DEFINE_LOCALE_CATEGORY
} scm_t_locale_settings;

/* Fill out SETTINGS according to the current locale settings.  On success
   zero is returned and SETTINGS is properly initialized.  */
static int
get_current_locale_settings (scm_t_locale_settings *settings)
{
  const char *locale_name;

#define SCM_DEFINE_LOCALE_CATEGORY(_name)			\
  {								\
    SCM_SYSCALL (locale_name = setlocale (LC_ ## _name, NULL));	\
    if (locale_name == NULL)					\
      goto handle_error;					\
								\
    settings-> _name = strdup (locale_name);			\
    if (settings-> _name == NULL)				\
      goto handle_oom;						\
  }

#include "locale-categories.h"
#undef SCM_DEFINE_LOCALE_CATEGORY

  return 0;

 handle_error:
  return EINVAL;

 handle_oom:
  return ENOMEM;
}

/* Restore locale settings SETTINGS.  On success, return zero.  */
static int
restore_locale_settings (const scm_t_locale_settings *settings)
{
  const char *result;

#define SCM_DEFINE_LOCALE_CATEGORY(_name)				\
  SCM_SYSCALL (result = setlocale (LC_ ## _name, settings-> _name));	\
  if (result == NULL)							\
    goto handle_error;

#include "locale-categories.h"
#undef SCM_DEFINE_LOCALE_CATEGORY

  return 0;

 handle_error:
  return EINVAL;
}

/* Free memory associated with SETTINGS.  */
static void
free_locale_settings (scm_t_locale_settings *settings)
{
#define SCM_DEFINE_LOCALE_CATEGORY(_name)	\
  free (settings-> _name);			\
  settings->_name = NULL;
#include  "locale-categories.h"
#undef SCM_DEFINE_LOCALE_CATEGORY
}

/* Install the locale named LOCALE_NAME for all the categories listed in
   CATEGORY_MASK.  */
static int
install_locale_categories (const char *locale_name, int category_mask)
{
  const char *result;

  if (category_mask == LC_ALL_MASK)
    {
      SCM_SYSCALL (result = setlocale (LC_ALL, locale_name));
      if (result == NULL)
	goto handle_error;
    }
  else
    {
#define SCM_DEFINE_LOCALE_CATEGORY(_name)				\
  if (category_mask & SCM_LOCALE_CATEGORY_MASK (_name))			\
    {									\
      SCM_SYSCALL (result = setlocale (LC_ ## _name, locale_name));	\
      if (result == NULL)						\
	goto handle_error;						\
    }
#include "locale-categories.h"
#undef SCM_DEFINE_LOCALE_CATEGORY
    }

  return 0;

 handle_error:
  return EINVAL;
}

/* Install LOCALE, recursively installing its base locales first.  On
   success, zero is returned.  */
static int
install_locale (scm_t_locale locale)
{
  scm_t_locale stack[LOCALE_STACK_SIZE_MAX];
  int category_mask = 0;
  size_t stack_size = 0;
  int stack_offset = 0;
  const char *result = NULL;

  /* Build up a locale stack by traversing the `base_locale' link.  */
  do
    {
      if (stack_size >= LOCALE_STACK_SIZE_MAX)
	/* We cannot use `scm_error ()' here because otherwise the locale
	   mutex may remain locked.  */
	return EINVAL;

      stack[stack_size++] = locale;

      /* Keep track of which categories have already been taken into
	 account.  */
      category_mask |= locale->category_mask;

      if (locale->base_locale != SCM_UNDEFINED)
	locale = (scm_t_locale) SCM_SMOB_DATA (locale->base_locale);
      else
	locale = NULL;
    }
  while ((locale != NULL) && (category_mask != LC_ALL_MASK));

  /* Install the C locale to start from a pristine state.  */
  SCM_SYSCALL (result = setlocale (LC_ALL, "C"));
  if (result == NULL)
    goto handle_error;

  /* Install the locales in reverse order.  */
  for (stack_offset = stack_size - 1;
       stack_offset >= 0;
       stack_offset--)
    {
      int err;
      scm_t_locale locale;

      locale = stack[stack_offset];
      err = install_locale_categories (locale->locale_name,
				       locale->category_mask);
      if (err)
	goto handle_error;
    }

  return 0;

 handle_error:
  return EINVAL;
}

/* Leave the locked locale section.  */
static inline void
leave_locale_section (const scm_t_locale_settings *settings)
{
  /* Restore the previous locale settings.  */
  (void)restore_locale_settings (settings);

  scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
}

/* Enter a locked locale section.  */
static inline int
enter_locale_section (scm_t_locale locale,
		      scm_t_locale_settings *prev_locale)
{
  int err;

  scm_i_pthread_mutex_lock (&scm_i_locale_mutex);

  err = get_current_locale_settings (prev_locale);
  if (err)
    {
      scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
      return err;
    }

  err = install_locale (locale);
  if (err)
    {
      leave_locale_section (prev_locale);
      free_locale_settings (prev_locale);
    }

  return err;
}

/* Convenient macro to run STATEMENT in the locale context of C_LOCALE.  */
#define RUN_IN_LOCALE_SECTION(_c_locale, _statement)			\
  do									\
   {									\
      int lsec_err;							\
      scm_t_locale_settings lsec_prev_locale;				\
									\
      lsec_err = enter_locale_section ((_c_locale), &lsec_prev_locale);	\
      if (lsec_err)							\
	scm_locale_error (FUNC_NAME, lsec_err);				\
      else								\
	{								\
	  _statement ;							\
									\
	  leave_locale_section (&lsec_prev_locale);			\
	  free_locale_settings (&lsec_prev_locale);			\
	}								\
   }									\
  while (0)

/* Convert the current locale settings into a locale SMOB.  On success, zero
   is returned and RESULT points to the new SMOB.  Otherwise, an error is
   returned.  */
static int
get_current_locale (SCM *result)
{
  int err = 0;
  scm_t_locale c_locale;
  const char *current_locale;

  c_locale = scm_gc_malloc (sizeof (* c_locale), "locale");

  scm_i_pthread_mutex_lock (&scm_i_locale_mutex);

  c_locale->category_mask = LC_ALL_MASK;
  c_locale->base_locale = SCM_UNDEFINED;

  current_locale = setlocale (LC_ALL, NULL);
  if (current_locale != NULL)
    {
      c_locale->locale_name = strdup (current_locale);
      if (c_locale->locale_name == NULL)
	err = ENOMEM;
    }
  else
    err = EINVAL;

  scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);

  if (err)
    scm_gc_free (c_locale, sizeof (* c_locale), "locale");
  else
    SCM_NEWSMOB (*result, scm_tc16_locale_smob_type, c_locale);

  return err;
}

#else /* USE_GNU_LOCALE_API */

/* Convenient macro to run STATEMENT in the locale context of C_LOCALE.  */
#define RUN_IN_LOCALE_SECTION(_c_locale, _statement)	\
  do							\
    {							\
      scm_t_locale old_loc;				\
							\
      old_loc = uselocale (_c_locale);			\
      _statement ;					\
      uselocale (old_loc);				\
    }							\
  while (0)

#endif /* USE_GNU_LOCALE_API */

/* `make-locale' can take either category lists or single categories (the
   `LC_*' integer constants).  */
#define SCM_LIST_OR_INTEGER_P(arg)				\
  (scm_is_integer (arg) || scm_is_true (scm_list_p (arg)))

/* Return the category mask corresponding to CATEGORY (an `LC_' integer
   constant).  */
static inline int
category_to_category_mask (SCM category,
			   const char *func_name, int pos)
{
  int c_category;
  int c_category_mask;

  c_category = scm_to_int (category);

#define SCM_DEFINE_LOCALE_CATEGORY(_name)			\
      case LC_ ## _name:					\
	c_category_mask = SCM_LOCALE_CATEGORY_MASK (_name);	\
	break;

  switch (c_category)
    {
#include "locale-categories.h"

    case LC_ALL:
      c_category_mask = LC_ALL_MASK;
      break;

    default:
      scm_wrong_type_arg_msg (func_name, pos, category,
			      "locale category");
    }

#undef SCM_DEFINE_LOCALE_CATEGORY

  return c_category_mask;
}

/* Convert CATEGORIES, a list of locale categories or a single category (an
   integer), into a category mask.  */
static int
category_list_to_category_mask (SCM categories,
				const char *func_name, int pos)
{
  int c_category_mask = 0;

  if (scm_is_integer (categories))
    c_category_mask = category_to_category_mask (categories,
						 func_name, pos);
  else
    for (; !scm_is_null (categories); categories = SCM_CDR (categories))
      {
	SCM category = SCM_CAR (categories);

	c_category_mask |=
	  category_to_category_mask (category, func_name, pos);
      }

  return c_category_mask;
}

SCM_DEFINE (scm_make_locale, "make-locale", 2, 1, 0,
	    (SCM category_list, SCM locale_name, SCM base_locale),
	    "Return a reference to a data structure representing a set of "
	    "locale datasets.  @var{category_list} should be either a list "
	    "of locale categories or a single category as used with "
	    "@code{setlocale} (@pxref{Locales, @code{setlocale}}) and "
	    "@var{locale_name} should be the name of the locale considered "
	    "(e.g., @code{\"sl_SI\"}).  Optionally, if @code{base_locale} is "
	    "passed, it should be a locale object denoting settings for "
	    "categories not listed in @var{category_list}.")
#define FUNC_NAME s_scm_make_locale
{
  SCM locale = SCM_BOOL_F;
  int err = 0;
  int c_category_mask;
  char *c_locale_name;
  scm_t_locale c_base_locale, c_locale;

  SCM_MAKE_VALIDATE (1, category_list, LIST_OR_INTEGER_P);
  SCM_VALIDATE_STRING (2, locale_name);
  SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, base_locale, c_base_locale);

  c_category_mask = category_list_to_category_mask (category_list,
						    FUNC_NAME, 1);
  c_locale_name = scm_to_locale_string (locale_name);

#ifdef USE_GNU_LOCALE_API

  if (scm_is_eq (base_locale, SCM_VARIABLE_REF (scm_global_locale)))
    c_base_locale = LC_GLOBAL_LOCALE;

  if (c_base_locale != (locale_t) 0)
    {
      /* C_BASE_LOCALE is to be consumed by `newlocale ()' so it needs to be
	 duplicated before.  */
      c_base_locale = duplocale (c_base_locale);

      if (c_base_locale == (locale_t) 0)
	{
	  err = errno;
	  goto fail;
	}
    }

  c_locale = newlocale (c_category_mask, c_locale_name, c_base_locale);

  free (c_locale_name);

  if (c_locale == (locale_t) 0)
    {
      if (c_base_locale != (locale_t) 0)
	freelocale (c_base_locale);
      scm_locale_error (FUNC_NAME, errno);
    }
  else
    SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale);

#else

  c_locale = scm_gc_malloc (sizeof (* c_locale), "locale");

  c_locale->category_mask = c_category_mask;
  c_locale->locale_name = c_locale_name;

  if (scm_is_eq (base_locale, SCM_VARIABLE_REF (scm_global_locale)))
    {
      /* Get the current locale settings and turn them into a locale
	 object.  */
      err = get_current_locale (&base_locale);
      if (err)
	goto fail;
    }

  c_locale->base_locale = base_locale;

  {
    /* Try out the new locale and raise an exception if it doesn't work.  */
    int err;
    scm_t_locale_settings prev_locale;

    err = enter_locale_section (c_locale, &prev_locale);

    if (err)
      goto fail;
    else
      {
	leave_locale_section (&prev_locale);
	SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale);
      }
  }

#endif

  return locale;

 fail:
#ifndef USE_GNU_LOCALE_API
  scm_gc_free (c_locale, sizeof (* c_locale), "locale");
#endif
  free (c_locale_name);
  scm_locale_error (FUNC_NAME, err);

  return SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_DEFINE (scm_locale_p, "locale?", 1, 0, 0,
	    (SCM obj),
	    "Return true if @var{obj} is a locale object.")
#define FUNC_NAME s_scm_locale_p
{
  return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_locale_smob_type, obj));
}
#undef FUNC_NAME

/* Locale-dependent string comparison.

   A similar API can be found in MzScheme starting from version 200:
   http://download.plt-scheme.org/chronology/mzmr200alpha14.html .  */

#define SCM_STRING_TO_U32_BUF(s1, c_s1)					\
  do									\
    {									\
      if (scm_i_is_narrow_string (s1))					\
	{								\
	  size_t i, len;						\
	  const char *buf = scm_i_string_chars (s1);			\
									\
	  len = scm_i_string_length (s1);				\
	  c_s1 = alloca (sizeof (scm_t_wchar) * (len + 1));		\
									\
	  for (i = 0; i < len; i ++)					\
	    c_s1[i] = (unsigned char ) buf[i];				\
	  c_s1[len] = 0;						\
	}								\
      else								\
	c_s1 = (scm_t_wchar *) scm_i_string_wide_chars (s1);		\
    } while (0)

/* Compare UTF-32 strings according to LOCALE.  Returns a negative value if
   S1 compares smaller than S2, a positive value if S1 compares larger than
   S2, or 0 if they compare equal.  */
static inline int
compare_u32_strings (SCM s1, SCM s2, SCM locale, const char *func_name)
#define FUNC_NAME func_name
{
  int result;
  scm_t_locale c_locale;
  scm_t_wchar *c_s1, *c_s2;
  SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale);

  SCM_STRING_TO_U32_BUF (s1, c_s1);
  SCM_STRING_TO_U32_BUF (s2, c_s2);

  if (c_locale)
    RUN_IN_LOCALE_SECTION (c_locale,
                           result = u32_strcoll ((const scm_t_uint32 *) c_s1,
                                                 (const scm_t_uint32 *) c_s2));
  else
    result = u32_strcoll ((const scm_t_uint32 *) c_s1,
			  (const scm_t_uint32 *) c_s2);

  scm_remember_upto_here_2 (s1, s2);
  scm_remember_upto_here (locale);
  return result;
}
#undef FUNC_NAME

/* Return the current language of the locale. */
static const char *
locale_language ()
{
  /* FIXME: If the locale has been set with 'uselocale',
     libunistring's uc_locale_language will return the incorrect
     language: it will return the language appropriate for the global
     (non-thread-specific) locale.

     There appears to be no portable way to extract the language from
     the thread-specific locale_t.  There is no LANGUAGE capability in
     nl_langinfo or nl_langinfo_l.

     Thus, uc_locale_language needs to be fixed upstream.  */
  return uc_locale_language ();
}

static inline int
u32_locale_casecoll (const char *func_name, const scm_t_uint32 *c_s1,
                     const scm_t_uint32 *c_s2,
		     int *result)
{
  /* Note: Since this is called from `RUN_IN_LOCALE_SECTION', it must note
     make any non-local exit.  */

  int ret;
  const char *loc = locale_language ();

  ret = u32_casecoll (c_s1, u32_strlen (c_s1),
                      c_s2, u32_strlen (c_s2),
                      loc, UNINORM_NFC, result);

  return ret == 0 ? ret : errno;
}

static inline int
compare_u32_strings_ci (SCM s1, SCM s2, SCM locale, const char *func_name)
#define FUNC_NAME func_name
{
  int result, ret = 0;
  scm_t_locale c_locale;
  scm_t_wchar *c_s1, *c_s2;
  SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale);

  SCM_STRING_TO_U32_BUF (s1, c_s1);
  SCM_STRING_TO_U32_BUF (s2, c_s2);

  if (c_locale)
    RUN_IN_LOCALE_SECTION
      (c_locale,
       ret = u32_locale_casecoll (func_name,
				  (const scm_t_uint32 *) c_s1,
				  (const scm_t_uint32 *) c_s2,
				  &result));
  else
    ret = u32_locale_casecoll (func_name,
			       (const scm_t_uint32 *) c_s1,
			       (const scm_t_uint32 *) c_s2,
			       &result);

  if (SCM_UNLIKELY (ret != 0))
    {
      errno = ret;
      scm_syserror (FUNC_NAME);
    }

  scm_remember_upto_here_2 (s1, s2);
  scm_remember_upto_here (locale);

  return result;
}
#undef FUNC_NAME

/* Store into DST an upper-case version of SRC.  */
static inline void
str_upcase (register char *dst, register const char *src)
{
  for (; *src != '\0'; src++, dst++)
    *dst = toupper ((int) *src);
  *dst = '\0';
}

static inline void
str_downcase (register char *dst, register const char *src)
{
  for (; *src != '\0'; src++, dst++)
    *dst = tolower ((int) *src);
  *dst = '\0';
}

#ifdef USE_GNU_LOCALE_API
static inline void
str_upcase_l (register char *dst, register const char *src,
	      scm_t_locale locale)
{
  for (; *src != '\0'; src++, dst++)
    *dst = toupper_l (*src, locale);
  *dst = '\0';
}

static inline void
str_downcase_l (register char *dst, register const char *src,
		scm_t_locale locale)
{
  for (; *src != '\0'; src++, dst++)
    *dst = tolower_l (*src, locale);
  *dst = '\0';
}
#endif

SCM_DEFINE (scm_string_locale_lt, "string-locale<?", 2, 1, 0,
	    (SCM s1, SCM s2, SCM locale),
	    "Compare strings @var{s1} and @var{s2} in a locale-dependent way."
	    "If @var{locale} is provided, it should be locale object (as "
	    "returned by @code{make-locale}) and will be used to perform the "
	    "comparison; otherwise, the current system locale is used.")
#define FUNC_NAME s_scm_string_locale_lt
{
  int result;

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

  result = compare_u32_strings (s1, s2, locale, FUNC_NAME);

  return scm_from_bool (result < 0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_string_locale_gt, "string-locale>?", 2, 1, 0,
	    (SCM s1, SCM s2, SCM locale),
	    "Compare strings @var{s1} and @var{s2} in a locale-dependent way."
	    "If @var{locale} is provided, it should be locale object (as "
	    "returned by @code{make-locale}) and will be used to perform the "
	    "comparison; otherwise, the current system locale is used.")
#define FUNC_NAME s_scm_string_locale_gt
{
  int result;

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

  result = compare_u32_strings (s1, s2, locale, FUNC_NAME);

  return scm_from_bool (result > 0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_string_locale_ci_lt, "string-locale-ci<?", 2, 1, 0,
	    (SCM s1, SCM s2, SCM locale),
	    "Compare strings @var{s1} and @var{s2} in a case-insensitive, "
	    "and locale-dependent way.  If @var{locale} is provided, it "
	    "should be locale object (as returned by @code{make-locale}) "
	    "and will be used to perform the comparison; otherwise, the "
	    "current system locale is used.")
#define FUNC_NAME s_scm_string_locale_ci_lt
{
  int result;

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

  result = compare_u32_strings_ci (s1, s2, locale, FUNC_NAME);

  return scm_from_bool (result < 0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_string_locale_ci_gt, "string-locale-ci>?", 2, 1, 0,
	    (SCM s1, SCM s2, SCM locale),
	    "Compare strings @var{s1} and @var{s2} in a case-insensitive, "
	    "and locale-dependent way.  If @var{locale} is provided, it "
	    "should be locale object (as returned by @code{make-locale}) "
	    "and will be used to perform the comparison; otherwise, the "
	    "current system locale is used.")
#define FUNC_NAME s_scm_string_locale_ci_gt
{
  int result;

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

  result = compare_u32_strings_ci (s1, s2, locale, FUNC_NAME);

  return scm_from_bool (result > 0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_string_locale_ci_eq, "string-locale-ci=?", 2, 1, 0,
	    (SCM s1, SCM s2, SCM locale),
	    "Compare strings @var{s1} and @var{s2} in a case-insensitive, "
	    "and locale-dependent way.  If @var{locale} is provided, it "
	    "should be locale object (as returned by @code{make-locale}) "
	    "and will be used to perform the comparison; otherwise, the "
	    "current system locale is used.")
#define FUNC_NAME s_scm_string_locale_ci_eq
{
  int result;

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

  result = compare_u32_strings_ci (s1, s2, locale, FUNC_NAME);

  return scm_from_bool (result == 0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_locale_lt, "char-locale<?", 2, 1, 0,
	    (SCM c1, SCM c2, SCM locale),
	    "Return true if character @var{c1} is lower than @var{c2} "
	    "according to @var{locale} or to the current locale.")
#define FUNC_NAME s_scm_char_locale_lt
{
  int result;

  SCM_VALIDATE_CHAR (1, c1);
  SCM_VALIDATE_CHAR (2, c2);

  result = compare_u32_strings (scm_string (scm_list_1 (c1)),
                                scm_string (scm_list_1 (c2)),
                                locale, FUNC_NAME);

  return scm_from_bool (result < 0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_locale_gt, "char-locale>?", 2, 1, 0,
	    (SCM c1, SCM c2, SCM locale),
	    "Return true if character @var{c1} is greater than @var{c2} "
	    "according to @var{locale} or to the current locale.")
#define FUNC_NAME s_scm_char_locale_gt
{
  int result;

  SCM_VALIDATE_CHAR (1, c1);
  SCM_VALIDATE_CHAR (2, c2);

  result = compare_u32_strings (scm_string (scm_list_1 (c1)),
                                scm_string (scm_list_1 (c2)),
                                locale, FUNC_NAME);

  return scm_from_bool (result > 0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_locale_ci_lt, "char-locale-ci<?", 2, 1, 0,
	    (SCM c1, SCM c2, SCM locale),
	    "Return true if character @var{c1} is lower than @var{c2}, "
	    "in a case insensitive way according to @var{locale} or to "
	    "the current locale.")
#define FUNC_NAME s_scm_char_locale_ci_lt
{
  int result;

  SCM_VALIDATE_CHAR (1, c1);
  SCM_VALIDATE_CHAR (2, c2);

  result = compare_u32_strings_ci (scm_string (scm_list_1 (c1)),
                                   scm_string (scm_list_1 (c2)),
                                   locale, FUNC_NAME);

  return scm_from_bool (result < 0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_locale_ci_gt, "char-locale-ci>?", 2, 1, 0,
	    (SCM c1, SCM c2, SCM locale),
	    "Return true if character @var{c1} is greater than @var{c2}, "
	    "in a case insensitive way according to @var{locale} or to "
	    "the current locale.")
#define FUNC_NAME s_scm_char_locale_ci_gt
{
  int result;

  SCM_VALIDATE_CHAR (1, c1);
  SCM_VALIDATE_CHAR (2, c2);

  result = compare_u32_strings_ci (scm_string (scm_list_1 (c1)),
                                   scm_string (scm_list_1 (c2)),
                                   locale, FUNC_NAME);

  return scm_from_bool (result > 0);
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_locale_ci_eq, "char-locale-ci=?", 2, 1, 0,
	    (SCM c1, SCM c2, SCM locale),
	    "Return true if character @var{c1} is equal to @var{c2}, "
	    "in a case insensitive way according to @var{locale} or to "
	    "the current locale.")
#define FUNC_NAME s_scm_char_locale_ci_eq
{
  int result;

  SCM_VALIDATE_CHAR (1, c1);
  SCM_VALIDATE_CHAR (2, c2);

  result = compare_u32_strings_ci (scm_string (scm_list_1 (c1)),
                                   scm_string (scm_list_1 (c2)),
                                   locale, FUNC_NAME);

  return scm_from_bool (result == 0);
}
#undef FUNC_NAME

/* Locale-dependent alphabetic character mapping.  */

static inline int
u32_locale_tocase (const scm_t_uint32 *c_s1, size_t len,
                   scm_t_uint32 **p_c_s2, size_t * p_len2,
                   scm_t_uint32 *(*func) (const scm_t_uint32 *, size_t,
                                          const char *, uninorm_t,
                                          scm_t_uint32 *, size_t *))
{
  /* Note: Since this is called from `RUN_IN_LOCALE_SECTION', it must not
     make any non-local exit.  */

  scm_t_uint32 *ret;
  const char *loc = locale_language ();

  /* The first NULL here indicates that no NFC or NFKC normalization
     is done.  The second NULL means the return buffer is
     malloc'ed here.  */
  ret = func (c_s1, len, loc, NULL, NULL, p_len2);

  if (ret == NULL)
    {
      *p_c_s2 = (scm_t_uint32 *) NULL;
      *p_len2 = 0;
      return errno;
    }
  *p_c_s2 = ret;

  return 0;
}

static SCM
chr_to_case (SCM chr, scm_t_locale c_locale,
	     scm_t_uint32 *(*func) (const scm_t_uint32 *, size_t, const char *,
				    uninorm_t, scm_t_uint32 *, size_t *),
	     const char *func_name,
	     int *err)
#define FUNC_NAME func_name
{
  int ret;
  scm_t_wchar *buf;
  scm_t_uint32 *convbuf;
  size_t convlen;
  SCM str, convchar;

  str = scm_i_make_wide_string (1, &buf);
  buf[0] = SCM_CHAR (chr);

  if (c_locale != NULL)
    RUN_IN_LOCALE_SECTION (c_locale, ret =
                           u32_locale_tocase ((scm_t_uint32 *) buf, 1,
                                              &convbuf,
                                              &convlen, func));
  else
    ret =
      u32_locale_tocase ((scm_t_uint32 *) buf, 1, &convbuf,
                         &convlen, func);

  if (SCM_UNLIKELY (ret != 0))
    {
      *err = ret;
      return NULL;
    }

  if (convlen == 1)
    convchar = SCM_MAKE_CHAR ((scm_t_wchar) convbuf[0]);
  else
    convchar = chr;
  free (convbuf);

  return convchar;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_locale_downcase, "char-locale-downcase", 1, 1, 0,
	    (SCM chr, SCM locale),
	    "Return the lowercase character that corresponds to @var{chr} "
	    "according to either @var{locale} or the current locale.")
#define FUNC_NAME s_scm_char_locale_downcase
{
  scm_t_locale c_locale;
  SCM ret;
  int err = 0;

  SCM_VALIDATE_CHAR (1, chr);
  SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);

  ret = chr_to_case (chr, c_locale, u32_tolower, FUNC_NAME, &err);

  if (err != 0)
    {
      errno = err;
      scm_syserror (FUNC_NAME);
    }
  return ret;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_locale_upcase, "char-locale-upcase", 1, 1, 0,
	    (SCM chr, SCM locale),
	    "Return the uppercase character that corresponds to @var{chr} "
	    "according to either @var{locale} or the current locale.")
#define FUNC_NAME s_scm_char_locale_upcase
{
  scm_t_locale c_locale;
  SCM ret;
  int err = 0;

  SCM_VALIDATE_CHAR (1, chr);
  SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);

  ret = chr_to_case (chr, c_locale, u32_toupper, FUNC_NAME, &err);

  if (err != 0)
    {
      errno = err;
      scm_syserror (FUNC_NAME);
    }
  return ret;
}
#undef FUNC_NAME

SCM_DEFINE (scm_char_locale_titlecase, "char-locale-titlecase", 1, 1, 0,
	    (SCM chr, SCM locale),
	    "Return the titlecase character that corresponds to @var{chr} "
	    "according to either @var{locale} or the current locale.")
#define FUNC_NAME s_scm_char_locale_titlecase
{
  scm_t_locale c_locale;
  SCM ret;
  int err = 0;

  SCM_VALIDATE_CHAR (1, chr);
  SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);

  ret = chr_to_case (chr, c_locale, u32_totitle, FUNC_NAME, &err);

  if (err != 0)
    {
      errno = err;
      scm_syserror (FUNC_NAME);
    }
  return ret;
}
#undef FUNC_NAME

static SCM
str_to_case (SCM str, scm_t_locale c_locale,
	     scm_t_uint32 *(*func) (const scm_t_uint32 *, size_t, const char *,
				    uninorm_t, scm_t_uint32 *, size_t *),
	     const char *func_name,
	     int *err)
#define FUNC_NAME func_name
{
  scm_t_wchar *c_str, *c_buf;
  scm_t_uint32 *c_convstr;
  size_t len, convlen;
  int ret;
  SCM convstr;

  len = scm_i_string_length (str);
  if (len == 0)
    return scm_nullstr;
  SCM_STRING_TO_U32_BUF (str, c_str);

  if (c_locale)
    RUN_IN_LOCALE_SECTION (c_locale, ret =
                           u32_locale_tocase ((scm_t_uint32 *) c_str, len,
                                              &c_convstr,
                                              &convlen, func));
  else
    ret =
      u32_locale_tocase ((scm_t_uint32 *) c_str, len,
                         &c_convstr, &convlen, func);

  scm_remember_upto_here (str);

  if (SCM_UNLIKELY (ret != 0))
    {
      *err = ret;
      return NULL;
    }

  convstr = scm_i_make_wide_string (convlen, &c_buf);
  memcpy (c_buf, c_convstr, convlen * sizeof (scm_t_wchar));
  free (c_convstr);

  scm_i_try_narrow_string (convstr);

  return convstr;
}
#undef FUNC_NAME

SCM_DEFINE (scm_string_locale_upcase, "string-locale-upcase", 1, 1, 0,
	    (SCM str, SCM locale),
	    "Return a new string that is the uppercase version of "
	    "@var{str} according to either @var{locale} or the current "
	    "locale.")
#define FUNC_NAME s_scm_string_locale_upcase
{
  scm_t_locale c_locale;
  SCM ret;
  int err = 0;

  SCM_VALIDATE_STRING (1, str);
  SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);

  ret = str_to_case (str, c_locale, u32_toupper, FUNC_NAME, &err);

  if (err != 0)
    {
      errno = err;
      scm_syserror (FUNC_NAME);
    }
  return ret;
}
#undef FUNC_NAME

SCM_DEFINE (scm_string_locale_downcase, "string-locale-downcase", 1, 1, 0,
	    (SCM str, SCM locale),
	    "Return a new string that is the down-case version of "
	    "@var{str} according to either @var{locale} or the current "
	    "locale.")
#define FUNC_NAME s_scm_string_locale_downcase
{
  scm_t_locale c_locale;
  SCM ret;
  int err = 0;

  SCM_VALIDATE_STRING (1, str);
  SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);

  ret = str_to_case (str, c_locale, u32_tolower, FUNC_NAME, &err);

  if (err != 0)
    {
      errno = err;
      scm_syserror (FUNC_NAME);
    }
  return ret;
}
#undef FUNC_NAME

SCM_DEFINE (scm_string_locale_titlecase, "string-locale-titlecase", 1, 1, 0,
	    (SCM str, SCM locale),
	    "Return a new string that is the title-case version of "
	    "@var{str} according to either @var{locale} or the current "
	    "locale.")
#define FUNC_NAME s_scm_string_locale_titlecase
{
  scm_t_locale c_locale;
  SCM ret;
  int err = 0;

  SCM_VALIDATE_STRING (1, str);
  SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);

  ret = str_to_case (str, c_locale, u32_totitle, FUNC_NAME, &err);

  if (err != 0)
    {
      errno = err;
      scm_syserror (FUNC_NAME);
    }
  return ret;
}
#undef FUNC_NAME

/* Note: We don't provide mutative versions of `string-locale-(up|down)case'
   because, in some languages, a single downcase character maps to a couple
   of uppercase characters.  Read the SRFI-13 document for a detailed
   discussion about this.  */

/* Locale-dependent number parsing.  */

SCM_DEFINE (scm_locale_string_to_integer, "locale-string->integer",
	    1, 2, 0, (SCM str, SCM base, SCM locale),
	    "Convert string @var{str} into an integer according to either "
	    "@var{locale} (a locale object as returned by @code{make-locale}) "
	    "or the current process locale.  Return two values: an integer "
	    "(on success) or @code{#f}, and the number of characters read "
	    "from @var{str} (@code{0} on failure).")
#define FUNC_NAME s_scm_locale_string_to_integer
{
  SCM result;
  long c_result;
  int c_base;
  const char *c_str;
  char *c_endptr;
  scm_t_locale c_locale;

  SCM_VALIDATE_STRING (1, str);
  c_str = scm_i_string_chars (str);

  if (base != SCM_UNDEFINED)
    SCM_VALIDATE_INT_COPY (2, base, c_base);
  else
    c_base = 10;

  SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale);

  if (c_locale != NULL)
    {
#ifdef USE_GNU_LOCALE_API
      c_result = strtol_l (c_str, &c_endptr, c_base, c_locale);
#else
      RUN_IN_LOCALE_SECTION (c_locale,
			     c_result = strtol (c_str, &c_endptr, c_base));
#endif
    }
  else
    c_result = strtol (c_str, &c_endptr, c_base);

  scm_remember_upto_here (str);

  if (c_endptr == c_str)
    result = SCM_BOOL_F;
  else
    result = scm_from_long (c_result);

  return (scm_values (scm_list_2 (result, scm_from_long (c_endptr - c_str))));
}
#undef FUNC_NAME

SCM_DEFINE (scm_locale_string_to_inexact, "locale-string->inexact",
	    1, 1, 0, (SCM str, SCM locale),
	    "Convert string @var{str} into an inexact number according to "
	    "either @var{locale} (a locale object as returned by "
	    "@code{make-locale}) or the current process locale.  Return "
	    "two values: an inexact number (on success) or @code{#f}, and "
	    "the number of characters read from @var{str} (@code{0} on "
	    "failure).")
#define FUNC_NAME s_scm_locale_string_to_inexact
{
  SCM result;
  double c_result;
  const char *c_str;
  char *c_endptr;
  scm_t_locale c_locale;

  SCM_VALIDATE_STRING (1, str);
  c_str = scm_i_string_chars (str);

  SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);

  if (c_locale != NULL)
    {
#ifdef USE_GNU_LOCALE_API
      c_result = strtod_l (c_str, &c_endptr, c_locale);
#else
      RUN_IN_LOCALE_SECTION (c_locale,
			     c_result = strtod (c_str, &c_endptr));
#endif
    }
  else
    c_result = strtod (c_str, &c_endptr);

  scm_remember_upto_here (str);

  if (c_endptr == c_str)
    result = SCM_BOOL_F;
  else
    result = scm_from_double (c_result);

  return (scm_values (scm_list_2 (result, scm_from_long (c_endptr - c_str))));
}
#undef FUNC_NAME

/* Language information, aka. `nl_langinfo ()'.  */

/* FIXME: Issues related to `nl-langinfo'.

   1. The `CODESET' value is not normalized.  This is a secondary issue, but
      still a practical issue.  See
      http://www.cl.cam.ac.uk/~mgk25/ucs/norm_charmap.c for codeset
      normalization.

   2. `nl_langinfo ()' is not available on Windows.

   3. `nl_langinfo ()' may return strings encoded in a locale different from
      the current one.
      For example:

        (nl-langinfo DAY_1 (make-locale LC_ALL "eo_EO.UTF-8"))

      returns a result that is a UTF-8 string, regardless of the
      setting of the current locale.  If nl_langinfo supports CODESET,
      we can convert the string properly using scm_from_stringn.  If
      CODESET is not supported, we won't be able to make much sense of
      the returned string.

   Note: We don't use Gnulib's `nl_langinfo' module because it's currently not
   as complete as the compatibility hacks in `i18n.scm'.  */

SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
	    (SCM item, SCM locale),
	    "Return a string denoting locale information for @var{item} "
	    "in the current locale or that specified by @var{locale}.  "
	    "The semantics and arguments are the same as those of the "
	    "X/Open @code{nl_langinfo} function (@pxref{The Elegant and "
	    "Fast Way, @code{nl_langinfo},, libc, The GNU C Library "
	    "Reference Manual}).")
#define FUNC_NAME s_scm_nl_langinfo
{
#ifdef HAVE_NL_LANGINFO
  SCM result;
  nl_item c_item;
  char *c_result;
  scm_t_locale c_locale;
#ifdef HAVE_LANGINFO_CODESET
  char *codeset;
#endif

  SCM_VALIDATE_INT_COPY (2, item, c_item);
  SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);

  /* Sadly, `nl_langinfo ()' returns a pointer to a static string.  According
     to SuS v2, that static string may be modified by subsequent calls to
     `nl_langinfo ()' as well as by calls to `setlocale ()'.  Thus, we must
     acquire the locale mutex before doing invoking `nl_langinfo ()'.  See
     http://opengroup.org/onlinepubs/007908799/xsh/nl_langinfo.html for
     details.  */

  scm_i_pthread_mutex_lock (&scm_i_locale_mutex);
  if (c_locale != NULL)
    {
#ifdef USE_GNU_LOCALE_API
      c_result = nl_langinfo_l (c_item, c_locale);
#ifdef HAVE_LANGINFO_CODESET
      codeset = nl_langinfo_l (CODESET, c_locale);
#endif /* HAVE_LANGINFO_CODESET */
#else /* !USE_GNU_LOCALE_API */
      /* We can't use `RUN_IN_LOCALE_SECTION ()' here because the locale
	 mutex is already taken.  */
      int lsec_err;
      scm_t_locale_settings lsec_prev_locale;

      lsec_err = get_current_locale_settings (&lsec_prev_locale);
      if (lsec_err)
	scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
      else
	{
	  lsec_err = install_locale (c_locale);
	  if (lsec_err)
	    {
	      leave_locale_section (&lsec_prev_locale);
	      free_locale_settings (&lsec_prev_locale);
	    }
	}

      if (lsec_err)
	scm_locale_error (FUNC_NAME, lsec_err);
      else
	{
	  c_result = nl_langinfo (c_item);
#ifdef HAVE_LANGINFO_CODESET
          codeset = nl_langinfo (CODESET);
#endif /* HAVE_LANGINFO_CODESET */

	  restore_locale_settings (&lsec_prev_locale);
	  free_locale_settings (&lsec_prev_locale);
	}
#endif
    }
  else
    {
      c_result = nl_langinfo (c_item);
#ifdef HAVE_LANGINFO_CODESET
      codeset = nl_langinfo (CODESET);
#endif /* HAVE_LANGINFO_CODESET */
    }

  c_result = strdup (c_result);
  scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);

  if (c_result == NULL)
    result = SCM_BOOL_F;
  else
    {
      switch (c_item)
	{
#if (defined GROUPING) && (defined MON_GROUPING)
	case GROUPING:
	case MON_GROUPING:
	  {
	    char *p;

	    /* In this cases, the result is to be interpreted as a list of
	       numbers.  If the last item is `CHARS_MAX', it has the special
	       meaning "no more grouping".  */
	    result = SCM_EOL;
	    for (p = c_result; (*p != '\0') && (*p != CHAR_MAX); p++)
	      result = scm_cons (SCM_I_MAKINUM ((int) *p), result);

	    {
	      SCM last_pair = result;

	      result = scm_reverse_x (result, SCM_EOL);

	      if (*p != CHAR_MAX)
		{
		  /* Cyclic grouping information.  */
		  if (last_pair != SCM_EOL)
		    SCM_SETCDR (last_pair, result);
		}
	    }

	    free (c_result);
	    break;
	  }
#endif

#if (defined FRAC_DIGITS) && (defined INT_FRAC_DIGITS)
	case FRAC_DIGITS:
	case INT_FRAC_DIGITS:
	  /* This is to be interpreted as a single integer.  */
	  if (*c_result == CHAR_MAX)
	    /* Unspecified.  */
	    result = SCM_BOOL_F;
	  else
	    result = SCM_I_MAKINUM (*c_result);

	  free (c_result);
	  break;
#endif

#if (defined P_CS_PRECEDES) && (defined INT_N_CS_PRECEDES)
	case P_CS_PRECEDES:
	case N_CS_PRECEDES:
	case INT_P_CS_PRECEDES:
	case INT_N_CS_PRECEDES:
#if (defined P_SEP_BY_SPACE) && (defined N_SEP_BY_SPACE)
	case P_SEP_BY_SPACE:
	case N_SEP_BY_SPACE:
#endif
	  /* This is to be interpreted as a boolean.  */
	  result = scm_from_bool (*c_result);

	  free (c_result);
	  break;
#endif

#if (defined P_SIGN_POSN) && (defined INT_N_SIGN_POSN)
	case P_SIGN_POSN:
	case N_SIGN_POSN:
	case INT_P_SIGN_POSN:
	case INT_N_SIGN_POSN:
	  /* See `(libc) Sign of Money Amount' for the interpretation of the
	     return value here.  */
	  switch (*c_result)
	    {
	    case 0:
	      result = scm_from_locale_symbol ("parenthesize");
	      break;

	    case 1:
	      result = scm_from_locale_symbol ("sign-before");
	      break;

	    case 2:
	      result = scm_from_locale_symbol ("sign-after");
	      break;

	    case 3:
	      result = scm_from_locale_symbol ("sign-before-currency-symbol");
	      break;

	    case 4:
	      result = scm_from_locale_symbol ("sign-after-currency-symbol");
	      break;

	    default:
	      result = scm_from_locale_symbol ("unspecified");
	    }
	  break;
#endif

	default:
#ifdef HAVE_LANGINFO_CODESET
          result = scm_from_stringn (c_result, strlen (c_result),
                                     codeset,
                                     SCM_FAILED_CONVERSION_QUESTION_MARK);
#else /* !HAVE_LANGINFO_CODESET */
          /* This may be incorrectly encoded if the locale differs
             from the c_locale.  */
          result = scm_from_locale_string (c_result);
#endif /* !HAVE_LANGINFO_CODESET */
          free (c_result);
	}
    }

  return result;
#else
  scm_syserror_msg (FUNC_NAME, "`nl-langinfo' not supported on your system",
		    SCM_EOL, ENOSYS);

  return SCM_BOOL_F;
#endif
}
#undef FUNC_NAME

/* Define the `nl_item' constants.  */
static inline void
define_langinfo_items (void)
{
#ifdef HAVE_LANGINFO_H

#define DEFINE_NLITEM_CONSTANT(_item)		\
  scm_c_define (# _item, scm_from_int (_item))

  DEFINE_NLITEM_CONSTANT (CODESET);

  /* Abbreviated days of the week. */
  DEFINE_NLITEM_CONSTANT (ABDAY_1);
  DEFINE_NLITEM_CONSTANT (ABDAY_2);
  DEFINE_NLITEM_CONSTANT (ABDAY_3);
  DEFINE_NLITEM_CONSTANT (ABDAY_4);
  DEFINE_NLITEM_CONSTANT (ABDAY_5);
  DEFINE_NLITEM_CONSTANT (ABDAY_6);
  DEFINE_NLITEM_CONSTANT (ABDAY_7);

  /* Long-named days of the week. */
  DEFINE_NLITEM_CONSTANT (DAY_1);	/* Sunday */
  DEFINE_NLITEM_CONSTANT (DAY_2);	/* Monday */
  DEFINE_NLITEM_CONSTANT (DAY_3);	/* Tuesday */
  DEFINE_NLITEM_CONSTANT (DAY_4);	/* Wednesday */
  DEFINE_NLITEM_CONSTANT (DAY_5);	/* Thursday */
  DEFINE_NLITEM_CONSTANT (DAY_6);	/* Friday */
  DEFINE_NLITEM_CONSTANT (DAY_7);	/* Saturday */

  /* Abbreviated month names.  */
  DEFINE_NLITEM_CONSTANT (ABMON_1);	/* Jan */
  DEFINE_NLITEM_CONSTANT (ABMON_2);
  DEFINE_NLITEM_CONSTANT (ABMON_3);
  DEFINE_NLITEM_CONSTANT (ABMON_4);
  DEFINE_NLITEM_CONSTANT (ABMON_5);
  DEFINE_NLITEM_CONSTANT (ABMON_6);
  DEFINE_NLITEM_CONSTANT (ABMON_7);
  DEFINE_NLITEM_CONSTANT (ABMON_8);
  DEFINE_NLITEM_CONSTANT (ABMON_9);
  DEFINE_NLITEM_CONSTANT (ABMON_10);
  DEFINE_NLITEM_CONSTANT (ABMON_11);
  DEFINE_NLITEM_CONSTANT (ABMON_12);

  /* Long month names.  */
  DEFINE_NLITEM_CONSTANT (MON_1);	/* January */
  DEFINE_NLITEM_CONSTANT (MON_2);
  DEFINE_NLITEM_CONSTANT (MON_3);
  DEFINE_NLITEM_CONSTANT (MON_4);
  DEFINE_NLITEM_CONSTANT (MON_5);
  DEFINE_NLITEM_CONSTANT (MON_6);
  DEFINE_NLITEM_CONSTANT (MON_7);
  DEFINE_NLITEM_CONSTANT (MON_8);
  DEFINE_NLITEM_CONSTANT (MON_9);
  DEFINE_NLITEM_CONSTANT (MON_10);
  DEFINE_NLITEM_CONSTANT (MON_11);
  DEFINE_NLITEM_CONSTANT (MON_12);

  DEFINE_NLITEM_CONSTANT (AM_STR);	/* Ante meridiem string.  */
  DEFINE_NLITEM_CONSTANT (PM_STR);	/* Post meridiem string.  */

  DEFINE_NLITEM_CONSTANT (D_T_FMT); /* Date and time format for strftime.  */
  DEFINE_NLITEM_CONSTANT (D_FMT);   /* Date format for strftime.  */
  DEFINE_NLITEM_CONSTANT (T_FMT);   /* Time format for strftime.  */
  DEFINE_NLITEM_CONSTANT (T_FMT_AMPM);/* 12-hour time format for strftime.  */

  DEFINE_NLITEM_CONSTANT (ERA);	        /* Alternate era.  */
  DEFINE_NLITEM_CONSTANT (ERA_D_FMT);	/* Date in alternate era format.  */
  DEFINE_NLITEM_CONSTANT (ERA_D_T_FMT);	/* Date and time in alternate era
					   format.  */
  DEFINE_NLITEM_CONSTANT (ERA_T_FMT);	/* Time in alternate era format.  */

  DEFINE_NLITEM_CONSTANT (ALT_DIGITS);	/* Alternate symbols for digits.  */
  DEFINE_NLITEM_CONSTANT (RADIXCHAR);
  DEFINE_NLITEM_CONSTANT (THOUSEP);

#ifdef YESEXPR
  DEFINE_NLITEM_CONSTANT (YESEXPR);
#endif
#ifdef NOEXPR
  DEFINE_NLITEM_CONSTANT (NOEXPR);
#endif

#ifdef CRNCYSTR /* currency symbol */
  DEFINE_NLITEM_CONSTANT (CRNCYSTR);
#endif

  /* GNU extensions.  */

#ifdef ERA_YEAR
  DEFINE_NLITEM_CONSTANT (ERA_YEAR);	/* Year in alternate era format.  */
#endif

  /* LC_MONETARY category: formatting of monetary quantities.
     These items each correspond to a member of `struct lconv',
     defined in <locale.h>.  */
#ifdef INT_CURR_SYMBOL
  DEFINE_NLITEM_CONSTANT (INT_CURR_SYMBOL);
#endif
#ifdef MON_DECIMAL_POINT
  DEFINE_NLITEM_CONSTANT (MON_DECIMAL_POINT);
#endif
#ifdef MON_THOUSANDS_SEP
  DEFINE_NLITEM_CONSTANT (MON_THOUSANDS_SEP);
#endif
#ifdef MON_GROUPING
  DEFINE_NLITEM_CONSTANT (MON_GROUPING);
#endif
#ifdef POSITIVE_SIGN
  DEFINE_NLITEM_CONSTANT (POSITIVE_SIGN);
#endif
#ifdef NEGATIVE_SIGN
  DEFINE_NLITEM_CONSTANT (NEGATIVE_SIGN);
#endif
#ifdef GROUPING
  DEFINE_NLITEM_CONSTANT (GROUPING);
#endif
#ifdef INT_FRAC_DIGITS
  DEFINE_NLITEM_CONSTANT (INT_FRAC_DIGITS);
#endif
#ifdef FRAC_DIGITS
  DEFINE_NLITEM_CONSTANT (FRAC_DIGITS);
#endif
#ifdef P_CS_PRECEDES
  DEFINE_NLITEM_CONSTANT (P_CS_PRECEDES);
#endif
#ifdef P_SEP_BY_SPACE
  DEFINE_NLITEM_CONSTANT (P_SEP_BY_SPACE);
#endif
#ifdef N_CS_PRECEDES
  DEFINE_NLITEM_CONSTANT (N_CS_PRECEDES);
#endif
#ifdef N_SEP_BY_SPACE
  DEFINE_NLITEM_CONSTANT (N_SEP_BY_SPACE);
#endif
#ifdef P_SIGN_POSN
  DEFINE_NLITEM_CONSTANT (P_SIGN_POSN);
#endif
#ifdef N_SIGN_POSN
  DEFINE_NLITEM_CONSTANT (N_SIGN_POSN);
#endif
#ifdef INT_P_CS_PRECEDES
  DEFINE_NLITEM_CONSTANT (INT_P_CS_PRECEDES);
#endif
#ifdef INT_P_SEP_BY_SPACE
  DEFINE_NLITEM_CONSTANT (INT_P_SEP_BY_SPACE);
#endif
#ifdef INT_N_CS_PRECEDES
  DEFINE_NLITEM_CONSTANT (INT_N_CS_PRECEDES);
#endif
#ifdef INT_N_SEP_BY_SPACE
  DEFINE_NLITEM_CONSTANT (INT_N_SEP_BY_SPACE);
#endif
#ifdef INT_P_SIGN_POSN
  DEFINE_NLITEM_CONSTANT (INT_P_SIGN_POSN);
#endif
#ifdef INT_N_SIGN_POSN
  DEFINE_NLITEM_CONSTANT (INT_N_SIGN_POSN);
#endif

#undef DEFINE_NLITEM_CONSTANT

#endif /* HAVE_NL_TYPES_H */
}

void
scm_init_i18n ()
{
  SCM global_locale_smob;

#ifdef HAVE_NL_LANGINFO
  scm_add_feature ("nl-langinfo");
  define_langinfo_items ();
#endif

#include "libguile/i18n.x"

  /* Initialize the global locale object with a special `locale' SMOB.  */
  /* XXX: We don't define it as `LC_GLOBAL_LOCALE' because of bugs as of
     glibc <= 2.11 not (yet) worked around by Gnulib.  See
     http://sourceware.org/bugzilla/show_bug.cgi?id=11009 for details.  */
  SCM_NEWSMOB (global_locale_smob, scm_tc16_locale_smob_type, NULL);
  SCM_VARIABLE_SET (scm_global_locale, global_locale_smob);
}

void
scm_bootstrap_i18n ()
{
  scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
                            "scm_init_i18n",
			    (scm_t_extension_init_func) scm_init_i18n,
			    NULL);

}

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


code:
/* classes: h_files */

#ifndef SCM_I18N_H
#define SCM_I18N_H

/* Copyright (C) 2006, 2008, 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
 */

#include "libguile/__scm.h"

SCM_API SCM scm_global_locale;
SCM_API SCM scm_make_locale (SCM category_mask, SCM locale_name, SCM base_locale);
SCM_API SCM scm_locale_p (SCM obj);
SCM_API SCM scm_string_locale_lt (SCM s1, SCM s2, SCM locale);
SCM_API SCM scm_string_locale_gt (SCM s1, SCM s2, SCM locale);
SCM_API SCM scm_string_locale_ci_lt (SCM s1, SCM s2, SCM locale);
SCM_API SCM scm_string_locale_ci_gt (SCM s1, SCM s2, SCM locale);
SCM_API SCM scm_string_locale_ci_eq (SCM s1, SCM s2, SCM locale);
SCM_API SCM scm_char_locale_lt (SCM c1, SCM c2, SCM locale);
SCM_API SCM scm_char_locale_gt (SCM c1, SCM c2, SCM locale);
SCM_API SCM scm_char_locale_ci_lt (SCM c1, SCM c2, SCM locale);
SCM_API SCM scm_char_locale_ci_gt (SCM c1, SCM c2, SCM locale);
SCM_API SCM scm_char_locale_ci_eq (SCM c1, SCM c2, SCM locale);
SCM_API SCM scm_char_locale_upcase (SCM chr, SCM locale);
SCM_API SCM scm_char_locale_downcase (SCM chr, SCM locale);
SCM_API SCM scm_char_locale_titlecase (SCM chr, SCM locale);
SCM_API SCM scm_string_locale_upcase (SCM chr, SCM locale);
SCM_API SCM scm_string_locale_downcase (SCM chr, SCM locale);
SCM_API SCM scm_string_locale_titlecase (SCM chr, SCM locale);
SCM_API SCM scm_locale_string_to_integer (SCM str, SCM base, SCM locale);
SCM_API SCM scm_locale_string_to_inexact (SCM str, SCM locale);

SCM_INTERNAL SCM scm_nl_langinfo (SCM item, SCM locale);

SCM_INTERNAL void scm_init_i18n (void);
SCM_INTERNAL void scm_bootstrap_i18n (void);

#endif  /* SCM_I18N_H */

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

license: mit


code:
/* Copyright (C) 1992, 1995, 1996, 1999 Free Software Foundation, Inc.
   This file is part of the GNU C Library.

   The GNU C Library is free software; you can redistribute it and/or
   modify it under the terms of the GNU Lesser General Public
   License as published by the Free Software Foundation; either
   version 2.1 of the License, or (at your option) any later version.

   The GNU C 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 the GNU C Library; if not, write to the Free
   Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
   02111-1307 USA.  */

#ifndef SCM_IEEE_754_H
#define SCM_IEEE_754_H 1

/* Based on glibc's <ieee754.h> and modified by Ludovic Court�s to include
   all possible IEEE-754 double-precision representations.  */

/* IEEE 754 simple-precision format (32-bit).  */

union scm_ieee754_float
  {
    float f;

    struct
      {
	unsigned int negative:1;
	unsigned int exponent:8;
	unsigned int mantissa:23;
      } big_endian;

    struct
      {
      	unsigned int mantissa:23;
	unsigned int exponent:8;
	unsigned int negative:1;
      } little_endian;
  };

/* IEEE 754 double-precision format (64-bit).  */

union scm_ieee754_double
  {
    double d;

    struct
      {
	/* Big endian.  */

	unsigned int negative:1;
	unsigned int exponent:11;
	/* Together these comprise the mantissa.  */
	unsigned int mantissa0:20;
	unsigned int mantissa1:32;
      } big_endian;

    struct
      {
	/* Both byte order and word order are little endian.  */

	/* Together these comprise the mantissa.  */
	unsigned int mantissa1:32;
	unsigned int mantissa0:20;
	unsigned int exponent:11;
	unsigned int negative:1;
      } little_little_endian;

    struct
      {
	/* Byte order is little endian but word order is big endian.  Not
	   sure this is very wide spread.  */
	unsigned int mantissa0:20;
	unsigned int exponent:11;
	unsigned int negative:1;
	unsigned int mantissa1:32;
      } little_big_endian;

  };

#endif /* SCM_IEEE_754_H */


code:
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 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
 */

/* Include the headers for just about everything.
   We call all their initialization functions.  */

#ifdef HAVE_CONFIG_H
#  include <config.h>
#endif

#include <stdio.h>
#include <sys/stat.h>
#include <fcntl.h>
#include <gmp.h>

#include "libguile/_scm.h"

/* Everybody has an init function.  */
#include "libguile/alist.h"
#include "libguile/arbiters.h"
#include "libguile/async.h"
#include "libguile/backtrace.h"
#include "libguile/bitvectors.h"
#include "libguile/boolean.h"
#include "libguile/bytevectors.h"
#include "libguile/chars.h"
#include "libguile/control.h"
#include "libguile/continuations.h"
#include "libguile/debug.h"
#ifdef GUILE_DEBUG_MALLOC
#include "libguile/debug-malloc.h"
#endif
#include "libguile/deprecation.h"
#include "libguile/dynl.h"
#include "libguile/dynwind.h"
#include "libguile/eq.h"
#include "libguile/error.h"
#include "libguile/eval.h"
#include "libguile/evalext.h"
#include "libguile/expand.h"
#include "libguile/feature.h"
#include "libguile/filesys.h"
#include "libguile/fluids.h"
#include "libguile/fports.h"
#include "libguile/frames.h"
#include "libguile/gc.h"
#include "libguile/gdbint.h"
#include "libguile/generalized-arrays.h"
#include "libguile/generalized-vectors.h"
#include "libguile/goops.h"
#include "libguile/gsubr.h"
#include "libguile/hash.h"
#include "libguile/hashtab.h"
#include "libguile/hooks.h"
#include "libguile/gettext.h"
#include "libguile/i18n.h"
#include "libguile/instructions.h"
#include "libguile/iselect.h"
#include "libguile/ioext.h"
#include "libguile/keywords.h"
#include "libguile/list.h"
#include "libguile/load.h"
#include "libguile/macros.h"
#include "libguile/mallocs.h"
#include "libguile/memoize.h"
#include "libguile/modules.h"
#include "libguile/net_db.h"
#include "libguile/numbers.h"
#include "libguile/objcodes.h"
#include "libguile/objprop.h"
#include "libguile/options.h"
#include "libguile/pairs.h"
#include "libguile/ports.h"
#include "libguile/posix.h"
#ifdef HAVE_REGCOMP
#include "libguile/regex-posix.h"
#endif
#include "libguile/print.h"
#include "libguile/procprop.h"
#include "libguile/procs.h"
#include "libguile/programs.h"
#include "libguile/promises.h"
#include "libguile/properties.h"
#include "libguile/array-map.h"
#include "libguile/random.h"
#include "libguile/rdelim.h"
#include "libguile/read.h"
#include "libguile/rw.h"
#include "libguile/scmsigs.h"
#include "libguile/script.h"
#include "libguile/simpos.h"
#include "libguile/smob.h"
#include "libguile/socket.h"
#include "libguile/sort.h"
#include "libguile/srcprop.h"
#include "libguile/stackchk.h"
#include "libguile/stacks.h"
#include "libguile/stime.h"
#include "libguile/strings.h"
#include "libguile/srfi-13.h"
#include "libguile/srfi-14.h"
#include "libguile/strorder.h"
#include "libguile/strports.h"
#include "libguile/struct.h"
#include "libguile/symbols.h"
#include "libguile/throw.h"
#include "libguile/arrays.h"
#include "libguile/trees.h"
#include "libguile/values.h"
#include "libguile/variable.h"
#include "libguile/vectors.h"
#include "libguile/version.h"
#include "libguile/vm.h"
#include "libguile/vports.h"
#include "libguile/weaks.h"
#include "libguile/guardians.h"
#include "libguile/extensions.h"
#include "libguile/uniform.h"
#include "libguile/srfi-4.h"
#include "libguile/deprecated.h"

#include "libguile/init.h"
#include "libguile/private-options.h"

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

#if 0
static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define ";

static void
fixconfig (char *s1, char *s2, int s)
{
  fputs (s1, stderr);
  fputs (s2, stderr);
  fputs ("\nin ", stderr);
  fputs (s ? "setjump" : "scmfig", stderr);
  fputs (".h and recompile scm\n", stderr);
  exit (1);
}

static void
check_config (void)
{
  size_t j;

  j = HEAP_SEG_SIZE;
  if (HEAP_SEG_SIZE != j)
    fixconfig ("reduce", "size of HEAP_SEG_SIZE", 0);

#if SCM_STACK_GROWS_UP
  if (((SCM_STACKITEM *) & j - stack_start_ptr) < 0)
    fixconfig (remsg, "SCM_STACK_GROWS_UP", 1);
#else
  if ((stack_start_ptr - (SCM_STACKITEM *) & j) < 0)
    fixconfig (addmsg, "SCM_STACK_GROWS_UP", 1);
#endif
}
#endif

/* initializing standard and current I/O ports */

typedef struct
{
  int fdes;
  char *mode;
  char *name;
} stream_body_data;

/* proc to be called in scope of exception handler stream_handler. */
static SCM
stream_body (void *data)
{
  stream_body_data *body_data = (stream_body_data *) data;
  SCM port = scm_fdes_to_port (body_data->fdes, body_data->mode,
			       scm_from_locale_string (body_data->name));

  SCM_REVEALED (port) = 1;
  return port;
}

/* exception handler for stream_body.  */
static SCM
stream_handler (void *data SCM_UNUSED,
		SCM tag SCM_UNUSED,
		SCM throw_args SCM_UNUSED)
{
  return SCM_BOOL_F;
}

/* Convert a file descriptor to a port, using scm_fdes_to_port.
   - NAME is a C string, not a Guile string
   - set the revealed count for FILE's file descriptor to 1, so
   that fdes won't be closed when the port object is GC'd.
   - catch exceptions: allow Guile to be able to start up even
   if it has been handed bogus stdin/stdout/stderr.  replace the
   bad ports with void ports.  */
static SCM
scm_standard_stream_to_port (int fdes, char *mode, char *name)
{
  SCM port;
  stream_body_data body_data;

  body_data.fdes = fdes;
  body_data.mode = mode;
  body_data.name = name;
  port = scm_internal_catch (SCM_BOOL_T, stream_body, &body_data,
			     stream_handler, NULL);
  if (scm_is_false (port))
    port = scm_void_port (mode);
  return port;
}

/* Create standard ports from stdin, stdout, and stderr.  */
static void
scm_init_standard_ports ()
{
  /* From the SCSH manual:

     It can be useful to turn I/O buffering off in some cases, for
     example when an I/O stream is to be shared by multiple
     subprocesses.  For this reason, scsh allocates an unbuffered port
     for file descriptor 0 at start-up time.

     Because shells frequently share stdin with subprocesses, if the
     shell does buffered reads, it might ``steal'' input intended for
     a subprocess.  For this reason, all shells, including sh, csh,
     and scsh, read stdin unbuffered.  Applications that can tolerate
     buffered input on stdin can reset \ex{(current-input-port)} to
     block buffering for higher performance.  */

  scm_set_current_input_port
    (scm_standard_stream_to_port (0,
				  isatty (0) ? "r0" : "r",
				  "standard input"));
  scm_set_current_output_port
    (scm_standard_stream_to_port (1,
				  isatty (1) ? "w0" : "w",
				  "standard output"));
  scm_set_current_error_port
    (scm_standard_stream_to_port (2,
				  isatty (2) ? "w0" : "w",
				  "standard error"));
}

/* Loading the startup Scheme files.  */

/* The boot code "ice-9/boot-9" is only loaded by scm_boot_guile when
   this is false.  The unexec code uses this, to keep ice_9 from being
   loaded into dumped guile executables.  */
int scm_ice_9_already_loaded = 0;

void
scm_load_startup_files ()
{
  /* We want a path only containing directories from GUILE_LOAD_PATH,
     SCM_SITE_DIR and SCM_LIBRARY_DIR when searching for the site init
     file, so we do this before loading Ice-9.  */
  SCM init_path =
    scm_sys_search_load_path (scm_from_locale_string ("init.scm"));

  /* Load Ice-9.  */
  if (!scm_ice_9_already_loaded)
    {
      scm_c_primitive_load_path ("ice-9/boot-9");

      /* Load the init.scm file.  */
      if (scm_is_true (init_path))
	scm_primitive_load (init_path);
    }
}

/* The main init code.  */

#ifdef _UNICOS
typedef int setjmp_type;
#else
typedef long setjmp_type;
#endif

/* All the data needed to invoke the main function.  */
struct main_func_closure
{
  /* the function to call */
  void (*main_func)(void *closure, int argc, char **argv);
  void *closure;		/* dummy data to pass it */
  int argc;
  char **argv;			/* the argument list it should receive */
};

static void *invoke_main_func(void *body_data);

/* Fire up the Guile Scheme interpreter.

   Call MAIN_FUNC, passing it CLOSURE, ARGC, and ARGV.  MAIN_FUNC
   should do all the work of the program (initializing other packages,
   reading user input, etc.) before returning.  When MAIN_FUNC
   returns, call exit (0); this function never returns.  If you want
   some other exit value, MAIN_FUNC may call exit itself.

   scm_boot_guile arranges for program-arguments to return the strings
   given by ARGC and ARGV.  If MAIN_FUNC modifies ARGC/ARGV, should
   call scm_set_program_arguments with the final list, so Scheme code
   will know which arguments have been processed.

   scm_boot_guile establishes a catch-all catch handler which prints
   an error message and exits the process.  This means that Guile
   exits in a coherent way when system errors occur and the user isn't
   prepared to handle it.  If the user doesn't like this behavior,
   they can establish their own universal catcher to shadow this one.

   Why must the caller do all the real work from MAIN_FUNC?  The
   garbage collector assumes that all local variables of type SCM will
   be above scm_boot_guile's stack frame on the stack.  If you try to
   manipulate SCM values after this function returns, it's the luck of
   the draw whether the GC will be able to find the objects you
   allocate.  So, scm_boot_guile function exits, rather than
   returning, to discourage people from making that mistake.  */

void
scm_boot_guile (int argc, char ** argv, void (*main_func) (), void *closure)
{
  void *res;
  struct main_func_closure c;

  c.main_func = main_func;
  c.closure = closure;
  c.argc = argc;
  c.argv = argv;

  res = scm_with_guile (invoke_main_func, &c);

  /* If the caller doesn't want this, they should exit from main_func
     themselves.
  */
  if (res == NULL)
    exit (EXIT_FAILURE);
  else
    exit (0);
}

static void *
invoke_main_func (void *body_data)
{
  struct main_func_closure *closure = (struct main_func_closure *) body_data;

  scm_set_program_arguments (closure->argc, closure->argv, 0);
  (*closure->main_func) (closure->closure, closure->argc, closure->argv);

  scm_restore_signals ();

  /* This tick gives any pending
   * asyncs a chance to run.  This must be done after
   * the call to scm_restore_signals.
   */
  SCM_ASYNC_TICK;

  /* Indicate success by returning non-NULL.
   */
  return (void *)1;
}

scm_i_pthread_mutex_t scm_i_init_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
int scm_initialized_p = 0;

static void *
really_cleanup_for_exit (void *unused)
{
  scm_flush_all_ports ();
  return NULL;
}

static void
cleanup_for_exit ()
{
  if (scm_i_pthread_mutex_trylock (&scm_i_init_mutex) == 0)
    scm_i_pthread_mutex_unlock (&scm_i_init_mutex);
  else
    {
      fprintf (stderr, "Cannot exit gracefully when init is in progress; aborting.\n");
      abort ();
    }

  /* This function might be called in non-guile mode, so we need to
     enter it temporarily.
  */
  scm_with_guile (really_cleanup_for_exit, NULL);
}

void
scm_i_init_guile (SCM_STACKITEM *base)
{
  if (scm_initialized_p)
    return;

  if (base == NULL)
    {
      fprintf (stderr, "cannot determine stack base!\n");
      abort ();
    }

  if (sizeof (mpz_t) > (3 * sizeof (scm_t_bits)))
    {
      fprintf (stderr,
               "GMP's mpz_t must fit into a double_cell,"
               "but doesn't seem to here.\n");
    }

  scm_storage_prehistory ();
  scm_threads_prehistory (base);  /* requires storage_prehistory */
  scm_weaks_prehistory ();        /* requires storage_prehistory */
#ifdef GUILE_DEBUG_MALLOC
  scm_debug_malloc_prehistory ();
#endif
  scm_symbols_prehistory ();      /* requires weaks_prehistory */
  scm_modules_prehistory ();
  scm_init_array_handle ();
  scm_bootstrap_bytevectors ();   /* Requires array-handle */
  scm_bootstrap_instructions ();
  scm_bootstrap_objcodes ();
  scm_bootstrap_programs ();
  scm_bootstrap_vm ();
  scm_register_foreign ();

  scm_init_strings ();            /* Requires array-handle */
  scm_init_struct ();             /* Requires strings */
  scm_smob_prehistory ();
  scm_init_variable ();
  scm_init_continuations ();      /* requires smob_prehistory */
  scm_init_root ();		  /* requires continuations */
  scm_init_threads ();            /* requires smob_prehistory */
  scm_init_gsubr ();
  scm_init_thread_procs ();       /* requires gsubrs */
  scm_init_procprop ();
  scm_init_alist ();
  scm_init_arbiters ();           /* requires smob_prehistory */
  scm_init_async ();              /* requires smob_prehistory */
  scm_init_boolean ();
  scm_init_chars ();
#ifdef GUILE_DEBUG_MALLOC
  scm_init_debug_malloc ();
#endif
  scm_init_dynwind ();            /* requires smob_prehistory */
  scm_init_eq ();
  scm_init_error ();
  scm_init_fluids ();
  scm_init_control ();            /* requires fluids */
  scm_init_feature ();
  scm_init_backtrace ();
  scm_init_fports ();
  scm_init_strports ();
  scm_init_ports ();
  scm_init_hash ();
  scm_init_hashtab ();
  scm_init_deprecation ();
  scm_init_objprop ();
  scm_init_promises ();         /* requires smob_prehistory */
  scm_init_properties ();
  scm_init_hooks ();            /* Requires smob_prehistory */
  scm_init_gc ();		/* Requires hooks */
  scm_init_gc_protect_object ();  /* requires threads_prehistory */
  scm_init_gdbint ();           /* Requires strports, gc_protect_object */
  scm_init_gettext ();
  scm_init_ioext ();
  scm_init_keywords ();    /* Requires smob_prehistory */
  scm_init_list ();
  scm_init_macros ();      /* Requires smob_prehistory */
  scm_init_mallocs ();     /* Requires smob_prehistory */
  scm_init_modules ();     /* Requires smob_prehistory */
  scm_init_numbers ();
  scm_init_options ();
  scm_init_pairs ();
#ifdef HAVE_POSIX
  scm_init_filesys ();     /* Requires smob_prehistory */
  scm_init_posix ();
#endif
#ifdef HAVE_REGCOMP
  scm_init_regex_posix (); /* Requires smob_prehistory */
#endif
  scm_init_procs ();
  scm_init_scmsigs ();
#ifdef HAVE_NETWORKING
  scm_init_net_db ();
  scm_init_socket ();
#endif
  scm_init_sort ();
  scm_init_srcprop ();     /* requires smob_prehistory */
  scm_init_stackchk ();

  scm_init_generalized_arrays ();
  scm_init_generalized_vectors ();
  scm_init_vectors ();  /* Requires array-handle, */
  scm_init_uniform ();
  scm_init_bitvectors ();  /* Requires smob_prehistory, array-handle */
  scm_init_srfi_4 ();  /* Requires smob_prehistory, array-handle */
  scm_init_arrays ();    /* Requires smob_prehistory, array-handle */
  scm_init_array_map ();

  scm_init_frames ();   /* Requires smob_prehistory */
  scm_init_stacks ();   /* Requires strings, struct, frames */
  scm_init_symbols ();
  scm_init_values ();   /* Requires struct */
  scm_init_load ();     /* Requires strings */
  scm_init_print ();	/* Requires strings, struct, smob */
  scm_init_read ();
  scm_init_stime ();
  scm_init_strorder ();
  scm_init_srfi_13 ();
  scm_init_srfi_14 ();  /* Requires smob_prehistory */
  scm_init_throw ();    /* Requires smob_prehistory */
  scm_init_trees ();
  scm_init_version ();
  scm_init_weaks ();
  scm_init_guardians (); /* requires smob_prehistory */
  scm_init_vports ();
  scm_init_standard_ports ();  /* Requires fports */
  scm_init_expand ();   /* Requires structs */
  scm_init_memoize ();  /* Requires smob_prehistory */
  scm_init_eval ();     /* Requires smob_prehistory */
  scm_init_load_path ();
  scm_init_eval_in_scheme ();
  scm_init_evalext ();
  scm_init_debug ();	/* Requires macro smobs */
  scm_init_random ();   /* Requires smob_prehistory */
  scm_init_simpos ();
  scm_init_dynamic_linking (); /* Requires smob_prehistory */
  scm_bootstrap_i18n ();
  scm_init_script ();

  scm_init_goops ();

#if SCM_ENABLE_DEPRECATED == 1
  scm_i_init_deprecated ();
#endif

  scm_initialized_p = 1;

#ifdef STACK_CHECKING
  scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
#endif

  scm_init_rdelim ();
  scm_init_rw ();
  scm_init_extensions ();

  atexit (cleanup_for_exit);
  scm_load_startup_files ();
  scm_init_load_should_autocompile ();

  /* Capture the dynamic state after loading boot-9, so that new threads end up
     in the guile-user module. */
  scm_init_threads_default_dynamic_state ();
}

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


code:
/* classes: h_files */

#ifndef SCM_INIT_H
#define SCM_INIT_H

/* Copyright (C) 1995,1996,1997,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"
#include "libguile/threads.h"

SCM_INTERNAL scm_i_pthread_mutex_t scm_i_init_mutex;
SCM_API int scm_initialized_p;

SCM_API void scm_init_guile (void);

SCM_API void scm_boot_guile (int argc, char **argv,
			     void (*main_func) (void *closure,
						int argc,
						char **argv),
			     void *closure);

SCM_INTERNAL void scm_i_init_guile (SCM_STACKITEM *base);

SCM_API void scm_load_startup_files (void);

#endif  /* SCM_INIT_H */

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


code:
/* Copyright (C) 2001, 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
 */

#ifdef HAVE_CONFIG_H
# include <config.h>
#endif

#define SCM_INLINE_C_INCLUDING_INLINE_H 1
#include "libguile/inline.h"


code:
/* classes: h_files */

#ifndef SCM_INLINE_H
#define SCM_INLINE_H

/* Copyright (C) 2001, 2002, 2003, 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
 */

/* This file is for inline functions.  On platforms that don't support
   inlining functions, they are turned into ordinary functions.  See
   "inline.c".
*/

#include <stdio.h>
#include <string.h>

#include "libguile/__scm.h"

#include "libguile/pairs.h"
#include "libguile/gc.h"
#include "libguile/threads.h"
#include "libguile/array-handle.h"
#include "libguile/ports.h"
#include "libguile/numbers.h"
#include "libguile/error.h"

#ifndef SCM_INLINE_C_INCLUDING_INLINE_H

/* GCC has `__inline__' in all modes, including strict ansi.  GCC 4.3 and
   above with `-std=c99' or `-std=gnu99' implements ISO C99 inline semantics,
   unless `-fgnu89-inline' is used.  Here we want GNU "extern inline"
   semantics, hence the `__gnu_inline__' attribute, in accordance with:
   http://gcc.gnu.org/gcc-4.3/porting_to.html .

   With GCC 4.2, `__GNUC_STDC_INLINE__' is never defined (because C99 inline
   semantics are not supported), but a warning is issued in C99 mode if
   `__gnu_inline__' is not used.

   Apple's GCC build >5400 (since Xcode 3.0) doesn't support GNU inline in
   C99 mode and doesn't define `__GNUC_STDC_INLINE__'.  Fall back to "static
   inline" in that case.  */

# if (defined __GNUC__) && (!(((defined __APPLE_CC__) && (__APPLE_CC__ > 5400)) && __STDC_VERSION__ >= 199901L))
#  define SCM_C_USE_EXTERN_INLINE 1
#  if (defined __GNUC_STDC_INLINE__) || (__GNUC__ == 4 && __GNUC_MINOR__ == 2)
#   define SCM_C_EXTERN_INLINE					\
           extern __inline__ __attribute__ ((__gnu_inline__))
#  else
#   define SCM_C_EXTERN_INLINE extern __inline__
#  endif
# elif (defined SCM_C_INLINE)
#  define SCM_C_EXTERN_INLINE static SCM_C_INLINE
# endif

#endif /* SCM_INLINE_C_INCLUDING_INLINE_H */

#if (!defined SCM_C_INLINE) || (defined SCM_INLINE_C_INCLUDING_INLINE_H) \
    || (defined SCM_C_USE_EXTERN_INLINE)

/* The `extern' declarations.  They should only appear when used from
   "inline.c", when `inline' is not supported at all or when "extern inline"
   is used.  */

#include "libguile/bdw-gc.h"

SCM_API SCM scm_cell (scm_t_bits car, scm_t_bits cdr);
SCM_API SCM scm_immutable_cell (scm_t_bits car, scm_t_bits cdr);
SCM_API SCM scm_double_cell (scm_t_bits car, scm_t_bits cbr,
			     scm_t_bits ccr, scm_t_bits cdr);
SCM_API SCM scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
				       scm_t_bits ccr, scm_t_bits cdr);
SCM_API SCM scm_words (scm_t_bits car, scm_t_uint16 n_words);
/* no immutable words for now, would require initialization at the same time as
   allocation */

SCM_API SCM scm_array_handle_ref (scm_t_array_handle *h, ssize_t pos);
SCM_API void scm_array_handle_set (scm_t_array_handle *h, ssize_t pos, SCM val);

SCM_API int scm_is_pair (SCM x);

SCM_API int scm_get_byte_or_eof (SCM port);
SCM_API void scm_putc (char c, SCM port);
SCM_API void scm_puts (const char *str_data, SCM port);

#endif

#if defined SCM_C_EXTERN_INLINE || defined SCM_INLINE_C_INCLUDING_INLINE_H
/* either inlining, or being included from inline.c.  We use (and
   repeat) this long #if test here and below so that we don't have to
   introduce any extraneous symbols into the public namespace.  We
   only need SCM_C_INLINE to be seen publically . */

extern unsigned scm_newcell2_count;
extern unsigned scm_newcell_count;

#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
SCM_C_EXTERN_INLINE
#endif

SCM
scm_cell (scm_t_bits car, scm_t_bits cdr)
{
  SCM cell = SCM_PACK ((scm_t_bits) (GC_MALLOC (sizeof (scm_t_cell))));

  /* Initialize the type slot last so that the cell is ignored by the GC
     until it is completely initialized.  This is only relevant when the GC
     can actually run during this code, which it can't since the GC only runs
     when all other threads are stopped.  */
  SCM_GC_SET_CELL_WORD (cell, 1, cdr);
  SCM_GC_SET_CELL_WORD (cell, 0, car);

  return cell;
}

#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
SCM_C_EXTERN_INLINE
#endif
SCM
scm_immutable_cell (scm_t_bits car, scm_t_bits cdr)
{
  SCM cell = SCM_PACK ((scm_t_bits) (GC_MALLOC_STUBBORN (sizeof (scm_t_cell))));

  /* Initialize the type slot last so that the cell is ignored by the GC
     until it is completely initialized.  This is only relevant when the GC
     can actually run during this code, which it can't since the GC only runs
     when all other threads are stopped.  */
  SCM_GC_SET_CELL_WORD (cell, 1, cdr);
  SCM_GC_SET_CELL_WORD (cell, 0, car);

  GC_END_STUBBORN_CHANGE ((void *) cell);

  return cell;
}

#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
SCM_C_EXTERN_INLINE
#endif
SCM
scm_double_cell (scm_t_bits car, scm_t_bits cbr,
		 scm_t_bits ccr, scm_t_bits cdr)
{
  SCM z;

  z = SCM_PACK ((scm_t_bits) (GC_MALLOC (2 * sizeof (scm_t_cell))));
  /* Initialize the type slot last so that the cell is ignored by the
     GC until it is completely initialized.  This is only relevant
     when the GC can actually run during this code, which it can't
     since the GC only runs when all other threads are stopped.
  */
  SCM_GC_SET_CELL_WORD (z, 1, cbr);
  SCM_GC_SET_CELL_WORD (z, 2, ccr);
  SCM_GC_SET_CELL_WORD (z, 3, cdr);
  SCM_GC_SET_CELL_WORD (z, 0, car);

  /* When this function is inlined, it's possible that the last
     SCM_GC_SET_CELL_WORD above will be adjacent to a following
     initialization of z.  E.g., it occurred in scm_make_real.  GCC
     from around version 3 (e.g., certainly 3.2) began taking
     advantage of strict C aliasing rules which say that it's OK to
     interchange the initialization above and the one below when the
     pointer types appear to differ sufficiently.  We don't want that,
     of course.  GCC allows this behaviour to be disabled with the
     -fno-strict-aliasing option, but would also need to be supplied
     by Guile users.  Instead, the following statements prevent the
     reordering.
   */
#ifdef __GNUC__
  __asm__ volatile ("" : : : "memory");
#else
  /* portable version, just in case any other compiler does the same
     thing.  */
  scm_remember_upto_here_1 (z);
#endif

  return z;
}

#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
SCM_C_EXTERN_INLINE
#endif
SCM
scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
			   scm_t_bits ccr, scm_t_bits cdr)
{
  SCM z;

  z = SCM_PACK ((scm_t_bits) (GC_MALLOC_STUBBORN (2 * sizeof (scm_t_cell))));
  /* Initialize the type slot last so that the cell is ignored by the
     GC until it is completely initialized.  This is only relevant
     when the GC can actually run during this code, which it can't
     since the GC only runs when all other threads are stopped.
  */
  SCM_GC_SET_CELL_WORD (z, 1, cbr);
  SCM_GC_SET_CELL_WORD (z, 2, ccr);
  SCM_GC_SET_CELL_WORD (z, 3, cdr);
  SCM_GC_SET_CELL_WORD (z, 0, car);

  GC_END_STUBBORN_CHANGE ((void *) z);

  /* When this function is inlined, it's possible that the last
     SCM_GC_SET_CELL_WORD above will be adjacent to a following
     initialization of z.  E.g., it occurred in scm_make_real.  GCC
     from around version 3 (e.g., certainly 3.2) began taking
     advantage of strict C aliasing rules which say that it's OK to
     interchange the initialization above and the one below when the
     pointer types appear to differ sufficiently.  We don't want that,
     of course.  GCC allows this behaviour to be disabled with the
     -fno-strict-aliasing option, but would also need to be supplied
     by Guile users.  Instead, the following statements prevent the
     reordering.
   */
#ifdef __GNUC__
  __asm__ volatile ("" : : : "memory");
#else
  /* portable version, just in case any other compiler does the same
     thing.  */
  scm_remember_upto_here_1 (z);
#endif

  return z;
}

#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
SCM_C_EXTERN_INLINE
#endif
SCM
scm_words (scm_t_bits car, scm_t_uint16 n_words)
{
  SCM z;

  z = SCM_PACK ((scm_t_bits) (GC_MALLOC (sizeof (scm_t_bits) * n_words)));
  SCM_GC_SET_CELL_WORD (z, 0, car);

  /* FIXME: is the following concern even relevant with BDW-GC? */

  /* When this function is inlined, it's possible that the last
     SCM_GC_SET_CELL_WORD above will be adjacent to a following
     initialization of z.  E.g., it occurred in scm_make_real.  GCC
     from around version 3 (e.g., certainly 3.2) began taking
     advantage of strict C aliasing rules which say that it's OK to
     interchange the initialization above and the one below when the
     pointer types appear to differ sufficiently.  We don't want that,
     of course.  GCC allows this behaviour to be disabled with the
     -fno-strict-aliasing option, but would also need to be supplied
     by Guile users.  Instead, the following statements prevent the
     reordering.
   */
#ifdef __GNUC__
  __asm__ volatile ("" : : : "memory");
#else
  /* portable version, just in case any other compiler does the same
     thing.  */
  scm_remember_upto_here_1 (z);
#endif

  return z;
}

#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
SCM_C_EXTERN_INLINE
#endif
SCM
scm_array_handle_ref (scm_t_array_handle *h, ssize_t p)
{
  if (SCM_UNLIKELY (p < 0 && ((size_t)-p) > h->base))
    /* catch overflow */
    scm_out_of_range (NULL, scm_from_ssize_t (p));
  /* perhaps should catch overflow here too */
  return h->impl->vref (h, h->base + p);
}

#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
SCM_C_EXTERN_INLINE
#endif
void
scm_array_handle_set (scm_t_array_handle *h, ssize_t p, SCM v)
{
  if (SCM_UNLIKELY (p < 0 && ((size_t)-p) > h->base))
    /* catch overflow */
    scm_out_of_range (NULL, scm_from_ssize_t (p));
  /* perhaps should catch overflow here too */
  h->impl->vset (h, h->base + p, v);
}

#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
SCM_C_EXTERN_INLINE
#endif
int
scm_is_pair (SCM x)
{
  /* The following "workaround_for_gcc_295" avoids bad code generated by
     i386 gcc 2.95.4 (the Debian packaged 2.95.4-24 at least).

     Under the default -O2 the inlined SCM_I_CONSP test gets "optimized" so
     the fetch of the tag word from x is done before confirming it's a
     non-immediate (SCM_NIMP).  Needless to say that bombs badly if x is a
     immediate.  This was seen to afflict scm_srfi1_split_at and something
     deep in the bowels of ceval().  In both cases segvs resulted from
     deferencing a random immediate value.  srfi-1.test exposes the problem
     through a short list, the immediate being SCM_EOL in that case.
     Something in syntax.test exposed the ceval() problem.

     Just "volatile SCM workaround_for_gcc_295 = lst" is enough to avoid the
     problem, without even using that variable.  The "w=w" is just to
     prevent a warning about it being unused.
     */
#if defined (__GNUC__) && __GNUC__ == 2 && __GNUC_MINOR__ == 95
  volatile SCM workaround_for_gcc_295 = x;
  workaround_for_gcc_295 = workaround_for_gcc_295;
#endif

  return SCM_I_CONSP (x);
}

/* Port I/O.  */

#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
SCM_C_EXTERN_INLINE
#endif
int
scm_get_byte_or_eof (SCM port)
{
  int c;
  scm_t_port *pt = SCM_PTAB_ENTRY (port);

  if (pt->rw_active == SCM_PORT_WRITE)
    /* may be marginally faster than calling scm_flush.  */
    scm_ptobs[SCM_PTOBNUM (port)].flush (port);

  if (pt->rw_random)
    pt->rw_active = SCM_PORT_READ;

  if (pt->read_pos >= pt->read_end)
    {
      if (scm_fill_input (port) == EOF)
	return EOF;
    }

  c = *(pt->read_pos++);

  return c;
}

#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
SCM_C_EXTERN_INLINE
#endif
void
scm_putc (char c, SCM port)
{
  SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port");
  scm_lfwrite (&c, 1, port);
}

#ifndef SCM_INLINE_C_INCLUDING_INLINE_H
SCM_C_EXTERN_INLINE
#endif
void
scm_puts (const char *s, SCM port)
{
  SCM_ASSERT_TYPE (SCM_OPOUTPORTP (port), port, 0, NULL, "output port");
  scm_lfwrite (s, strlen (s), port);
}

#endif
#endif


code:
/* Copyright (C) 2001, 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
 */

#if HAVE_CONFIG_H
#  include <config.h>
#endif

#include <string.h>

#include "_scm.h"
#include "instructions.h"

struct scm_instruction {
  enum scm_opcode opcode;	/* opcode */
  const char *name;		/* instruction name */
  signed char len;		/* Instruction length.  This may be -1 for
				   the loader (see the `VM_LOADER'
				   macro).  */
  signed char npop;		/* The number of values popped.  This may be
				   -1 for insns like `call' which can take
				   any number of arguments.  */
  char npush;			/* the number of values pushed */
  SCM symname;                  /* filled in later */
};

#define SCM_VALIDATE_LOOKUP_INSTRUCTION(pos, var, cvar)               \
  do {                                                                \
    cvar = scm_lookup_instruction_by_name (var);                      \
    SCM_ASSERT_TYPE (cvar, var, pos, FUNC_NAME, "INSTRUCTION_P");     \
  } while (0)

static struct scm_instruction*
fetch_instruction_table ()
{
  static struct scm_instruction *table = NULL;

  if (SCM_UNLIKELY (!table))
    {
      size_t bytes = SCM_VM_NUM_INSTRUCTIONS * sizeof(struct scm_instruction);
      int i;
      table = malloc (bytes);
      memset (table, 0, bytes);
#define VM_INSTRUCTION_TO_TABLE 1
#include <libguile/vm-expand.h>
#include <libguile/vm-i-system.i>
#include <libguile/vm-i-scheme.i>
#include <libguile/vm-i-loader.i>
#undef VM_INSTRUCTION_TO_TABLE
      for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
        {
          table[i].opcode = i;
          if (table[i].name)
            table[i].symname = scm_from_locale_symbol (table[i].name);
          else
            table[i].symname = SCM_BOOL_F;
        }
    }
  return table;
}

static struct scm_instruction *
scm_lookup_instruction_by_name (SCM name)
{
  static SCM instructions_by_name = SCM_BOOL_F;
  struct scm_instruction *table = fetch_instruction_table ();
  SCM op;

  if (SCM_UNLIKELY (scm_is_false (instructions_by_name)))
    {
      unsigned int i;

      instructions_by_name =
        scm_make_hash_table (SCM_I_MAKINUM (SCM_VM_NUM_INSTRUCTIONS));

      for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
        if (scm_is_true (table[i].symname))
          scm_hashq_set_x (instructions_by_name, table[i].symname,
                           SCM_I_MAKINUM (i));
    }

  op = scm_hashq_ref (instructions_by_name, name, SCM_UNDEFINED);
  if (SCM_I_INUMP (op))
    return &table[SCM_I_INUM (op)];

  return NULL;
}

/* Scheme interface */

SCM_DEFINE (scm_instruction_list, "instruction-list", 0, 0, 0,
	    (void),
	    "")
#define FUNC_NAME s_scm_instruction_list
{
  SCM list = SCM_EOL;
  int i;
  struct scm_instruction *ip = fetch_instruction_table ();
  for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
    if (ip[i].name)
      list = scm_cons (ip[i].symname, list);
  return scm_reverse_x (list, SCM_EOL);
}
#undef FUNC_NAME

SCM_DEFINE (scm_instruction_p, "instruction?", 1, 0, 0,
	    (SCM obj),
	    "")
#define FUNC_NAME s_scm_instruction_p
{
  return scm_from_bool (scm_lookup_instruction_by_name (obj) != NULL);
}
#undef FUNC_NAME

SCM_DEFINE (scm_instruction_length, "instruction-length", 1, 0, 0,
	    (SCM inst),
	    "")
#define FUNC_NAME s_scm_instruction_length
{
  struct scm_instruction *ip;
  SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
  return SCM_I_MAKINUM (ip->len);
}
#undef FUNC_NAME

SCM_DEFINE (scm_instruction_pops, "instruction-pops", 1, 0, 0,
	    (SCM inst),
	    "")
#define FUNC_NAME s_scm_instruction_pops
{
  struct scm_instruction *ip;
  SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
  return SCM_I_MAKINUM (ip->npop);
}
#undef FUNC_NAME

SCM_DEFINE (scm_instruction_pushes, "instruction-pushes", 1, 0, 0,
	    (SCM inst),
	    "")
#define FUNC_NAME s_scm_instruction_pushes
{
  struct scm_instruction *ip;
  SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
  return SCM_I_MAKINUM (ip->npush);
}
#undef FUNC_NAME

SCM_DEFINE (scm_instruction_to_opcode, "instruction->opcode", 1, 0, 0,
	    (SCM inst),
	    "")
#define FUNC_NAME s_scm_instruction_to_opcode
{
  struct scm_instruction *ip;
  SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip);
  return SCM_I_MAKINUM (ip->opcode);
}
#undef FUNC_NAME

SCM_DEFINE (scm_opcode_to_instruction, "opcode->instruction", 1, 0, 0,
	    (SCM op),
	    "")
#define FUNC_NAME s_scm_opcode_to_instruction
{
  int opcode;
  SCM ret = SCM_BOOL_F;

  SCM_MAKE_VALIDATE (1, op, I_INUMP);
  opcode = SCM_I_INUM (op);

  if (opcode >= 0 && opcode < SCM_VM_NUM_INSTRUCTIONS)
    ret = fetch_instruction_table ()[opcode].symname;

  if (scm_is_false (ret))
    scm_wrong_type_arg_msg (FUNC_NAME, 1, op, "INSTRUCTION_P");

  return ret;
}
#undef FUNC_NAME

void
scm_bootstrap_instructions (void)
{
  scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
                            "scm_init_instructions",
                            (scm_t_extension_init_func)scm_init_instructions,
                            NULL);
}

void
scm_init_instructions (void)
{
#ifndef SCM_MAGIC_SNARFER
#include "libguile/instructions.x"
#endif
}

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


code:
/* Copyright (C) 2001, 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
 */

#ifndef _SCM_INSTRUCTIONS_H_
#define _SCM_INSTRUCTIONS_H_

#include <libguile.h>

#define SCM_VM_NUM_INSTRUCTIONS (1<<8)
#define SCM_VM_INSTRUCTION_MASK (SCM_VM_NUM_INSTRUCTIONS-1)

enum scm_opcode {
#define VM_INSTRUCTION_TO_OPCODE 1
#include <libguile/vm-expand.h>
#include <libguile/vm-i-system.i>
#include <libguile/vm-i-scheme.i>
#include <libguile/vm-i-loader.i>
#undef VM_INSTRUCTION_TO_OPCODE
};

SCM_API SCM scm_instruction_list (void);
SCM_API SCM scm_instruction_p (SCM obj);
SCM_API SCM scm_instruction_length (SCM inst);
SCM_API SCM scm_instruction_pops (SCM inst);
SCM_API SCM scm_instruction_pushes (SCM inst);
SCM_API SCM scm_instruction_to_opcode (SCM inst);
SCM_API SCM scm_opcode_to_instruction (SCM op);

SCM_INTERNAL void scm_bootstrap_instructions (void);
SCM_INTERNAL void scm_init_instructions (void);

#endif /* _SCM_INSTRUCTIONS_H_ */

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