-/* Copyright (C) 2006 Free Software Foundation, Inc.
+/* Copyright (C) 2006, 2007, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * 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
+ * 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
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
-#define _GNU_SOURCE /* Ask for glibc's `newlocale' API */
-
-#if HAVE_CONFIG_H
+#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
-#if HAVE_ALLOCA_H
-# include <alloca.h>
-#elif defined __GNUC__
-# define alloca __builtin_alloca
-#elif defined _AIX
-# define alloca __alloca
-#elif defined _MSC_VER
-# include <malloc.h>
-# define alloca _alloca
-#else
-# include <stddef.h>
-# ifdef __cplusplus
-extern "C"
-# endif
-void *alloca (size_t);
-#endif
+#include <alloca.h>
#include "libguile/_scm.h"
#include "libguile/feature.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 <errno.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
-#ifndef USE_GNU_LOCALE_API
-# include "libguile/posix.h" /* for `scm_i_locale_mutex' */
+#if (defined USE_GNU_LOCALE_API) && (defined HAVE_XLOCALE_H)
+# include <xlocale.h>
+#endif
+
+#include "libguile/posix.h" /* for `scm_i_locale_mutex' */
+
+#if (defined HAVE_LANGINFO_H) && (defined HAVE_NL_TYPES_H)
+# include <langinfo.h>
+# include <nl_types.h>
#endif
#ifndef HAVE_SETLOCALE
}
#endif
+/* Helper stringification macro. */
+#define SCM_I18N_STRINGIFY(_name) # _name
+
\f
/* Locale objects, string and character collation, and other locale-dependent
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_t_locale_mutex' is locked.
+ 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_settings' object.
+ 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_t_locale_mutex' is released.
+ 5. The `scm_i_locale_mutex' is released.
- Hopefully, some smart standard will make that hack useless someday...
- A similar API can be found in MzScheme starting from version 200:
- http://download.plt-scheme.org/chronology/mzmr200alpha14.html .
+ 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
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 (copied from
- <locale.h> as found in glibc 2.3.6). This must be kept in sync with
- `locale-categories.h'. */
+/* Provide the locale category masks as found in glibc. This must be kept in
+ sync with `locale-categories.h'. */
-# define LC_CTYPE_MASK (1 << LC_CTYPE)
-# define LC_COLLATE_MASK (1 << LC_COLLATE)
-# define LC_MESSAGES_MASK (1 << LC_MESSAGES)
-# define LC_MONETARY_MASK (1 << LC_MONETARY)
-# define LC_NUMERIC_MASK (1 << LC_NUMERIC)
-# define LC_TIME_MASK (1 << LC_TIME)
+# 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 (1 << LC_PAPER)
+# define LC_PAPER_MASK 64
# else
# define LC_PAPER_MASK 0
# endif
# ifdef LC_NAME
-# define LC_NAME_MASK (1 << LC_NAME)
+# define LC_NAME_MASK 128
# else
# define LC_NAME_MASK 0
# endif
# ifdef LC_ADDRESS
-# define LC_ADDRESS_MASK (1 << LC_ADDRESS)
+# define LC_ADDRESS_MASK 256
# else
# define LC_ADDRESS_MASK 0
# endif
# ifdef LC_TELEPHONE
-# define LC_TELEPHONE_MASK (1 << LC_TELEPHONE)
+# define LC_TELEPHONE_MASK 512
# else
# define LC_TELEPHONE_MASK 0
# endif
# ifdef LC_MEASUREMENT
-# define LC_MEASUREMENT_MASK (1 << LC_MEASUREMENT)
+# define LC_MEASUREMENT_MASK 1024
# else
# define LC_MEASUREMENT_MASK 0
# endif
# ifdef LC_IDENTIFICATION
-# define LC_IDENTIFICATION_MASK (1 << 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 \
+# 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. */
int category_mask;
} *scm_t_locale;
-#else
+
+/* 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;
-#endif
+#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. */
{
scm_t_locale c_locale;
- c_locale = (scm_t_locale)SCM_SMOB_DATA (locale);
-
-#ifdef USE_GNU_LOCALE_API
- freelocale ((locale_t)c_locale);
-#else
- c_locale->base_locale = SCM_UNDEFINED;
- free (c_locale->locale_name);
-
- scm_gc_free (c_locale, sizeof (* c_locale), "locale");
-#endif
+ c_locale = (scm_t_locale) SCM_SMOB_DATA (locale);
+ scm_i_locale_free (c_locale);
return 0;
}
static SCM
smob_locale_mark (SCM locale)
{
- scm_t_locale c_locale;
-
- c_locale = (scm_t_locale)SCM_SMOB_DATA (locale);
- return (c_locale->base_locale);
-}
-#endif
-
+ register SCM dependency;
-SCM_DEFINE (scm_make_locale, "make-locale", 2, 1, 0,
- (SCM category_mask, SCM locale_name, SCM base_locale),
- "Return a reference to a data structure representing a set of "
- "locale datasets. Unlike for the @var{category} parameter for "
- "@code{setlocale}, the @var{category_mask} parameter here uses "
- "a single bit for each category, made by OR'ing together "
- "@code{LC_*_MASK} bits.")
-#define FUNC_NAME s_scm_make_locale
-{
- SCM locale = SCM_BOOL_F;
- int c_category_mask;
- char *c_locale_name;
- scm_t_locale c_base_locale, c_locale;
-
- SCM_VALIDATE_INT_COPY (1, category_mask, c_category_mask);
- SCM_VALIDATE_STRING (2, locale_name);
- SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, base_locale, c_base_locale);
-
- c_locale_name = scm_to_locale_string (locale_name);
-
-#ifdef USE_GNU_LOCALE_API
-
- c_locale = newlocale (c_category_mask, c_locale_name, c_base_locale);
+ if (!scm_is_eq (locale, SCM_VARIABLE_REF (scm_global_locale)))
+ {
+ scm_t_locale c_locale;
- if (!c_locale)
- locale = SCM_BOOL_F;
+ c_locale = (scm_t_locale) SCM_SMOB_DATA (locale);
+ dependency = (c_locale->base_locale);
+ }
else
- SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale);
-
- free (c_locale_name);
-
-#else
-
- c_locale = scm_gc_malloc (sizeof (* c_locale), "locale");
- c_locale->base_locale = base_locale;
-
- c_locale->category_mask = c_category_mask;
- c_locale->locale_name = c_locale_name;
-
- SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale);
+ dependency = SCM_BOOL_F;
+ return dependency;
+}
#endif
- return locale;
-}
-#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
-{
- if (SCM_SMOB_PREDICATE (scm_tc16_locale_smob_type, obj))
- return SCM_BOOL_T;
+static void inline scm_locale_error (const char *, int) SCM_NORETURN;
- return SCM_BOOL_F;
+/* 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);
}
-#undef FUNC_NAME
\f
-#ifndef USE_GNU_LOCALE_API /* Emulate GNU's reentrant locale API. */
+/* Emulating GNU's reentrant locale API. */
+#ifndef USE_GNU_LOCALE_API
/* Maximum number of chained locales (via `base_locale'). */
#define SCM_DEFINE_LOCALE_CATEGORY(_name) \
{ \
SCM_SYSCALL (locale_name = setlocale (LC_ ## _name, NULL)); \
- if (!locale_name) \
+ if (locale_name == NULL) \
goto handle_error; \
\
settings-> _name = strdup (locale_name); \
return 0;
handle_error:
- return errno;
+ return EINVAL;
handle_oom:
return ENOMEM;
return 0;
handle_error:
- return errno;
+ return EINVAL;
}
/* Free memory associated with SETTINGS. */
else
{
#define SCM_DEFINE_LOCALE_CATEGORY(_name) \
- if (category_mask & LC_ ## _name ## _MASK) \
+ if (category_mask & SCM_LOCALE_CATEGORY_MASK (_name)) \
{ \
SCM_SYSCALL (result = setlocale (LC_ ## _name, locale_name)); \
if (result == NULL) \
return 0;
handle_error:
- return errno;
+ return EINVAL;
}
/* Install LOCALE, recursively installing its base locales first. On
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;
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);
+ locale = (scm_t_locale) SCM_SMOB_DATA (locale->base_locale);
else
locale = NULL;
}
- while (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"));
return 0;
handle_error:
- return errno;
+ return EINVAL;
}
/* Leave the locked locale section. */
return err;
}
-/* Throw an exception corresponding to error ERR. */
-static void inline
-scm_locale_error (const char *func_name, int err)
-{
- SCM s_err;
-
- s_err = scm_from_int (err);
- scm_error (scm_system_error_key, func_name,
- "Failed to install locale",
- scm_cons (scm_strerror (s_err), SCM_EOL),
- scm_cons (s_err, SCM_EOL));
-}
-
/* Convenient macro to run STATEMENT in the locale context of C_LOCALE. */
#define RUN_IN_LOCALE_SECTION(_c_locale, _statement) \
do \
} \
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;
+}
+
+
#endif /* !USE_GNU_LOCALE_API */
+
+\f
+/* `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)))
+ {
+ /* Fetch the current locale and turn in into a `locale_t'. Don't
+ duplicate the resulting `locale_t' because we want it to be consumed
+ by `newlocale ()'. */
+ char *current_locale;
+
+ scm_i_pthread_mutex_lock (&scm_i_locale_mutex);
+
+ current_locale = setlocale (LC_ALL, NULL);
+ c_base_locale = newlocale (LC_ALL_MASK, current_locale, NULL);
+
+ scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
+
+ if (c_base_locale == (locale_t) 0)
+ scm_locale_error (FUNC_NAME, errno);
+ }
+ else 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 (scm_is_eq (base_locale, SCM_VARIABLE_REF (scm_global_locale)))
+ /* The base locale object was created lazily and must be freed. */
+ 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
+
+
\f
-/* Locale-dependent string comparison. */
+/* Locale-dependent string comparison.
+
+ A similar API can be found in MzScheme starting from version 200:
+ http://download.plt-scheme.org/chronology/mzmr200alpha14.html . */
+
/* Compare null-terminated strings C_S1 and C_S2 according to LOCALE. Return
an integer whose sign is the same as the difference between C_S1 and
str_upcase (register char *dst, register const char *src)
{
for (; *src != '\0'; src++, dst++)
- *dst = toupper (*src);
+ *dst = toupper ((int) *src);
*dst = '\0';
}
str_downcase (register char *dst, register const char *src)
{
for (; *src != '\0'; src++, dst++)
- *dst = tolower (*src);
+ *dst = tolower ((int) *src);
*dst = '\0';
}
if (c_locale != NULL)
{
#ifdef USE_GNU_LOCALE_API
- c_result = tolower_l (c_chr, c_locale);
+ c_result = tolower_l ((int) c_chr, c_locale);
#else
- RUN_IN_LOCALE_SECTION (c_locale, c_result = tolower (c_chr));
+ RUN_IN_LOCALE_SECTION (c_locale, c_result = tolower ((int) c_chr));
#endif
}
else
- c_result = tolower (c_chr);
+ c_result = tolower ((int) c_chr);
return (SCM_MAKE_CHAR (c_result));
}
if (c_locale != NULL)
{
#ifdef USE_GNU_LOCALE_API
- c_result = toupper_l (c_chr, c_locale);
+ c_result = toupper_l ((int) c_chr, c_locale);
#else
- RUN_IN_LOCALE_SECTION (c_locale, c_result = toupper (c_chr));
+ RUN_IN_LOCALE_SECTION (c_locale, c_result = toupper ((int) c_chr));
#endif
}
else
- c_result = toupper (c_chr);
+ c_result = toupper ((int) c_chr);
return (SCM_MAKE_CHAR (c_result));
}
}
#undef FUNC_NAME
-
\f
-void
-scm_init_i18n ()
+/* 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, thereby defeating `scm_from_locale_string ()'.
+ Example: support the current locale is "Latin-1" and one asks:
+
+ (nl-langinfo DAY_1 (make-locale LC_ALL "eo_EO.UTF-8"))
+
+ The result will be a UTF-8 string. However, `scm_from_locale_string',
+ which expects a Latin-1 string, won't be able to make much sense of the
+ returned string. Thus, we'd need an `scm_from_string ()' variant where
+ the locale (or charset) is explicitly passed. */
+
+
+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
{
- scm_add_feature ("ice-9-i18n");
+#ifdef HAVE_NL_LANGINFO
+ SCM result;
+ nl_item c_item;
+ char *c_result;
+ scm_t_locale c_locale;
-#define _SCM_STRINGIFY_LC(_name) # _name
-#define SCM_STRINGIFY_LC(_name) _SCM_STRINGIFY_LC (_name)
+ SCM_VALIDATE_INT_COPY (2, item, c_item);
+ SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
- /* Define all the relevant `_MASK' variables. */
-#define SCM_DEFINE_LOCALE_CATEGORY(_name) \
- scm_c_define ("LC_" SCM_STRINGIFY_LC (_name) "_MASK", \
- SCM_I_MAKINUM (LC_ ## _name ## _MASK));
-#include "locale-categories.h"
+ /* 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. */
-#undef SCM_DEFINE_LOCALE_CATEGORY
-#undef SCM_STRINGIFY_LC
-#undef _SCM_STRINGIFY_LC
+ 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);
+#else
+ /* 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);
+
+ restore_locale_settings (&lsec_prev_locale);
+ free_locale_settings (&lsec_prev_locale);
+ }
+#endif
+ }
+ else
+ c_result = nl_langinfo (c_item);
+
+ 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:
+ /* FIXME: `locale_string ()' is not appropriate here because of
+ encoding issues (see comment above). */
+ result = scm_take_locale_string (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)
+{
+#if (defined HAVE_NL_TYPES_H) && (defined 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
- scm_c_define ("LC_ALL_MASK", SCM_I_MAKINUM (LC_ALL_MASK));
+ /* 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 */
+}
+
+\f
+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"
#ifndef USE_GNU_LOCALE_API
scm_set_smob_mark (scm_tc16_locale_smob_type, smob_locale_mark);
#endif
+
+ /* Initialize the global locale object with a special `locale' SMOB. */
+ SCM_NEWSMOB (global_locale_smob, scm_tc16_locale_smob_type, NULL);
+ SCM_VARIABLE_SET (scm_global_locale, global_locale_smob);
}
HCoop / bpt / guile.git / blobdiff