1 /* Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
25 #include "libguile/_scm.h"
26 #include "libguile/extensions.h"
27 #include "libguile/feature.h"
28 #include "libguile/i18n.h"
29 #include "libguile/strings.h"
30 #include "libguile/chars.h"
31 #include "libguile/dynwind.h"
32 #include "libguile/validate.h"
33 #include "libguile/values.h"
34 #include "libguile/threads.h"
37 #include <string.h> /* `strcoll ()' */
38 #include <ctype.h> /* `toupper ()' et al. */
43 #if (defined HAVE_NEWLOCALE) && (defined HAVE_STRCOLL_L)
44 /* The GNU thread-aware locale API is documented in ``Thread-Aware Locale
45 Model, a Proposal'', by Ulrich Drepper:
47 http://people.redhat.com/drepper/tllocale.ps.gz
49 It is now also implemented by Darwin:
51 http://developer.apple.com/documentation/Darwin/Reference/ManPages/man3/newlocale.3.html
53 The whole API was eventually standardized in the ``Open Group Base
54 Specifications Issue 7'' (aka. "POSIX 2008"):
56 http://www.opengroup.org/onlinepubs/9699919799/basedefs/locale.h.html */
57 # define USE_GNU_LOCALE_API
60 #include "libguile/posix.h" /* for `scm_i_locale_mutex' */
62 #ifdef HAVE_LANGINFO_H
63 # include <langinfo.h>
65 #ifdef HAVE_NL_TYPES_H
66 # include <nl_types.h>
69 /* Cygwin has <langinfo.h> but lacks <nl_types.h> and `nl_item'. */
73 #ifndef HAVE_SETLOCALE
75 setlocale (int category
, const char *name
)
82 /* Helper stringification macro. */
83 #define SCM_I18N_STRINGIFY(_name) # _name
85 /* Acquiring and releasing the locale lock. */
88 lock_locale_mutex (void)
91 scm_i_pthread_mutex_lock (&scm_i_locale_mutex
);
97 unlock_locale_mutex (void)
100 scm_i_pthread_mutex_unlock (&scm_i_locale_mutex
);
106 /* Locale objects, string and character collation, and other locale-dependent
109 A large part of the code here deals with emulating glibc's reentrant
110 locale API on non-GNU systems. The emulation is a bit "brute-force":
111 Whenever a `-locale<?' procedure is passed a locale object, then:
113 1. The `scm_i_locale_mutex' is locked.
114 2. A series of `setlocale ()' call is performed to store the current
115 locale for each category in an `scm_t_locale' object.
116 3. A series of `setlocale ()' call is made to install each of the locale
117 categories of each of the base locales of each locale object,
118 recursively, starting from the last locale object of the chain.
119 4. The settings captured in step (2) are restored.
120 5. The `scm_i_locale_mutex' is released.
122 Hopefully, the X/Open standard will eventually make this hack useless.
124 Note: We don't wrap glibc's `uselocale ()' call because it sets the locale
125 of the current _thread_ (unlike `setlocale ()') and doing so would require
126 maintaining per-thread locale information on non-GNU systems and always
127 re-installing this locale upon locale-dependent calls. */
130 /* Return the category mask corresponding to CAT. */
131 #define SCM_LOCALE_CATEGORY_MASK(_cat) LC_ ## _cat ## _MASK
134 #ifndef USE_GNU_LOCALE_API
136 /* Provide the locale category masks as found in glibc. This must be kept in
137 sync with `locale-categories.h'. */
139 # define LC_CTYPE_MASK 1
140 # define LC_COLLATE_MASK 2
141 # define LC_MESSAGES_MASK 4
142 # define LC_MONETARY_MASK 8
143 # define LC_NUMERIC_MASK 16
144 # define LC_TIME_MASK 32
147 # define LC_PAPER_MASK 64
149 # define LC_PAPER_MASK 0
152 # define LC_NAME_MASK 128
154 # define LC_NAME_MASK 0
157 # define LC_ADDRESS_MASK 256
159 # define LC_ADDRESS_MASK 0
162 # define LC_TELEPHONE_MASK 512
164 # define LC_TELEPHONE_MASK 0
166 # ifdef LC_MEASUREMENT
167 # define LC_MEASUREMENT_MASK 1024
169 # define LC_MEASUREMENT_MASK 0
171 # ifdef LC_IDENTIFICATION
172 # define LC_IDENTIFICATION_MASK 2048
174 # define LC_IDENTIFICATION_MASK 0
177 # define LC_ALL_MASK (LC_CTYPE_MASK \
186 | LC_TELEPHONE_MASK \
187 | LC_MEASUREMENT_MASK \
188 | LC_IDENTIFICATION_MASK \
191 /* Locale objects as returned by `make-locale' on non-GNU systems. */
192 typedef struct scm_locale
194 SCM base_locale
; /* a `locale' object */
200 /* Free the resources used by LOCALE. */
202 scm_i_locale_free (scm_t_locale locale
)
204 free (locale
->locale_name
);
205 locale
->locale_name
= NULL
;
208 #else /* USE_GNU_LOCALE_API */
210 /* Alias for glibc's locale type. */
211 typedef locale_t scm_t_locale
;
213 #define scm_i_locale_free freelocale
215 #endif /* USE_GNU_LOCALE_API */
218 /* A locale object denoting the global locale. */
219 SCM_GLOBAL_VARIABLE (scm_global_locale
, "%global-locale");
222 /* Validate parameter ARG as a locale object and set C_LOCALE to the
223 corresponding C locale object. */
224 #define SCM_VALIDATE_LOCALE_COPY(_pos, _arg, _c_locale) \
227 SCM_VALIDATE_SMOB ((_pos), (_arg), locale_smob_type); \
228 (_c_locale) = (scm_t_locale)SCM_SMOB_DATA (_arg); \
232 /* Validate optional parameter ARG as either undefined or bound to a locale
233 object. Set C_LOCALE to the corresponding C locale object or NULL. */
234 #define SCM_VALIDATE_OPTIONAL_LOCALE_COPY(_pos, _arg, _c_locale) \
237 if (!scm_is_eq ((_arg), SCM_UNDEFINED)) \
238 SCM_VALIDATE_LOCALE_COPY (_pos, _arg, _c_locale); \
240 (_c_locale) = NULL; \
245 SCM_SMOB (scm_tc16_locale_smob_type
, "locale", 0);
247 SCM_SMOB_FREE (scm_tc16_locale_smob_type
, smob_locale_free
, locale
)
249 scm_t_locale c_locale
;
251 c_locale
= (scm_t_locale
) SCM_SMOB_DATA (locale
);
252 scm_i_locale_free (c_locale
);
258 static void inline scm_locale_error (const char *, int) SCM_NORETURN
;
260 /* Throw an exception corresponding to error ERR. */
262 scm_locale_error (const char *func_name
, int err
)
264 scm_syserror_msg (func_name
,
265 "Failed to install locale",
271 /* Emulating GNU's reentrant locale API. */
272 #ifndef USE_GNU_LOCALE_API
275 /* Maximum number of chained locales (via `base_locale'). */
276 #define LOCALE_STACK_SIZE_MAX 256
280 #define SCM_DEFINE_LOCALE_CATEGORY(_name) char * _name;
281 #include "locale-categories.h"
282 #undef SCM_DEFINE_LOCALE_CATEGORY
283 } scm_t_locale_settings
;
285 /* Fill out SETTINGS according to the current locale settings. On success
286 zero is returned and SETTINGS is properly initialized. */
288 get_current_locale_settings (scm_t_locale_settings
*settings
)
290 const char *locale_name
;
292 #define SCM_DEFINE_LOCALE_CATEGORY(_name) \
294 SCM_SYSCALL (locale_name = setlocale (LC_ ## _name, NULL)); \
295 if (locale_name == NULL) \
298 settings-> _name = strdup (locale_name); \
299 if (settings-> _name == NULL) \
303 #include "locale-categories.h"
304 #undef SCM_DEFINE_LOCALE_CATEGORY
315 /* Restore locale settings SETTINGS. On success, return zero. */
317 restore_locale_settings (const scm_t_locale_settings
*settings
)
321 #define SCM_DEFINE_LOCALE_CATEGORY(_name) \
322 SCM_SYSCALL (result = setlocale (LC_ ## _name, settings-> _name)); \
323 if (result == NULL) \
326 #include "locale-categories.h"
327 #undef SCM_DEFINE_LOCALE_CATEGORY
335 /* Free memory associated with SETTINGS. */
337 free_locale_settings (scm_t_locale_settings
*settings
)
339 #define SCM_DEFINE_LOCALE_CATEGORY(_name) \
340 free (settings-> _name); \
341 settings->_name = NULL;
342 #include "locale-categories.h"
343 #undef SCM_DEFINE_LOCALE_CATEGORY
346 /* Install the locale named LOCALE_NAME for all the categories listed in
349 install_locale_categories (const char *locale_name
, int category_mask
)
353 if (category_mask
== LC_ALL_MASK
)
355 SCM_SYSCALL (result
= setlocale (LC_ALL
, locale_name
));
361 #define SCM_DEFINE_LOCALE_CATEGORY(_name) \
362 if (category_mask & SCM_LOCALE_CATEGORY_MASK (_name)) \
364 SCM_SYSCALL (result = setlocale (LC_ ## _name, locale_name)); \
365 if (result == NULL) \
368 #include "locale-categories.h"
369 #undef SCM_DEFINE_LOCALE_CATEGORY
378 /* Install LOCALE, recursively installing its base locales first. On
379 success, zero is returned. */
381 install_locale (scm_t_locale locale
)
383 scm_t_locale stack
[LOCALE_STACK_SIZE_MAX
];
384 int category_mask
= 0;
385 size_t stack_size
= 0;
386 int stack_offset
= 0;
387 const char *result
= NULL
;
389 /* Build up a locale stack by traversing the `base_locale' link. */
392 if (stack_size
>= LOCALE_STACK_SIZE_MAX
)
393 /* We cannot use `scm_error ()' here because otherwise the locale
394 mutex may remain locked. */
397 stack
[stack_size
++] = locale
;
399 /* Keep track of which categories have already been taken into
401 category_mask
|= locale
->category_mask
;
403 if (!SCM_UNBNDP (locale
->base_locale
))
404 locale
= (scm_t_locale
) SCM_SMOB_DATA (locale
->base_locale
);
408 while ((locale
!= NULL
) && (category_mask
!= LC_ALL_MASK
));
410 /* Install the C locale to start from a pristine state. */
411 SCM_SYSCALL (result
= setlocale (LC_ALL
, "C"));
415 /* Install the locales in reverse order. */
416 for (stack_offset
= stack_size
- 1;
423 locale
= stack
[stack_offset
];
424 err
= install_locale_categories (locale
->locale_name
,
425 locale
->category_mask
);
436 /* Leave the locked locale section. */
438 leave_locale_section (const scm_t_locale_settings
*settings
)
440 /* Restore the previous locale settings. */
441 (void)restore_locale_settings (settings
);
443 unlock_locale_mutex ();
446 /* Enter a locked locale section. */
448 enter_locale_section (scm_t_locale locale
,
449 scm_t_locale_settings
*prev_locale
)
453 lock_locale_mutex ();
455 err
= get_current_locale_settings (prev_locale
);
458 unlock_locale_mutex ();
462 err
= install_locale (locale
);
465 leave_locale_section (prev_locale
);
466 free_locale_settings (prev_locale
);
472 /* Convenient macro to run STATEMENT in the locale context of C_LOCALE. */
473 #define RUN_IN_LOCALE_SECTION(_c_locale, _statement) \
477 scm_t_locale_settings lsec_prev_locale; \
479 lsec_err = enter_locale_section ((_c_locale), &lsec_prev_locale); \
481 scm_locale_error (FUNC_NAME, lsec_err); \
486 leave_locale_section (&lsec_prev_locale); \
487 free_locale_settings (&lsec_prev_locale); \
492 /* Convert the current locale settings into a locale SMOB. On success, zero
493 is returned and RESULT points to the new SMOB. Otherwise, an error is
496 get_current_locale (SCM
*result
)
499 scm_t_locale c_locale
;
500 const char *current_locale
;
502 c_locale
= scm_gc_malloc (sizeof (* c_locale
), "locale");
504 lock_locale_mutex ();
506 c_locale
->category_mask
= LC_ALL_MASK
;
507 c_locale
->base_locale
= SCM_UNDEFINED
;
509 current_locale
= setlocale (LC_ALL
, NULL
);
510 if (current_locale
!= NULL
)
511 c_locale
->locale_name
= scm_gc_strdup (current_locale
);
515 unlock_locale_mutex ();
518 SCM_NEWSMOB (*result
, scm_tc16_locale_smob_type
, c_locale
);
520 *result
= SCM_BOOL_F
;
525 #else /* USE_GNU_LOCALE_API */
527 /* Convenient macro to run STATEMENT in the locale context of C_LOCALE. */
528 #define RUN_IN_LOCALE_SECTION(_c_locale, _statement) \
531 scm_t_locale old_loc; \
533 old_loc = uselocale (_c_locale); \
535 uselocale (old_loc); \
540 #endif /* USE_GNU_LOCALE_API */
544 /* `make-locale' can take either category lists or single categories (the
545 `LC_*' integer constants). */
546 #define SCM_LIST_OR_INTEGER_P(arg) \
547 (scm_is_integer (arg) || scm_is_true (scm_list_p (arg)))
550 /* Return the category mask corresponding to CATEGORY (an `LC_' integer
553 category_to_category_mask (SCM category
,
554 const char *func_name
, int pos
)
559 c_category
= scm_to_int (category
);
561 #define SCM_DEFINE_LOCALE_CATEGORY(_name) \
563 c_category_mask = SCM_LOCALE_CATEGORY_MASK (_name); \
568 #include "locale-categories.h"
571 c_category_mask
= LC_ALL_MASK
;
575 scm_wrong_type_arg_msg (func_name
, pos
, category
,
579 #undef SCM_DEFINE_LOCALE_CATEGORY
581 return c_category_mask
;
584 /* Convert CATEGORIES, a list of locale categories or a single category (an
585 integer), into a category mask. */
587 category_list_to_category_mask (SCM categories
,
588 const char *func_name
, int pos
)
590 int c_category_mask
= 0;
592 if (scm_is_integer (categories
))
593 c_category_mask
= category_to_category_mask (categories
,
596 for (; !scm_is_null (categories
); categories
= SCM_CDR (categories
))
598 SCM category
= SCM_CAR (categories
);
601 category_to_category_mask (category
, func_name
, pos
);
604 return c_category_mask
;
608 SCM_DEFINE (scm_make_locale
, "make-locale", 2, 1, 0,
609 (SCM category_list
, SCM locale_name
, SCM base_locale
),
610 "Return a reference to a data structure representing a set of "
611 "locale datasets. @var{category_list} should be either a list "
612 "of locale categories or a single category as used with "
613 "@code{setlocale} (@pxref{Locales, @code{setlocale}}) and "
614 "@var{locale_name} should be the name of the locale considered "
615 "(e.g., @code{\"sl_SI\"}). Optionally, if @code{base_locale} is "
616 "passed, it should be a locale object denoting settings for "
617 "categories not listed in @var{category_list}.")
618 #define FUNC_NAME s_scm_make_locale
620 SCM locale
= SCM_BOOL_F
;
624 scm_t_locale c_base_locale
, c_locale
;
626 SCM_MAKE_VALIDATE (1, category_list
, LIST_OR_INTEGER_P
);
627 SCM_VALIDATE_STRING (2, locale_name
);
628 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, base_locale
, c_base_locale
);
630 c_category_mask
= category_list_to_category_mask (category_list
,
632 c_locale_name
= scm_to_locale_string (locale_name
);
634 #ifdef USE_GNU_LOCALE_API
636 if (scm_is_eq (base_locale
, SCM_VARIABLE_REF (scm_global_locale
)))
637 c_base_locale
= LC_GLOBAL_LOCALE
;
639 if (c_base_locale
!= (locale_t
) 0)
641 /* C_BASE_LOCALE is to be consumed by `newlocale ()' so it needs to be
642 duplicated before. */
643 c_base_locale
= duplocale (c_base_locale
);
645 if (c_base_locale
== (locale_t
) 0)
652 c_locale
= newlocale (c_category_mask
, c_locale_name
, c_base_locale
);
654 free (c_locale_name
);
656 if (c_locale
== (locale_t
) 0)
658 if (c_base_locale
!= (locale_t
) 0)
659 freelocale (c_base_locale
);
660 scm_locale_error (FUNC_NAME
, errno
);
663 SCM_NEWSMOB (locale
, scm_tc16_locale_smob_type
, c_locale
);
667 c_locale
= scm_gc_malloc (sizeof (* c_locale
), "locale");
669 c_locale
->category_mask
= c_category_mask
;
670 c_locale
->locale_name
= c_locale_name
;
672 if (scm_is_eq (base_locale
, SCM_VARIABLE_REF (scm_global_locale
)))
674 /* Get the current locale settings and turn them into a locale
676 err
= get_current_locale (&base_locale
);
681 c_locale
->base_locale
= base_locale
;
684 /* Try out the new locale and raise an exception if it doesn't work. */
686 scm_t_locale_settings prev_locale
;
688 err
= enter_locale_section (c_locale
, &prev_locale
);
694 leave_locale_section (&prev_locale
);
695 SCM_NEWSMOB (locale
, scm_tc16_locale_smob_type
, c_locale
);
704 #ifndef USE_GNU_LOCALE_API
705 scm_gc_free (c_locale
, sizeof (* c_locale
), "locale");
707 free (c_locale_name
);
708 scm_locale_error (FUNC_NAME
, err
);
714 SCM_DEFINE (scm_locale_p
, "locale?", 1, 0, 0,
716 "Return true if @var{obj} is a locale object.")
717 #define FUNC_NAME s_scm_locale_p
719 return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_locale_smob_type
, obj
));
725 /* Locale-dependent string comparison.
727 A similar API can be found in MzScheme starting from version 200:
728 http://download.plt-scheme.org/chronology/mzmr200alpha14.html . */
730 #define SCM_STRING_TO_U32_BUF(s1, c_s1) \
733 if (scm_i_is_narrow_string (s1)) \
736 const char *buf = scm_i_string_chars (s1); \
738 len = scm_i_string_length (s1); \
739 c_s1 = alloca (sizeof (scm_t_wchar) * (len + 1)); \
741 for (i = 0; i < len; i ++) \
742 c_s1[i] = (unsigned char ) buf[i]; \
746 c_s1 = (scm_t_wchar *) scm_i_string_wide_chars (s1); \
750 /* Compare UTF-32 strings according to LOCALE. Returns a negative value if
751 S1 compares smaller than S2, a positive value if S1 compares larger than
752 S2, or 0 if they compare equal. */
754 compare_u32_strings (SCM s1
, SCM s2
, SCM locale
, const char *func_name
)
755 #define FUNC_NAME func_name
758 scm_t_locale c_locale
;
759 scm_t_wchar
*c_s1
, *c_s2
;
760 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale
, c_locale
);
762 SCM_STRING_TO_U32_BUF (s1
, c_s1
);
763 SCM_STRING_TO_U32_BUF (s2
, c_s2
);
766 RUN_IN_LOCALE_SECTION (c_locale
,
767 result
= u32_strcoll ((const scm_t_uint32
*) c_s1
,
768 (const scm_t_uint32
*) c_s2
));
770 result
= u32_strcoll ((const scm_t_uint32
*) c_s1
,
771 (const scm_t_uint32
*) c_s2
);
773 scm_remember_upto_here_2 (s1
, s2
);
774 scm_remember_upto_here (locale
);
779 /* Return the current language of the locale. */
783 /* Note: If the locale has been set with 'uselocale', uc_locale_language
784 from libunistring versions 0.9.1 and older will return the incorrect
785 (non-thread-specific) locale. This is fixed in versions 0.9.2 and
787 return uc_locale_language ();
791 u32_locale_casecoll (const char *func_name
, const scm_t_uint32
*c_s1
,
792 const scm_t_uint32
*c_s2
,
795 /* Note: Since this is called from `RUN_IN_LOCALE_SECTION', it must note
796 make any non-local exit. */
799 const char *loc
= locale_language ();
801 ret
= u32_casecoll (c_s1
, u32_strlen (c_s1
),
802 c_s2
, u32_strlen (c_s2
),
803 loc
, UNINORM_NFC
, result
);
805 return ret
== 0 ? ret
: errno
;
809 compare_u32_strings_ci (SCM s1
, SCM s2
, SCM locale
, const char *func_name
)
810 #define FUNC_NAME func_name
813 scm_t_locale c_locale
;
814 scm_t_wchar
*c_s1
, *c_s2
;
815 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale
, c_locale
);
817 SCM_STRING_TO_U32_BUF (s1
, c_s1
);
818 SCM_STRING_TO_U32_BUF (s2
, c_s2
);
821 RUN_IN_LOCALE_SECTION
823 ret
= u32_locale_casecoll (func_name
,
824 (const scm_t_uint32
*) c_s1
,
825 (const scm_t_uint32
*) c_s2
,
828 ret
= u32_locale_casecoll (func_name
,
829 (const scm_t_uint32
*) c_s1
,
830 (const scm_t_uint32
*) c_s2
,
833 if (SCM_UNLIKELY (ret
!= 0))
836 scm_syserror (FUNC_NAME
);
839 scm_remember_upto_here_2 (s1
, s2
);
840 scm_remember_upto_here (locale
);
846 /* Store into DST an upper-case version of SRC. */
848 str_upcase (register char *dst
, register const char *src
)
850 for (; *src
!= '\0'; src
++, dst
++)
851 *dst
= toupper ((int) *src
);
856 str_downcase (register char *dst
, register const char *src
)
858 for (; *src
!= '\0'; src
++, dst
++)
859 *dst
= tolower ((int) *src
);
863 #ifdef USE_GNU_LOCALE_API
865 str_upcase_l (register char *dst
, register const char *src
,
868 for (; *src
!= '\0'; src
++, dst
++)
869 *dst
= toupper_l (*src
, locale
);
874 str_downcase_l (register char *dst
, register const char *src
,
877 for (; *src
!= '\0'; src
++, dst
++)
878 *dst
= tolower_l (*src
, locale
);
884 SCM_DEFINE (scm_string_locale_lt
, "string-locale<?", 2, 1, 0,
885 (SCM s1
, SCM s2
, SCM locale
),
886 "Compare strings @var{s1} and @var{s2} in a locale-dependent way."
887 "If @var{locale} is provided, it should be locale object (as "
888 "returned by @code{make-locale}) and will be used to perform the "
889 "comparison; otherwise, the current system locale is used.")
890 #define FUNC_NAME s_scm_string_locale_lt
894 SCM_VALIDATE_STRING (1, s1
);
895 SCM_VALIDATE_STRING (2, s2
);
897 result
= compare_u32_strings (s1
, s2
, locale
, FUNC_NAME
);
899 return scm_from_bool (result
< 0);
903 SCM_DEFINE (scm_string_locale_gt
, "string-locale>?", 2, 1, 0,
904 (SCM s1
, SCM s2
, SCM locale
),
905 "Compare strings @var{s1} and @var{s2} in a locale-dependent way."
906 "If @var{locale} is provided, it should be locale object (as "
907 "returned by @code{make-locale}) and will be used to perform the "
908 "comparison; otherwise, the current system locale is used.")
909 #define FUNC_NAME s_scm_string_locale_gt
913 SCM_VALIDATE_STRING (1, s1
);
914 SCM_VALIDATE_STRING (2, s2
);
916 result
= compare_u32_strings (s1
, s2
, locale
, FUNC_NAME
);
918 return scm_from_bool (result
> 0);
922 SCM_DEFINE (scm_string_locale_ci_lt
, "string-locale-ci<?", 2, 1, 0,
923 (SCM s1
, SCM s2
, SCM locale
),
924 "Compare strings @var{s1} and @var{s2} in a case-insensitive, "
925 "and locale-dependent way. If @var{locale} is provided, it "
926 "should be locale object (as returned by @code{make-locale}) "
927 "and will be used to perform the comparison; otherwise, the "
928 "current system locale is used.")
929 #define FUNC_NAME s_scm_string_locale_ci_lt
933 SCM_VALIDATE_STRING (1, s1
);
934 SCM_VALIDATE_STRING (2, s2
);
936 result
= compare_u32_strings_ci (s1
, s2
, locale
, FUNC_NAME
);
938 return scm_from_bool (result
< 0);
942 SCM_DEFINE (scm_string_locale_ci_gt
, "string-locale-ci>?", 2, 1, 0,
943 (SCM s1
, SCM s2
, SCM locale
),
944 "Compare strings @var{s1} and @var{s2} in a case-insensitive, "
945 "and locale-dependent way. If @var{locale} is provided, it "
946 "should be locale object (as returned by @code{make-locale}) "
947 "and will be used to perform the comparison; otherwise, the "
948 "current system locale is used.")
949 #define FUNC_NAME s_scm_string_locale_ci_gt
953 SCM_VALIDATE_STRING (1, s1
);
954 SCM_VALIDATE_STRING (2, s2
);
956 result
= compare_u32_strings_ci (s1
, s2
, locale
, FUNC_NAME
);
958 return scm_from_bool (result
> 0);
962 SCM_DEFINE (scm_string_locale_ci_eq
, "string-locale-ci=?", 2, 1, 0,
963 (SCM s1
, SCM s2
, SCM locale
),
964 "Compare strings @var{s1} and @var{s2} in a case-insensitive, "
965 "and locale-dependent way. If @var{locale} is provided, it "
966 "should be locale object (as returned by @code{make-locale}) "
967 "and will be used to perform the comparison; otherwise, the "
968 "current system locale is used.")
969 #define FUNC_NAME s_scm_string_locale_ci_eq
973 SCM_VALIDATE_STRING (1, s1
);
974 SCM_VALIDATE_STRING (2, s2
);
976 result
= compare_u32_strings_ci (s1
, s2
, locale
, FUNC_NAME
);
978 return scm_from_bool (result
== 0);
983 SCM_DEFINE (scm_char_locale_lt
, "char-locale<?", 2, 1, 0,
984 (SCM c1
, SCM c2
, SCM locale
),
985 "Return true if character @var{c1} is lower than @var{c2} "
986 "according to @var{locale} or to the current locale.")
987 #define FUNC_NAME s_scm_char_locale_lt
991 SCM_VALIDATE_CHAR (1, c1
);
992 SCM_VALIDATE_CHAR (2, c2
);
994 result
= compare_u32_strings (scm_string (scm_list_1 (c1
)),
995 scm_string (scm_list_1 (c2
)),
998 return scm_from_bool (result
< 0);
1002 SCM_DEFINE (scm_char_locale_gt
, "char-locale>?", 2, 1, 0,
1003 (SCM c1
, SCM c2
, SCM locale
),
1004 "Return true if character @var{c1} is greater than @var{c2} "
1005 "according to @var{locale} or to the current locale.")
1006 #define FUNC_NAME s_scm_char_locale_gt
1010 SCM_VALIDATE_CHAR (1, c1
);
1011 SCM_VALIDATE_CHAR (2, c2
);
1013 result
= compare_u32_strings (scm_string (scm_list_1 (c1
)),
1014 scm_string (scm_list_1 (c2
)),
1017 return scm_from_bool (result
> 0);
1021 SCM_DEFINE (scm_char_locale_ci_lt
, "char-locale-ci<?", 2, 1, 0,
1022 (SCM c1
, SCM c2
, SCM locale
),
1023 "Return true if character @var{c1} is lower than @var{c2}, "
1024 "in a case insensitive way according to @var{locale} or to "
1025 "the current locale.")
1026 #define FUNC_NAME s_scm_char_locale_ci_lt
1030 SCM_VALIDATE_CHAR (1, c1
);
1031 SCM_VALIDATE_CHAR (2, c2
);
1033 result
= compare_u32_strings_ci (scm_string (scm_list_1 (c1
)),
1034 scm_string (scm_list_1 (c2
)),
1037 return scm_from_bool (result
< 0);
1041 SCM_DEFINE (scm_char_locale_ci_gt
, "char-locale-ci>?", 2, 1, 0,
1042 (SCM c1
, SCM c2
, SCM locale
),
1043 "Return true if character @var{c1} is greater than @var{c2}, "
1044 "in a case insensitive way according to @var{locale} or to "
1045 "the current locale.")
1046 #define FUNC_NAME s_scm_char_locale_ci_gt
1050 SCM_VALIDATE_CHAR (1, c1
);
1051 SCM_VALIDATE_CHAR (2, c2
);
1053 result
= compare_u32_strings_ci (scm_string (scm_list_1 (c1
)),
1054 scm_string (scm_list_1 (c2
)),
1057 return scm_from_bool (result
> 0);
1061 SCM_DEFINE (scm_char_locale_ci_eq
, "char-locale-ci=?", 2, 1, 0,
1062 (SCM c1
, SCM c2
, SCM locale
),
1063 "Return true if character @var{c1} is equal to @var{c2}, "
1064 "in a case insensitive way according to @var{locale} or to "
1065 "the current locale.")
1066 #define FUNC_NAME s_scm_char_locale_ci_eq
1070 SCM_VALIDATE_CHAR (1, c1
);
1071 SCM_VALIDATE_CHAR (2, c2
);
1073 result
= compare_u32_strings_ci (scm_string (scm_list_1 (c1
)),
1074 scm_string (scm_list_1 (c2
)),
1077 return scm_from_bool (result
== 0);
1083 /* Locale-dependent alphabetic character mapping. */
1086 u32_locale_tocase (const scm_t_uint32
*c_s1
, size_t len
,
1087 scm_t_uint32
**p_c_s2
, size_t * p_len2
,
1088 scm_t_uint32
*(*func
) (const scm_t_uint32
*, size_t,
1089 const char *, uninorm_t
,
1090 scm_t_uint32
*, size_t *))
1092 /* Note: Since this is called from `RUN_IN_LOCALE_SECTION', it must not
1093 make any non-local exit. */
1096 const char *loc
= locale_language ();
1098 /* The first NULL here indicates that no NFC or NFKC normalization
1099 is done. The second NULL means the return buffer is
1101 ret
= func (c_s1
, len
, loc
, NULL
, NULL
, p_len2
);
1105 *p_c_s2
= (scm_t_uint32
*) NULL
;
1116 chr_to_case (SCM chr
, scm_t_locale c_locale
,
1117 scm_t_uint32
*(*func
) (const scm_t_uint32
*, size_t, const char *,
1118 uninorm_t
, scm_t_uint32
*, size_t *),
1119 const char *func_name
,
1121 #define FUNC_NAME func_name
1125 scm_t_uint32
*convbuf
;
1131 if (c_locale
!= NULL
)
1132 RUN_IN_LOCALE_SECTION (c_locale
, ret
=
1133 u32_locale_tocase (&c
, 1, &convbuf
, &convlen
, func
));
1136 u32_locale_tocase (&c
, 1, &convbuf
, &convlen
, func
);
1138 if (SCM_UNLIKELY (ret
!= 0))
1145 convchar
= SCM_MAKE_CHAR ((scm_t_wchar
) convbuf
[0]);
1154 SCM_DEFINE (scm_char_locale_downcase
, "char-locale-downcase", 1, 1, 0,
1155 (SCM chr
, SCM locale
),
1156 "Return the lowercase character that corresponds to @var{chr} "
1157 "according to either @var{locale} or the current locale.")
1158 #define FUNC_NAME s_scm_char_locale_downcase
1160 scm_t_locale c_locale
;
1164 SCM_VALIDATE_CHAR (1, chr
);
1165 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale
, c_locale
);
1167 ret
= chr_to_case (chr
, c_locale
, u32_tolower
, FUNC_NAME
, &err
);
1172 scm_syserror (FUNC_NAME
);
1178 SCM_DEFINE (scm_char_locale_upcase
, "char-locale-upcase", 1, 1, 0,
1179 (SCM chr
, SCM locale
),
1180 "Return the uppercase character that corresponds to @var{chr} "
1181 "according to either @var{locale} or the current locale.")
1182 #define FUNC_NAME s_scm_char_locale_upcase
1184 scm_t_locale c_locale
;
1188 SCM_VALIDATE_CHAR (1, chr
);
1189 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale
, c_locale
);
1191 ret
= chr_to_case (chr
, c_locale
, u32_toupper
, FUNC_NAME
, &err
);
1196 scm_syserror (FUNC_NAME
);
1202 SCM_DEFINE (scm_char_locale_titlecase
, "char-locale-titlecase", 1, 1, 0,
1203 (SCM chr
, SCM locale
),
1204 "Return the titlecase character that corresponds to @var{chr} "
1205 "according to either @var{locale} or the current locale.")
1206 #define FUNC_NAME s_scm_char_locale_titlecase
1208 scm_t_locale c_locale
;
1212 SCM_VALIDATE_CHAR (1, chr
);
1213 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale
, c_locale
);
1215 ret
= chr_to_case (chr
, c_locale
, u32_totitle
, FUNC_NAME
, &err
);
1220 scm_syserror (FUNC_NAME
);
1227 str_to_case (SCM str
, scm_t_locale c_locale
,
1228 scm_t_uint32
*(*func
) (const scm_t_uint32
*, size_t, const char *,
1229 uninorm_t
, scm_t_uint32
*, size_t *),
1230 const char *func_name
,
1232 #define FUNC_NAME func_name
1234 scm_t_wchar
*c_str
, *c_buf
;
1235 scm_t_uint32
*c_convstr
;
1236 size_t len
, convlen
;
1240 len
= scm_i_string_length (str
);
1243 SCM_STRING_TO_U32_BUF (str
, c_str
);
1246 RUN_IN_LOCALE_SECTION (c_locale
, ret
=
1247 u32_locale_tocase ((scm_t_uint32
*) c_str
, len
,
1252 u32_locale_tocase ((scm_t_uint32
*) c_str
, len
,
1253 &c_convstr
, &convlen
, func
);
1255 scm_remember_upto_here (str
);
1257 if (SCM_UNLIKELY (ret
!= 0))
1263 convstr
= scm_i_make_wide_string (convlen
, &c_buf
, 0);
1264 memcpy (c_buf
, c_convstr
, convlen
* sizeof (scm_t_wchar
));
1267 scm_i_try_narrow_string (convstr
);
1273 SCM_DEFINE (scm_string_locale_upcase
, "string-locale-upcase", 1, 1, 0,
1274 (SCM str
, SCM locale
),
1275 "Return a new string that is the uppercase version of "
1276 "@var{str} according to either @var{locale} or the current "
1278 #define FUNC_NAME s_scm_string_locale_upcase
1280 scm_t_locale c_locale
;
1284 SCM_VALIDATE_STRING (1, str
);
1285 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale
, c_locale
);
1287 ret
= str_to_case (str
, c_locale
, u32_toupper
, FUNC_NAME
, &err
);
1292 scm_syserror (FUNC_NAME
);
1298 SCM_DEFINE (scm_string_locale_downcase
, "string-locale-downcase", 1, 1, 0,
1299 (SCM str
, SCM locale
),
1300 "Return a new string that is the down-case version of "
1301 "@var{str} according to either @var{locale} or the current "
1303 #define FUNC_NAME s_scm_string_locale_downcase
1305 scm_t_locale c_locale
;
1309 SCM_VALIDATE_STRING (1, str
);
1310 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale
, c_locale
);
1312 ret
= str_to_case (str
, c_locale
, u32_tolower
, FUNC_NAME
, &err
);
1317 scm_syserror (FUNC_NAME
);
1323 SCM_DEFINE (scm_string_locale_titlecase
, "string-locale-titlecase", 1, 1, 0,
1324 (SCM str
, SCM locale
),
1325 "Return a new string that is the title-case version of "
1326 "@var{str} according to either @var{locale} or the current "
1328 #define FUNC_NAME s_scm_string_locale_titlecase
1330 scm_t_locale c_locale
;
1334 SCM_VALIDATE_STRING (1, str
);
1335 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale
, c_locale
);
1337 ret
= str_to_case (str
, c_locale
, u32_totitle
, FUNC_NAME
, &err
);
1342 scm_syserror (FUNC_NAME
);
1348 /* Note: We don't provide mutative versions of `string-locale-(up|down)case'
1349 because, in some languages, a single downcase character maps to a couple
1350 of uppercase characters. Read the SRFI-13 document for a detailed
1351 discussion about this. */
1355 /* Locale-dependent number parsing. */
1357 SCM_DEFINE (scm_locale_string_to_integer
, "locale-string->integer",
1358 1, 2, 0, (SCM str
, SCM base
, SCM locale
),
1359 "Convert string @var{str} into an integer according to either "
1360 "@var{locale} (a locale object as returned by @code{make-locale}) "
1361 "or the current process locale. Return two values: an integer "
1362 "(on success) or @code{#f}, and the number of characters read "
1363 "from @var{str} (@code{0} on failure).")
1364 #define FUNC_NAME s_scm_locale_string_to_integer
1371 scm_t_locale c_locale
;
1373 SCM_VALIDATE_STRING (1, str
);
1374 c_str
= scm_i_string_chars (str
);
1376 if (!scm_is_eq (base
, SCM_UNDEFINED
))
1377 SCM_VALIDATE_INT_COPY (2, base
, c_base
);
1381 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale
, c_locale
);
1383 if (c_locale
!= NULL
)
1385 #ifdef USE_GNU_LOCALE_API
1386 c_result
= strtol_l (c_str
, &c_endptr
, c_base
, c_locale
);
1388 RUN_IN_LOCALE_SECTION (c_locale
,
1389 c_result
= strtol (c_str
, &c_endptr
, c_base
));
1393 c_result
= strtol (c_str
, &c_endptr
, c_base
);
1395 scm_remember_upto_here (str
);
1397 if (c_endptr
== c_str
)
1398 result
= SCM_BOOL_F
;
1400 result
= scm_from_long (c_result
);
1402 return (scm_values (scm_list_2 (result
, scm_from_long (c_endptr
- c_str
))));
1406 SCM_DEFINE (scm_locale_string_to_inexact
, "locale-string->inexact",
1407 1, 1, 0, (SCM str
, SCM locale
),
1408 "Convert string @var{str} into an inexact number according to "
1409 "either @var{locale} (a locale object as returned by "
1410 "@code{make-locale}) or the current process locale. Return "
1411 "two values: an inexact number (on success) or @code{#f}, and "
1412 "the number of characters read from @var{str} (@code{0} on "
1414 #define FUNC_NAME s_scm_locale_string_to_inexact
1420 scm_t_locale c_locale
;
1422 SCM_VALIDATE_STRING (1, str
);
1423 c_str
= scm_i_string_chars (str
);
1425 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale
, c_locale
);
1427 if (c_locale
!= NULL
)
1429 #ifdef USE_GNU_LOCALE_API
1430 c_result
= strtod_l (c_str
, &c_endptr
, c_locale
);
1432 RUN_IN_LOCALE_SECTION (c_locale
,
1433 c_result
= strtod (c_str
, &c_endptr
));
1437 c_result
= strtod (c_str
, &c_endptr
);
1439 scm_remember_upto_here (str
);
1441 if (c_endptr
== c_str
)
1442 result
= SCM_BOOL_F
;
1444 result
= scm_from_double (c_result
);
1446 return (scm_values (scm_list_2 (result
, scm_from_long (c_endptr
- c_str
))));
1451 /* Language information, aka. `nl_langinfo ()'. */
1453 /* FIXME: Issues related to `nl-langinfo'.
1455 1. The `CODESET' value is not normalized. This is a secondary issue, but
1456 still a practical issue. See
1457 http://www.cl.cam.ac.uk/~mgk25/ucs/norm_charmap.c for codeset
1460 2. `nl_langinfo ()' is not available on Windows.
1462 3. `nl_langinfo ()' may return strings encoded in a locale different from
1466 (nl-langinfo DAY_1 (make-locale LC_ALL "eo_EO.UTF-8"))
1468 returns a result that is a UTF-8 string, regardless of the
1469 setting of the current locale. If nl_langinfo supports CODESET,
1470 we can convert the string properly using scm_from_stringn. If
1471 CODESET is not supported, we won't be able to make much sense of
1472 the returned string.
1474 Note: We don't use Gnulib's `nl_langinfo' module because it's currently not
1475 as complete as the compatibility hacks in `i18n.scm'. */
1478 SCM_DEFINE (scm_nl_langinfo
, "nl-langinfo", 1, 1, 0,
1479 (SCM item
, SCM locale
),
1480 "Return a string denoting locale information for @var{item} "
1481 "in the current locale or that specified by @var{locale}. "
1482 "The semantics and arguments are the same as those of the "
1483 "X/Open @code{nl_langinfo} function (@pxref{The Elegant and "
1484 "Fast Way, @code{nl_langinfo},, libc, The GNU C Library "
1485 "Reference Manual}).")
1486 #define FUNC_NAME s_scm_nl_langinfo
1488 #ifdef HAVE_NL_LANGINFO
1492 scm_t_locale c_locale
;
1493 #ifdef HAVE_LANGINFO_CODESET
1497 SCM_VALIDATE_INT_COPY (2, item
, c_item
);
1498 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale
, c_locale
);
1500 /* Sadly, `nl_langinfo ()' returns a pointer to a static string. According
1501 to SuS v2, that static string may be modified by subsequent calls to
1502 `nl_langinfo ()' as well as by calls to `setlocale ()'. Thus, we must
1503 acquire the locale mutex before doing invoking `nl_langinfo ()'. See
1504 http://opengroup.org/onlinepubs/007908799/xsh/nl_langinfo.html for
1507 lock_locale_mutex ();
1508 if (c_locale
!= NULL
)
1510 #ifdef USE_GNU_LOCALE_API
1511 c_result
= nl_langinfo_l (c_item
, c_locale
);
1512 #ifdef HAVE_LANGINFO_CODESET
1513 codeset
= nl_langinfo_l (CODESET
, c_locale
);
1514 #endif /* HAVE_LANGINFO_CODESET */
1515 #else /* !USE_GNU_LOCALE_API */
1516 /* We can't use `RUN_IN_LOCALE_SECTION ()' here because the locale
1517 mutex is already taken. */
1519 scm_t_locale_settings lsec_prev_locale
;
1521 lsec_err
= get_current_locale_settings (&lsec_prev_locale
);
1523 unlock_locale_mutex ();
1526 lsec_err
= install_locale (c_locale
);
1529 leave_locale_section (&lsec_prev_locale
);
1530 free_locale_settings (&lsec_prev_locale
);
1535 scm_locale_error (FUNC_NAME
, lsec_err
);
1538 c_result
= nl_langinfo (c_item
);
1539 #ifdef HAVE_LANGINFO_CODESET
1540 codeset
= nl_langinfo (CODESET
);
1541 #endif /* HAVE_LANGINFO_CODESET */
1543 restore_locale_settings (&lsec_prev_locale
);
1544 free_locale_settings (&lsec_prev_locale
);
1550 c_result
= nl_langinfo (c_item
);
1551 #ifdef HAVE_LANGINFO_CODESET
1552 codeset
= nl_langinfo (CODESET
);
1553 #endif /* HAVE_LANGINFO_CODESET */
1556 c_result
= strdup (c_result
);
1557 unlock_locale_mutex ();
1559 if (c_result
== NULL
)
1560 result
= SCM_BOOL_F
;
1565 #if (defined GROUPING) && (defined MON_GROUPING)
1571 /* In this cases, the result is to be interpreted as a list
1572 of numbers. If the last item is `CHAR_MAX' or a negative
1573 number, it has the special meaning "no more grouping"
1574 (negative numbers aren't specified in POSIX but can be
1576 <http://lists.gnu.org/archive/html/bug-guile/2011-02/msg00159.html>). */
1578 for (p
= c_result
; (*p
> 0) && (*p
!= CHAR_MAX
); p
++)
1579 result
= scm_cons (SCM_I_MAKINUM ((int) *p
), result
);
1582 SCM last_pair
= result
;
1584 result
= scm_reverse_x (result
, SCM_EOL
);
1588 /* Cyclic grouping information. */
1589 if (!scm_is_null (last_pair
))
1590 SCM_SETCDR (last_pair
, result
);
1599 #if (defined FRAC_DIGITS) && (defined INT_FRAC_DIGITS)
1601 case INT_FRAC_DIGITS
:
1602 /* This is to be interpreted as a single integer. */
1603 if (*c_result
== CHAR_MAX
)
1605 result
= SCM_BOOL_F
;
1607 result
= SCM_I_MAKINUM (*c_result
);
1613 #if (defined P_CS_PRECEDES) && (defined INT_N_CS_PRECEDES)
1616 case INT_P_CS_PRECEDES
:
1617 case INT_N_CS_PRECEDES
:
1618 #if (defined P_SEP_BY_SPACE) && (defined N_SEP_BY_SPACE)
1619 case P_SEP_BY_SPACE
:
1620 case N_SEP_BY_SPACE
:
1622 /* This is to be interpreted as a boolean. */
1623 result
= scm_from_bool (*c_result
);
1629 #if (defined P_SIGN_POSN) && (defined INT_N_SIGN_POSN)
1632 case INT_P_SIGN_POSN
:
1633 case INT_N_SIGN_POSN
:
1634 /* See `(libc) Sign of Money Amount' for the interpretation of the
1635 return value here. */
1639 result
= scm_from_latin1_symbol ("parenthesize");
1643 result
= scm_from_latin1_symbol ("sign-before");
1647 result
= scm_from_latin1_symbol ("sign-after");
1651 result
= scm_from_latin1_symbol ("sign-before-currency-symbol");
1655 result
= scm_from_latin1_symbol ("sign-after-currency-symbol");
1659 result
= scm_from_latin1_symbol ("unspecified");
1665 #ifdef HAVE_LANGINFO_CODESET
1666 result
= scm_from_stringn (c_result
, strlen (c_result
),
1668 SCM_FAILED_CONVERSION_QUESTION_MARK
);
1669 #else /* !HAVE_LANGINFO_CODESET */
1670 /* This may be incorrectly encoded if the locale differs
1671 from the c_locale. */
1672 result
= scm_from_locale_string (c_result
);
1673 #endif /* !HAVE_LANGINFO_CODESET */
1680 scm_syserror_msg (FUNC_NAME
, "`nl-langinfo' not supported on your system",
1688 /* Define the `nl_item' constants. */
1690 define_langinfo_items (void)
1692 #ifdef HAVE_LANGINFO_H
1694 #define DEFINE_NLITEM_CONSTANT(_item) \
1695 scm_c_define (# _item, scm_from_int (_item))
1697 DEFINE_NLITEM_CONSTANT (CODESET
);
1699 /* Abbreviated days of the week. */
1700 DEFINE_NLITEM_CONSTANT (ABDAY_1
);
1701 DEFINE_NLITEM_CONSTANT (ABDAY_2
);
1702 DEFINE_NLITEM_CONSTANT (ABDAY_3
);
1703 DEFINE_NLITEM_CONSTANT (ABDAY_4
);
1704 DEFINE_NLITEM_CONSTANT (ABDAY_5
);
1705 DEFINE_NLITEM_CONSTANT (ABDAY_6
);
1706 DEFINE_NLITEM_CONSTANT (ABDAY_7
);
1708 /* Long-named days of the week. */
1709 DEFINE_NLITEM_CONSTANT (DAY_1
); /* Sunday */
1710 DEFINE_NLITEM_CONSTANT (DAY_2
); /* Monday */
1711 DEFINE_NLITEM_CONSTANT (DAY_3
); /* Tuesday */
1712 DEFINE_NLITEM_CONSTANT (DAY_4
); /* Wednesday */
1713 DEFINE_NLITEM_CONSTANT (DAY_5
); /* Thursday */
1714 DEFINE_NLITEM_CONSTANT (DAY_6
); /* Friday */
1715 DEFINE_NLITEM_CONSTANT (DAY_7
); /* Saturday */
1717 /* Abbreviated month names. */
1718 DEFINE_NLITEM_CONSTANT (ABMON_1
); /* Jan */
1719 DEFINE_NLITEM_CONSTANT (ABMON_2
);
1720 DEFINE_NLITEM_CONSTANT (ABMON_3
);
1721 DEFINE_NLITEM_CONSTANT (ABMON_4
);
1722 DEFINE_NLITEM_CONSTANT (ABMON_5
);
1723 DEFINE_NLITEM_CONSTANT (ABMON_6
);
1724 DEFINE_NLITEM_CONSTANT (ABMON_7
);
1725 DEFINE_NLITEM_CONSTANT (ABMON_8
);
1726 DEFINE_NLITEM_CONSTANT (ABMON_9
);
1727 DEFINE_NLITEM_CONSTANT (ABMON_10
);
1728 DEFINE_NLITEM_CONSTANT (ABMON_11
);
1729 DEFINE_NLITEM_CONSTANT (ABMON_12
);
1731 /* Long month names. */
1732 DEFINE_NLITEM_CONSTANT (MON_1
); /* January */
1733 DEFINE_NLITEM_CONSTANT (MON_2
);
1734 DEFINE_NLITEM_CONSTANT (MON_3
);
1735 DEFINE_NLITEM_CONSTANT (MON_4
);
1736 DEFINE_NLITEM_CONSTANT (MON_5
);
1737 DEFINE_NLITEM_CONSTANT (MON_6
);
1738 DEFINE_NLITEM_CONSTANT (MON_7
);
1739 DEFINE_NLITEM_CONSTANT (MON_8
);
1740 DEFINE_NLITEM_CONSTANT (MON_9
);
1741 DEFINE_NLITEM_CONSTANT (MON_10
);
1742 DEFINE_NLITEM_CONSTANT (MON_11
);
1743 DEFINE_NLITEM_CONSTANT (MON_12
);
1745 DEFINE_NLITEM_CONSTANT (AM_STR
); /* Ante meridiem string. */
1746 DEFINE_NLITEM_CONSTANT (PM_STR
); /* Post meridiem string. */
1748 DEFINE_NLITEM_CONSTANT (D_T_FMT
); /* Date and time format for strftime. */
1749 DEFINE_NLITEM_CONSTANT (D_FMT
); /* Date format for strftime. */
1750 DEFINE_NLITEM_CONSTANT (T_FMT
); /* Time format for strftime. */
1751 DEFINE_NLITEM_CONSTANT (T_FMT_AMPM
);/* 12-hour time format for strftime. */
1753 DEFINE_NLITEM_CONSTANT (ERA
); /* Alternate era. */
1754 DEFINE_NLITEM_CONSTANT (ERA_D_FMT
); /* Date in alternate era format. */
1755 DEFINE_NLITEM_CONSTANT (ERA_D_T_FMT
); /* Date and time in alternate era
1757 DEFINE_NLITEM_CONSTANT (ERA_T_FMT
); /* Time in alternate era format. */
1759 DEFINE_NLITEM_CONSTANT (ALT_DIGITS
); /* Alternate symbols for digits. */
1760 DEFINE_NLITEM_CONSTANT (RADIXCHAR
);
1761 DEFINE_NLITEM_CONSTANT (THOUSEP
);
1764 DEFINE_NLITEM_CONSTANT (YESEXPR
);
1767 DEFINE_NLITEM_CONSTANT (NOEXPR
);
1770 #ifdef CRNCYSTR /* currency symbol */
1771 DEFINE_NLITEM_CONSTANT (CRNCYSTR
);
1774 /* GNU extensions. */
1777 DEFINE_NLITEM_CONSTANT (ERA_YEAR
); /* Year in alternate era format. */
1780 /* LC_MONETARY category: formatting of monetary quantities.
1781 These items each correspond to a member of `struct lconv',
1782 defined in <locale.h>. */
1783 #ifdef INT_CURR_SYMBOL
1784 DEFINE_NLITEM_CONSTANT (INT_CURR_SYMBOL
);
1786 #ifdef MON_DECIMAL_POINT
1787 DEFINE_NLITEM_CONSTANT (MON_DECIMAL_POINT
);
1789 #ifdef MON_THOUSANDS_SEP
1790 DEFINE_NLITEM_CONSTANT (MON_THOUSANDS_SEP
);
1793 DEFINE_NLITEM_CONSTANT (MON_GROUPING
);
1795 #ifdef POSITIVE_SIGN
1796 DEFINE_NLITEM_CONSTANT (POSITIVE_SIGN
);
1798 #ifdef NEGATIVE_SIGN
1799 DEFINE_NLITEM_CONSTANT (NEGATIVE_SIGN
);
1802 DEFINE_NLITEM_CONSTANT (GROUPING
);
1804 #ifdef INT_FRAC_DIGITS
1805 DEFINE_NLITEM_CONSTANT (INT_FRAC_DIGITS
);
1808 DEFINE_NLITEM_CONSTANT (FRAC_DIGITS
);
1810 #ifdef P_CS_PRECEDES
1811 DEFINE_NLITEM_CONSTANT (P_CS_PRECEDES
);
1813 #ifdef P_SEP_BY_SPACE
1814 DEFINE_NLITEM_CONSTANT (P_SEP_BY_SPACE
);
1816 #ifdef N_CS_PRECEDES
1817 DEFINE_NLITEM_CONSTANT (N_CS_PRECEDES
);
1819 #ifdef N_SEP_BY_SPACE
1820 DEFINE_NLITEM_CONSTANT (N_SEP_BY_SPACE
);
1823 DEFINE_NLITEM_CONSTANT (P_SIGN_POSN
);
1826 DEFINE_NLITEM_CONSTANT (N_SIGN_POSN
);
1828 #ifdef INT_P_CS_PRECEDES
1829 DEFINE_NLITEM_CONSTANT (INT_P_CS_PRECEDES
);
1831 #ifdef INT_P_SEP_BY_SPACE
1832 DEFINE_NLITEM_CONSTANT (INT_P_SEP_BY_SPACE
);
1834 #ifdef INT_N_CS_PRECEDES
1835 DEFINE_NLITEM_CONSTANT (INT_N_CS_PRECEDES
);
1837 #ifdef INT_N_SEP_BY_SPACE
1838 DEFINE_NLITEM_CONSTANT (INT_N_SEP_BY_SPACE
);
1840 #ifdef INT_P_SIGN_POSN
1841 DEFINE_NLITEM_CONSTANT (INT_P_SIGN_POSN
);
1843 #ifdef INT_N_SIGN_POSN
1844 DEFINE_NLITEM_CONSTANT (INT_N_SIGN_POSN
);
1847 #undef DEFINE_NLITEM_CONSTANT
1849 #endif /* HAVE_NL_TYPES_H */
1856 SCM global_locale_smob
;
1858 #ifdef HAVE_NL_LANGINFO
1859 scm_add_feature ("nl-langinfo");
1860 define_langinfo_items ();
1863 #include "libguile/i18n.x"
1865 /* Initialize the global locale object with a special `locale' SMOB. */
1866 /* XXX: We don't define it as `LC_GLOBAL_LOCALE' because of bugs as of
1867 glibc <= 2.11 not (yet) worked around by Gnulib. See
1868 http://sourceware.org/bugzilla/show_bug.cgi?id=11009 for details. */
1869 SCM_NEWSMOB (global_locale_smob
, scm_tc16_locale_smob_type
, NULL
);
1870 SCM_VARIABLE_SET (scm_global_locale
, global_locale_smob
);
1874 scm_bootstrap_i18n ()
1876 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1878 (scm_t_extension_init_func
) scm_init_i18n
,