1 /* Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011, 2012 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 */
199 #else /* USE_GNU_LOCALE_API */
201 /* Alias for glibc's locale type. */
202 typedef locale_t scm_t_locale
;
204 #endif /* USE_GNU_LOCALE_API */
207 /* A locale object denoting the global locale. */
208 SCM_GLOBAL_VARIABLE (scm_global_locale
, "%global-locale");
211 /* Validate parameter ARG as a locale object and set C_LOCALE to the
212 corresponding C locale object. */
213 #define SCM_VALIDATE_LOCALE_COPY(_pos, _arg, _c_locale) \
216 SCM_VALIDATE_SMOB ((_pos), (_arg), locale_smob_type); \
217 (_c_locale) = (scm_t_locale)SCM_SMOB_DATA (_arg); \
221 /* Validate optional parameter ARG as either undefined or bound to a locale
222 object. Set C_LOCALE to the corresponding C locale object or NULL. */
223 #define SCM_VALIDATE_OPTIONAL_LOCALE_COPY(_pos, _arg, _c_locale) \
226 if (!scm_is_eq ((_arg), SCM_UNDEFINED)) \
227 SCM_VALIDATE_LOCALE_COPY (_pos, _arg, _c_locale); \
229 (_c_locale) = NULL; \
234 SCM_SMOB (scm_tc16_locale_smob_type
, "locale", 0);
236 #ifdef USE_GNU_LOCALE_API
238 SCM_SMOB_FREE (scm_tc16_locale_smob_type
, smob_locale_free
, locale
)
240 scm_t_locale c_locale
;
242 c_locale
= (scm_t_locale
) SCM_SMOB_DATA (locale
);
243 freelocale (c_locale
);
248 #endif /* USE_GNU_LOCALE_API */
251 static void inline scm_locale_error (const char *, int) SCM_NORETURN
;
253 /* Throw an exception corresponding to error ERR. */
255 scm_locale_error (const char *func_name
, int err
)
257 scm_syserror_msg (func_name
,
258 "Failed to install locale",
264 /* Emulating GNU's reentrant locale API. */
265 #ifndef USE_GNU_LOCALE_API
268 /* Maximum number of chained locales (via `base_locale'). */
269 #define LOCALE_STACK_SIZE_MAX 256
273 #define SCM_DEFINE_LOCALE_CATEGORY(_name) char * _name;
274 #include "locale-categories.h"
275 #undef SCM_DEFINE_LOCALE_CATEGORY
276 } scm_t_locale_settings
;
278 /* Fill out SETTINGS according to the current locale settings. On success
279 zero is returned and SETTINGS is properly initialized. */
281 get_current_locale_settings (scm_t_locale_settings
*settings
)
283 const char *locale_name
;
285 #define SCM_DEFINE_LOCALE_CATEGORY(_name) \
287 SCM_SYSCALL (locale_name = setlocale (LC_ ## _name, NULL)); \
288 if (locale_name == NULL) \
291 settings-> _name = strdup (locale_name); \
292 if (settings-> _name == NULL) \
296 #include "locale-categories.h"
297 #undef SCM_DEFINE_LOCALE_CATEGORY
308 /* Restore locale settings SETTINGS. On success, return zero. */
310 restore_locale_settings (const scm_t_locale_settings
*settings
)
314 #define SCM_DEFINE_LOCALE_CATEGORY(_name) \
315 SCM_SYSCALL (result = setlocale (LC_ ## _name, settings-> _name)); \
316 if (result == NULL) \
319 #include "locale-categories.h"
320 #undef SCM_DEFINE_LOCALE_CATEGORY
328 /* Free memory associated with SETTINGS. */
330 free_locale_settings (scm_t_locale_settings
*settings
)
332 #define SCM_DEFINE_LOCALE_CATEGORY(_name) \
333 free (settings-> _name); \
334 settings->_name = NULL;
335 #include "locale-categories.h"
336 #undef SCM_DEFINE_LOCALE_CATEGORY
339 /* Install the locale named LOCALE_NAME for all the categories listed in
342 install_locale_categories (const char *locale_name
, int category_mask
)
346 if (category_mask
== LC_ALL_MASK
)
348 SCM_SYSCALL (result
= setlocale (LC_ALL
, locale_name
));
354 #define SCM_DEFINE_LOCALE_CATEGORY(_name) \
355 if (category_mask & SCM_LOCALE_CATEGORY_MASK (_name)) \
357 SCM_SYSCALL (result = setlocale (LC_ ## _name, locale_name)); \
358 if (result == NULL) \
361 #include "locale-categories.h"
362 #undef SCM_DEFINE_LOCALE_CATEGORY
371 /* Install LOCALE, recursively installing its base locales first. On
372 success, zero is returned. */
374 install_locale (scm_t_locale locale
)
376 scm_t_locale stack
[LOCALE_STACK_SIZE_MAX
];
377 int category_mask
= 0;
378 size_t stack_size
= 0;
379 int stack_offset
= 0;
380 const char *result
= NULL
;
382 /* Build up a locale stack by traversing the `base_locale' link. */
385 if (stack_size
>= LOCALE_STACK_SIZE_MAX
)
386 /* We cannot use `scm_error ()' here because otherwise the locale
387 mutex may remain locked. */
390 stack
[stack_size
++] = locale
;
392 /* Keep track of which categories have already been taken into
394 category_mask
|= locale
->category_mask
;
396 if (!SCM_UNBNDP (locale
->base_locale
))
397 locale
= (scm_t_locale
) SCM_SMOB_DATA (locale
->base_locale
);
401 while ((locale
!= NULL
) && (category_mask
!= LC_ALL_MASK
));
403 /* Install the C locale to start from a pristine state. */
404 SCM_SYSCALL (result
= setlocale (LC_ALL
, "C"));
408 /* Install the locales in reverse order. */
409 for (stack_offset
= stack_size
- 1;
416 locale
= stack
[stack_offset
];
417 err
= install_locale_categories (locale
->locale_name
,
418 locale
->category_mask
);
429 /* Leave the locked locale section. */
431 leave_locale_section (const scm_t_locale_settings
*settings
)
433 /* Restore the previous locale settings. */
434 (void)restore_locale_settings (settings
);
436 unlock_locale_mutex ();
439 /* Enter a locked locale section. */
441 enter_locale_section (scm_t_locale locale
,
442 scm_t_locale_settings
*prev_locale
)
446 lock_locale_mutex ();
448 err
= get_current_locale_settings (prev_locale
);
451 unlock_locale_mutex ();
455 err
= install_locale (locale
);
458 leave_locale_section (prev_locale
);
459 free_locale_settings (prev_locale
);
465 /* Convenient macro to run STATEMENT in the locale context of C_LOCALE. */
466 #define RUN_IN_LOCALE_SECTION(_c_locale, _statement) \
470 scm_t_locale_settings lsec_prev_locale; \
472 lsec_err = enter_locale_section ((_c_locale), &lsec_prev_locale); \
474 scm_locale_error (FUNC_NAME, lsec_err); \
479 leave_locale_section (&lsec_prev_locale); \
480 free_locale_settings (&lsec_prev_locale); \
485 /* Convert the current locale settings into a locale SMOB. On success, zero
486 is returned and RESULT points to the new SMOB. Otherwise, an error is
489 get_current_locale (SCM
*result
)
492 scm_t_locale c_locale
;
493 const char *current_locale
;
495 c_locale
= scm_gc_malloc (sizeof (* c_locale
), "locale");
497 lock_locale_mutex ();
499 c_locale
->category_mask
= LC_ALL_MASK
;
500 c_locale
->base_locale
= SCM_UNDEFINED
;
502 current_locale
= setlocale (LC_ALL
, NULL
);
503 if (current_locale
!= NULL
)
504 c_locale
->locale_name
= scm_gc_strdup (current_locale
, "locale");
508 unlock_locale_mutex ();
511 SCM_NEWSMOB (*result
, scm_tc16_locale_smob_type
, c_locale
);
513 *result
= SCM_BOOL_F
;
518 #else /* USE_GNU_LOCALE_API */
520 /* Convenient macro to run STATEMENT in the locale context of C_LOCALE. */
521 #define RUN_IN_LOCALE_SECTION(_c_locale, _statement) \
524 scm_t_locale old_loc; \
526 old_loc = uselocale (_c_locale); \
528 uselocale (old_loc); \
533 #endif /* USE_GNU_LOCALE_API */
537 /* `make-locale' can take either category lists or single categories (the
538 `LC_*' integer constants). */
539 #define SCM_LIST_OR_INTEGER_P(arg) \
540 (scm_is_integer (arg) || scm_is_true (scm_list_p (arg)))
543 /* Return the category mask corresponding to CATEGORY (an `LC_' integer
546 category_to_category_mask (SCM category
,
547 const char *func_name
, int pos
)
552 c_category
= scm_to_int (category
);
554 #define SCM_DEFINE_LOCALE_CATEGORY(_name) \
556 c_category_mask = SCM_LOCALE_CATEGORY_MASK (_name); \
561 #include "locale-categories.h"
564 c_category_mask
= LC_ALL_MASK
;
568 scm_wrong_type_arg_msg (func_name
, pos
, category
,
572 #undef SCM_DEFINE_LOCALE_CATEGORY
574 return c_category_mask
;
577 /* Convert CATEGORIES, a list of locale categories or a single category (an
578 integer), into a category mask. */
580 category_list_to_category_mask (SCM categories
,
581 const char *func_name
, int pos
)
583 int c_category_mask
= 0;
585 if (scm_is_integer (categories
))
586 c_category_mask
= category_to_category_mask (categories
,
589 for (; !scm_is_null (categories
); categories
= SCM_CDR (categories
))
591 SCM category
= SCM_CAR (categories
);
594 category_to_category_mask (category
, func_name
, pos
);
597 return c_category_mask
;
601 SCM_DEFINE (scm_make_locale
, "make-locale", 2, 1, 0,
602 (SCM category_list
, SCM locale_name
, SCM base_locale
),
603 "Return a reference to a data structure representing a set of "
604 "locale datasets. @var{category_list} should be either a list "
605 "of locale categories or a single category as used with "
606 "@code{setlocale} (@pxref{Locales, @code{setlocale}}) and "
607 "@var{locale_name} should be the name of the locale considered "
608 "(e.g., @code{\"sl_SI\"}). Optionally, if @code{base_locale} is "
609 "passed, it should be a locale object denoting settings for "
610 "categories not listed in @var{category_list}.")
611 #define FUNC_NAME s_scm_make_locale
613 SCM locale
= SCM_BOOL_F
;
617 scm_t_locale c_base_locale
, c_locale
;
619 SCM_MAKE_VALIDATE (1, category_list
, LIST_OR_INTEGER_P
);
620 SCM_VALIDATE_STRING (2, locale_name
);
621 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, base_locale
, c_base_locale
);
623 c_category_mask
= category_list_to_category_mask (category_list
,
625 c_locale_name
= scm_to_locale_string (locale_name
);
627 #ifdef USE_GNU_LOCALE_API
629 if (scm_is_eq (base_locale
, SCM_VARIABLE_REF (scm_global_locale
)))
630 c_base_locale
= LC_GLOBAL_LOCALE
;
632 if (c_base_locale
!= (locale_t
) 0)
634 /* C_BASE_LOCALE is to be consumed by `newlocale ()' so it needs to be
635 duplicated before. */
636 c_base_locale
= duplocale (c_base_locale
);
638 if (c_base_locale
== (locale_t
) 0)
645 c_locale
= newlocale (c_category_mask
, c_locale_name
, c_base_locale
);
647 free (c_locale_name
);
648 c_locale_name
= NULL
;
650 if (c_locale
== (locale_t
) 0)
652 if (c_base_locale
!= (locale_t
) 0)
653 freelocale (c_base_locale
);
654 scm_locale_error (FUNC_NAME
, errno
);
657 SCM_NEWSMOB (locale
, scm_tc16_locale_smob_type
, c_locale
);
661 c_locale
= scm_gc_malloc (sizeof (* c_locale
), "locale");
663 c_locale
->category_mask
= c_category_mask
;
664 c_locale
->locale_name
= scm_gc_strdup (c_locale_name
, "locale");
665 free (c_locale_name
);
666 c_locale_name
= NULL
;
668 if (scm_is_eq (base_locale
, SCM_VARIABLE_REF (scm_global_locale
)))
670 /* Get the current locale settings and turn them into a locale
672 err
= get_current_locale (&base_locale
);
677 c_locale
->base_locale
= base_locale
;
680 /* Try out the new locale and raise an exception if it doesn't work. */
682 scm_t_locale_settings prev_locale
;
684 err
= enter_locale_section (c_locale
, &prev_locale
);
690 leave_locale_section (&prev_locale
);
691 SCM_NEWSMOB (locale
, scm_tc16_locale_smob_type
, c_locale
);
700 #ifndef USE_GNU_LOCALE_API
701 scm_gc_free (c_locale
, sizeof (* c_locale
), "locale");
703 free (c_locale_name
);
704 scm_locale_error (FUNC_NAME
, err
);
710 SCM_DEFINE (scm_locale_p
, "locale?", 1, 0, 0,
712 "Return true if @var{obj} is a locale object.")
713 #define FUNC_NAME s_scm_locale_p
715 return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_locale_smob_type
, obj
));
721 /* Locale-dependent string comparison.
723 A similar API can be found in MzScheme starting from version 200:
724 http://download.plt-scheme.org/chronology/mzmr200alpha14.html . */
726 #define SCM_STRING_TO_U32_BUF(s1, c_s1) \
729 if (scm_i_is_narrow_string (s1)) \
732 const char *buf = scm_i_string_chars (s1); \
734 len = scm_i_string_length (s1); \
735 c_s1 = alloca (sizeof (scm_t_wchar) * (len + 1)); \
737 for (i = 0; i < len; i ++) \
738 c_s1[i] = (unsigned char ) buf[i]; \
742 c_s1 = (scm_t_wchar *) scm_i_string_wide_chars (s1); \
746 /* Compare UTF-32 strings according to LOCALE. Returns a negative value if
747 S1 compares smaller than S2, a positive value if S1 compares larger than
748 S2, or 0 if they compare equal. */
750 compare_u32_strings (SCM s1
, SCM s2
, SCM locale
, const char *func_name
)
751 #define FUNC_NAME func_name
754 scm_t_locale c_locale
;
755 scm_t_wchar
*c_s1
, *c_s2
;
756 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale
, c_locale
);
758 SCM_STRING_TO_U32_BUF (s1
, c_s1
);
759 SCM_STRING_TO_U32_BUF (s2
, c_s2
);
762 RUN_IN_LOCALE_SECTION (c_locale
,
763 result
= u32_strcoll ((const scm_t_uint32
*) c_s1
,
764 (const scm_t_uint32
*) c_s2
));
766 result
= u32_strcoll ((const scm_t_uint32
*) c_s1
,
767 (const scm_t_uint32
*) c_s2
);
769 scm_remember_upto_here_2 (s1
, s2
);
770 scm_remember_upto_here (locale
);
775 /* Return the current language of the locale. */
779 /* Note: If the locale has been set with 'uselocale', uc_locale_language
780 from libunistring versions 0.9.1 and older will return the incorrect
781 (non-thread-specific) locale. This is fixed in versions 0.9.2 and
783 return uc_locale_language ();
787 u32_locale_casecoll (const char *func_name
, const scm_t_uint32
*c_s1
,
788 const scm_t_uint32
*c_s2
,
791 /* Note: Since this is called from `RUN_IN_LOCALE_SECTION', it must note
792 make any non-local exit. */
795 const char *loc
= locale_language ();
797 ret
= u32_casecoll (c_s1
, u32_strlen (c_s1
),
798 c_s2
, u32_strlen (c_s2
),
799 loc
, UNINORM_NFC
, result
);
801 return ret
== 0 ? ret
: errno
;
805 compare_u32_strings_ci (SCM s1
, SCM s2
, SCM locale
, const char *func_name
)
806 #define FUNC_NAME func_name
809 scm_t_locale c_locale
;
810 scm_t_wchar
*c_s1
, *c_s2
;
811 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale
, c_locale
);
813 SCM_STRING_TO_U32_BUF (s1
, c_s1
);
814 SCM_STRING_TO_U32_BUF (s2
, c_s2
);
817 RUN_IN_LOCALE_SECTION
819 ret
= u32_locale_casecoll (func_name
,
820 (const scm_t_uint32
*) c_s1
,
821 (const scm_t_uint32
*) c_s2
,
824 ret
= u32_locale_casecoll (func_name
,
825 (const scm_t_uint32
*) c_s1
,
826 (const scm_t_uint32
*) c_s2
,
829 if (SCM_UNLIKELY (ret
!= 0))
832 scm_syserror (FUNC_NAME
);
835 scm_remember_upto_here_2 (s1
, s2
);
836 scm_remember_upto_here (locale
);
842 /* Store into DST an upper-case version of SRC. */
844 str_upcase (register char *dst
, register const char *src
)
846 for (; *src
!= '\0'; src
++, dst
++)
847 *dst
= toupper ((int) *src
);
852 str_downcase (register char *dst
, register const char *src
)
854 for (; *src
!= '\0'; src
++, dst
++)
855 *dst
= tolower ((int) *src
);
859 #ifdef USE_GNU_LOCALE_API
861 str_upcase_l (register char *dst
, register const char *src
,
864 for (; *src
!= '\0'; src
++, dst
++)
865 *dst
= toupper_l (*src
, locale
);
870 str_downcase_l (register char *dst
, register const char *src
,
873 for (; *src
!= '\0'; src
++, dst
++)
874 *dst
= tolower_l (*src
, locale
);
880 SCM_DEFINE (scm_string_locale_lt
, "string-locale<?", 2, 1, 0,
881 (SCM s1
, SCM s2
, SCM locale
),
882 "Compare strings @var{s1} and @var{s2} in a locale-dependent way."
883 "If @var{locale} is provided, it should be locale object (as "
884 "returned by @code{make-locale}) and will be used to perform the "
885 "comparison; otherwise, the current system locale is used.")
886 #define FUNC_NAME s_scm_string_locale_lt
890 SCM_VALIDATE_STRING (1, s1
);
891 SCM_VALIDATE_STRING (2, s2
);
893 result
= compare_u32_strings (s1
, s2
, locale
, FUNC_NAME
);
895 return scm_from_bool (result
< 0);
899 SCM_DEFINE (scm_string_locale_gt
, "string-locale>?", 2, 1, 0,
900 (SCM s1
, SCM s2
, SCM locale
),
901 "Compare strings @var{s1} and @var{s2} in a locale-dependent way."
902 "If @var{locale} is provided, it should be locale object (as "
903 "returned by @code{make-locale}) and will be used to perform the "
904 "comparison; otherwise, the current system locale is used.")
905 #define FUNC_NAME s_scm_string_locale_gt
909 SCM_VALIDATE_STRING (1, s1
);
910 SCM_VALIDATE_STRING (2, s2
);
912 result
= compare_u32_strings (s1
, s2
, locale
, FUNC_NAME
);
914 return scm_from_bool (result
> 0);
918 SCM_DEFINE (scm_string_locale_ci_lt
, "string-locale-ci<?", 2, 1, 0,
919 (SCM s1
, SCM s2
, SCM locale
),
920 "Compare strings @var{s1} and @var{s2} in a case-insensitive, "
921 "and locale-dependent way. If @var{locale} is provided, it "
922 "should be locale object (as returned by @code{make-locale}) "
923 "and will be used to perform the comparison; otherwise, the "
924 "current system locale is used.")
925 #define FUNC_NAME s_scm_string_locale_ci_lt
929 SCM_VALIDATE_STRING (1, s1
);
930 SCM_VALIDATE_STRING (2, s2
);
932 result
= compare_u32_strings_ci (s1
, s2
, locale
, FUNC_NAME
);
934 return scm_from_bool (result
< 0);
938 SCM_DEFINE (scm_string_locale_ci_gt
, "string-locale-ci>?", 2, 1, 0,
939 (SCM s1
, SCM s2
, SCM locale
),
940 "Compare strings @var{s1} and @var{s2} in a case-insensitive, "
941 "and locale-dependent way. If @var{locale} is provided, it "
942 "should be locale object (as returned by @code{make-locale}) "
943 "and will be used to perform the comparison; otherwise, the "
944 "current system locale is used.")
945 #define FUNC_NAME s_scm_string_locale_ci_gt
949 SCM_VALIDATE_STRING (1, s1
);
950 SCM_VALIDATE_STRING (2, s2
);
952 result
= compare_u32_strings_ci (s1
, s2
, locale
, FUNC_NAME
);
954 return scm_from_bool (result
> 0);
958 SCM_DEFINE (scm_string_locale_ci_eq
, "string-locale-ci=?", 2, 1, 0,
959 (SCM s1
, SCM s2
, SCM locale
),
960 "Compare strings @var{s1} and @var{s2} in a case-insensitive, "
961 "and locale-dependent way. If @var{locale} is provided, it "
962 "should be locale object (as returned by @code{make-locale}) "
963 "and will be used to perform the comparison; otherwise, the "
964 "current system locale is used.")
965 #define FUNC_NAME s_scm_string_locale_ci_eq
969 SCM_VALIDATE_STRING (1, s1
);
970 SCM_VALIDATE_STRING (2, s2
);
972 result
= compare_u32_strings_ci (s1
, s2
, locale
, FUNC_NAME
);
974 return scm_from_bool (result
== 0);
979 SCM_DEFINE (scm_char_locale_lt
, "char-locale<?", 2, 1, 0,
980 (SCM c1
, SCM c2
, SCM locale
),
981 "Return true if character @var{c1} is lower than @var{c2} "
982 "according to @var{locale} or to the current locale.")
983 #define FUNC_NAME s_scm_char_locale_lt
987 SCM_VALIDATE_CHAR (1, c1
);
988 SCM_VALIDATE_CHAR (2, c2
);
990 result
= compare_u32_strings (scm_string (scm_list_1 (c1
)),
991 scm_string (scm_list_1 (c2
)),
994 return scm_from_bool (result
< 0);
998 SCM_DEFINE (scm_char_locale_gt
, "char-locale>?", 2, 1, 0,
999 (SCM c1
, SCM c2
, SCM locale
),
1000 "Return true if character @var{c1} is greater than @var{c2} "
1001 "according to @var{locale} or to the current locale.")
1002 #define FUNC_NAME s_scm_char_locale_gt
1006 SCM_VALIDATE_CHAR (1, c1
);
1007 SCM_VALIDATE_CHAR (2, c2
);
1009 result
= compare_u32_strings (scm_string (scm_list_1 (c1
)),
1010 scm_string (scm_list_1 (c2
)),
1013 return scm_from_bool (result
> 0);
1017 SCM_DEFINE (scm_char_locale_ci_lt
, "char-locale-ci<?", 2, 1, 0,
1018 (SCM c1
, SCM c2
, SCM locale
),
1019 "Return true if character @var{c1} is lower than @var{c2}, "
1020 "in a case insensitive way according to @var{locale} or to "
1021 "the current locale.")
1022 #define FUNC_NAME s_scm_char_locale_ci_lt
1026 SCM_VALIDATE_CHAR (1, c1
);
1027 SCM_VALIDATE_CHAR (2, c2
);
1029 result
= compare_u32_strings_ci (scm_string (scm_list_1 (c1
)),
1030 scm_string (scm_list_1 (c2
)),
1033 return scm_from_bool (result
< 0);
1037 SCM_DEFINE (scm_char_locale_ci_gt
, "char-locale-ci>?", 2, 1, 0,
1038 (SCM c1
, SCM c2
, SCM locale
),
1039 "Return true if character @var{c1} is greater than @var{c2}, "
1040 "in a case insensitive way according to @var{locale} or to "
1041 "the current locale.")
1042 #define FUNC_NAME s_scm_char_locale_ci_gt
1046 SCM_VALIDATE_CHAR (1, c1
);
1047 SCM_VALIDATE_CHAR (2, c2
);
1049 result
= compare_u32_strings_ci (scm_string (scm_list_1 (c1
)),
1050 scm_string (scm_list_1 (c2
)),
1053 return scm_from_bool (result
> 0);
1057 SCM_DEFINE (scm_char_locale_ci_eq
, "char-locale-ci=?", 2, 1, 0,
1058 (SCM c1
, SCM c2
, SCM locale
),
1059 "Return true if character @var{c1} is equal to @var{c2}, "
1060 "in a case insensitive way according to @var{locale} or to "
1061 "the current locale.")
1062 #define FUNC_NAME s_scm_char_locale_ci_eq
1066 SCM_VALIDATE_CHAR (1, c1
);
1067 SCM_VALIDATE_CHAR (2, c2
);
1069 result
= compare_u32_strings_ci (scm_string (scm_list_1 (c1
)),
1070 scm_string (scm_list_1 (c2
)),
1073 return scm_from_bool (result
== 0);
1079 /* Locale-dependent alphabetic character mapping. */
1082 u32_locale_tocase (const scm_t_uint32
*c_s1
, size_t len
,
1083 scm_t_uint32
**p_c_s2
, size_t * p_len2
,
1084 scm_t_uint32
*(*func
) (const scm_t_uint32
*, size_t,
1085 const char *, uninorm_t
,
1086 scm_t_uint32
*, size_t *))
1088 /* Note: Since this is called from `RUN_IN_LOCALE_SECTION', it must not
1089 make any non-local exit. */
1092 const char *loc
= locale_language ();
1094 /* The first NULL here indicates that no NFC or NFKC normalization
1095 is done. The second NULL means the return buffer is
1097 ret
= func (c_s1
, len
, loc
, NULL
, NULL
, p_len2
);
1101 *p_c_s2
= (scm_t_uint32
*) NULL
;
1112 chr_to_case (SCM chr
, scm_t_locale c_locale
,
1113 scm_t_uint32
*(*func
) (const scm_t_uint32
*, size_t, const char *,
1114 uninorm_t
, scm_t_uint32
*, size_t *),
1115 const char *func_name
,
1117 #define FUNC_NAME func_name
1121 scm_t_uint32
*convbuf
;
1127 if (c_locale
!= NULL
)
1128 RUN_IN_LOCALE_SECTION (c_locale
, ret
=
1129 u32_locale_tocase (&c
, 1, &convbuf
, &convlen
, func
));
1132 u32_locale_tocase (&c
, 1, &convbuf
, &convlen
, func
);
1134 if (SCM_UNLIKELY (ret
!= 0))
1141 convchar
= SCM_MAKE_CHAR ((scm_t_wchar
) convbuf
[0]);
1150 SCM_DEFINE (scm_char_locale_downcase
, "char-locale-downcase", 1, 1, 0,
1151 (SCM chr
, SCM locale
),
1152 "Return the lowercase character that corresponds to @var{chr} "
1153 "according to either @var{locale} or the current locale.")
1154 #define FUNC_NAME s_scm_char_locale_downcase
1156 scm_t_locale c_locale
;
1160 SCM_VALIDATE_CHAR (1, chr
);
1161 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale
, c_locale
);
1163 ret
= chr_to_case (chr
, c_locale
, u32_tolower
, FUNC_NAME
, &err
);
1168 scm_syserror (FUNC_NAME
);
1174 SCM_DEFINE (scm_char_locale_upcase
, "char-locale-upcase", 1, 1, 0,
1175 (SCM chr
, SCM locale
),
1176 "Return the uppercase character that corresponds to @var{chr} "
1177 "according to either @var{locale} or the current locale.")
1178 #define FUNC_NAME s_scm_char_locale_upcase
1180 scm_t_locale c_locale
;
1184 SCM_VALIDATE_CHAR (1, chr
);
1185 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale
, c_locale
);
1187 ret
= chr_to_case (chr
, c_locale
, u32_toupper
, FUNC_NAME
, &err
);
1192 scm_syserror (FUNC_NAME
);
1198 SCM_DEFINE (scm_char_locale_titlecase
, "char-locale-titlecase", 1, 1, 0,
1199 (SCM chr
, SCM locale
),
1200 "Return the titlecase character that corresponds to @var{chr} "
1201 "according to either @var{locale} or the current locale.")
1202 #define FUNC_NAME s_scm_char_locale_titlecase
1204 scm_t_locale c_locale
;
1208 SCM_VALIDATE_CHAR (1, chr
);
1209 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale
, c_locale
);
1211 ret
= chr_to_case (chr
, c_locale
, u32_totitle
, FUNC_NAME
, &err
);
1216 scm_syserror (FUNC_NAME
);
1223 str_to_case (SCM str
, scm_t_locale c_locale
,
1224 scm_t_uint32
*(*func
) (const scm_t_uint32
*, size_t, const char *,
1225 uninorm_t
, scm_t_uint32
*, size_t *),
1226 const char *func_name
,
1228 #define FUNC_NAME func_name
1230 scm_t_wchar
*c_str
, *c_buf
;
1231 scm_t_uint32
*c_convstr
;
1232 size_t len
, convlen
;
1236 len
= scm_i_string_length (str
);
1239 SCM_STRING_TO_U32_BUF (str
, c_str
);
1242 RUN_IN_LOCALE_SECTION (c_locale
, ret
=
1243 u32_locale_tocase ((scm_t_uint32
*) c_str
, len
,
1248 u32_locale_tocase ((scm_t_uint32
*) c_str
, len
,
1249 &c_convstr
, &convlen
, func
);
1251 scm_remember_upto_here (str
);
1253 if (SCM_UNLIKELY (ret
!= 0))
1259 convstr
= scm_i_make_wide_string (convlen
, &c_buf
, 0);
1260 memcpy (c_buf
, c_convstr
, convlen
* sizeof (scm_t_wchar
));
1263 scm_i_try_narrow_string (convstr
);
1269 SCM_DEFINE (scm_string_locale_upcase
, "string-locale-upcase", 1, 1, 0,
1270 (SCM str
, SCM locale
),
1271 "Return a new string that is the uppercase version of "
1272 "@var{str} according to either @var{locale} or the current "
1274 #define FUNC_NAME s_scm_string_locale_upcase
1276 scm_t_locale c_locale
;
1280 SCM_VALIDATE_STRING (1, str
);
1281 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale
, c_locale
);
1283 ret
= str_to_case (str
, c_locale
, u32_toupper
, FUNC_NAME
, &err
);
1288 scm_syserror (FUNC_NAME
);
1294 SCM_DEFINE (scm_string_locale_downcase
, "string-locale-downcase", 1, 1, 0,
1295 (SCM str
, SCM locale
),
1296 "Return a new string that is the down-case version of "
1297 "@var{str} according to either @var{locale} or the current "
1299 #define FUNC_NAME s_scm_string_locale_downcase
1301 scm_t_locale c_locale
;
1305 SCM_VALIDATE_STRING (1, str
);
1306 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale
, c_locale
);
1308 ret
= str_to_case (str
, c_locale
, u32_tolower
, FUNC_NAME
, &err
);
1313 scm_syserror (FUNC_NAME
);
1319 SCM_DEFINE (scm_string_locale_titlecase
, "string-locale-titlecase", 1, 1, 0,
1320 (SCM str
, SCM locale
),
1321 "Return a new string that is the title-case version of "
1322 "@var{str} according to either @var{locale} or the current "
1324 #define FUNC_NAME s_scm_string_locale_titlecase
1326 scm_t_locale c_locale
;
1330 SCM_VALIDATE_STRING (1, str
);
1331 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale
, c_locale
);
1333 ret
= str_to_case (str
, c_locale
, u32_totitle
, FUNC_NAME
, &err
);
1338 scm_syserror (FUNC_NAME
);
1344 /* Note: We don't provide mutative versions of `string-locale-(up|down)case'
1345 because, in some languages, a single downcase character maps to a couple
1346 of uppercase characters. Read the SRFI-13 document for a detailed
1347 discussion about this. */
1351 /* Locale-dependent number parsing. */
1353 SCM_DEFINE (scm_locale_string_to_integer
, "locale-string->integer",
1354 1, 2, 0, (SCM str
, SCM base
, SCM locale
),
1355 "Convert string @var{str} into an integer according to either "
1356 "@var{locale} (a locale object as returned by @code{make-locale}) "
1357 "or the current process locale. Return two values: an integer "
1358 "(on success) or @code{#f}, and the number of characters read "
1359 "from @var{str} (@code{0} on failure).")
1360 #define FUNC_NAME s_scm_locale_string_to_integer
1367 scm_t_locale c_locale
;
1369 SCM_VALIDATE_STRING (1, str
);
1370 c_str
= scm_i_string_chars (str
);
1372 if (!scm_is_eq (base
, SCM_UNDEFINED
))
1373 SCM_VALIDATE_INT_COPY (2, base
, c_base
);
1377 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale
, c_locale
);
1379 if (c_locale
!= NULL
)
1381 #ifdef USE_GNU_LOCALE_API
1382 c_result
= strtol_l (c_str
, &c_endptr
, c_base
, c_locale
);
1384 RUN_IN_LOCALE_SECTION (c_locale
,
1385 c_result
= strtol (c_str
, &c_endptr
, c_base
));
1389 c_result
= strtol (c_str
, &c_endptr
, c_base
);
1391 scm_remember_upto_here (str
);
1393 if (c_endptr
== c_str
)
1394 result
= SCM_BOOL_F
;
1396 result
= scm_from_long (c_result
);
1398 return (scm_values (scm_list_2 (result
, scm_from_long (c_endptr
- c_str
))));
1402 SCM_DEFINE (scm_locale_string_to_inexact
, "locale-string->inexact",
1403 1, 1, 0, (SCM str
, SCM locale
),
1404 "Convert string @var{str} into an inexact number according to "
1405 "either @var{locale} (a locale object as returned by "
1406 "@code{make-locale}) or the current process locale. Return "
1407 "two values: an inexact number (on success) or @code{#f}, and "
1408 "the number of characters read from @var{str} (@code{0} on "
1410 #define FUNC_NAME s_scm_locale_string_to_inexact
1416 scm_t_locale c_locale
;
1418 SCM_VALIDATE_STRING (1, str
);
1419 c_str
= scm_i_string_chars (str
);
1421 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale
, c_locale
);
1423 if (c_locale
!= NULL
)
1425 #ifdef USE_GNU_LOCALE_API
1426 c_result
= strtod_l (c_str
, &c_endptr
, c_locale
);
1428 RUN_IN_LOCALE_SECTION (c_locale
,
1429 c_result
= strtod (c_str
, &c_endptr
));
1433 c_result
= strtod (c_str
, &c_endptr
);
1435 scm_remember_upto_here (str
);
1437 if (c_endptr
== c_str
)
1438 result
= SCM_BOOL_F
;
1440 result
= scm_from_double (c_result
);
1442 return (scm_values (scm_list_2 (result
, scm_from_long (c_endptr
- c_str
))));
1447 /* Language information, aka. `nl_langinfo ()'. */
1449 /* FIXME: Issues related to `nl-langinfo'.
1451 1. The `CODESET' value is not normalized. This is a secondary issue, but
1452 still a practical issue. See
1453 http://www.cl.cam.ac.uk/~mgk25/ucs/norm_charmap.c for codeset
1456 2. `nl_langinfo ()' is not available on Windows.
1458 3. `nl_langinfo ()' may return strings encoded in a locale different from
1462 (nl-langinfo DAY_1 (make-locale LC_ALL "eo_EO.UTF-8"))
1464 returns a result that is a UTF-8 string, regardless of the
1465 setting of the current locale. If nl_langinfo supports CODESET,
1466 we can convert the string properly using scm_from_stringn. If
1467 CODESET is not supported, we won't be able to make much sense of
1468 the returned string.
1470 Note: We don't use Gnulib's `nl_langinfo' module because it's currently not
1471 as complete as the compatibility hacks in `i18n.scm'. */
1474 SCM_DEFINE (scm_nl_langinfo
, "nl-langinfo", 1, 1, 0,
1475 (SCM item
, SCM locale
),
1476 "Return a string denoting locale information for @var{item} "
1477 "in the current locale or that specified by @var{locale}. "
1478 "The semantics and arguments are the same as those of the "
1479 "X/Open @code{nl_langinfo} function (@pxref{The Elegant and "
1480 "Fast Way, @code{nl_langinfo},, libc, The GNU C Library "
1481 "Reference Manual}).")
1482 #define FUNC_NAME s_scm_nl_langinfo
1484 #ifdef HAVE_NL_LANGINFO
1488 scm_t_locale c_locale
;
1489 #ifdef HAVE_LANGINFO_CODESET
1493 SCM_VALIDATE_INT_COPY (2, item
, c_item
);
1494 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale
, c_locale
);
1496 /* Sadly, `nl_langinfo ()' returns a pointer to a static string. According
1497 to SuS v2, that static string may be modified by subsequent calls to
1498 `nl_langinfo ()' as well as by calls to `setlocale ()'. Thus, we must
1499 acquire the locale mutex before doing invoking `nl_langinfo ()'. See
1500 http://opengroup.org/onlinepubs/007908799/xsh/nl_langinfo.html for
1503 lock_locale_mutex ();
1504 if (c_locale
!= NULL
)
1506 #ifdef USE_GNU_LOCALE_API
1507 c_result
= nl_langinfo_l (c_item
, c_locale
);
1508 #ifdef HAVE_LANGINFO_CODESET
1509 codeset
= nl_langinfo_l (CODESET
, c_locale
);
1510 #endif /* HAVE_LANGINFO_CODESET */
1511 #else /* !USE_GNU_LOCALE_API */
1512 /* We can't use `RUN_IN_LOCALE_SECTION ()' here because the locale
1513 mutex is already taken. */
1515 scm_t_locale_settings lsec_prev_locale
;
1517 lsec_err
= get_current_locale_settings (&lsec_prev_locale
);
1519 unlock_locale_mutex ();
1522 lsec_err
= install_locale (c_locale
);
1525 leave_locale_section (&lsec_prev_locale
);
1526 free_locale_settings (&lsec_prev_locale
);
1531 scm_locale_error (FUNC_NAME
, lsec_err
);
1534 c_result
= nl_langinfo (c_item
);
1535 #ifdef HAVE_LANGINFO_CODESET
1536 codeset
= nl_langinfo (CODESET
);
1537 #endif /* HAVE_LANGINFO_CODESET */
1539 restore_locale_settings (&lsec_prev_locale
);
1540 free_locale_settings (&lsec_prev_locale
);
1546 c_result
= nl_langinfo (c_item
);
1547 #ifdef HAVE_LANGINFO_CODESET
1548 codeset
= nl_langinfo (CODESET
);
1549 #endif /* HAVE_LANGINFO_CODESET */
1552 c_result
= strdup (c_result
);
1553 unlock_locale_mutex ();
1555 if (c_result
== NULL
)
1556 result
= SCM_BOOL_F
;
1561 #if (defined GROUPING) && (defined MON_GROUPING)
1567 /* In this cases, the result is to be interpreted as a list
1568 of numbers. If the last item is `CHAR_MAX' or a negative
1569 number, it has the special meaning "no more grouping"
1570 (negative numbers aren't specified in POSIX but can be
1572 <http://lists.gnu.org/archive/html/bug-guile/2011-02/msg00159.html>). */
1574 for (p
= c_result
; (*p
> 0) && (*p
!= CHAR_MAX
); p
++)
1575 result
= scm_cons (SCM_I_MAKINUM ((int) *p
), result
);
1578 SCM last_pair
= result
;
1580 result
= scm_reverse_x (result
, SCM_EOL
);
1584 /* Cyclic grouping information. */
1585 if (!scm_is_null (last_pair
))
1586 SCM_SETCDR (last_pair
, result
);
1595 #if (defined FRAC_DIGITS) && (defined INT_FRAC_DIGITS)
1597 case INT_FRAC_DIGITS
:
1598 /* This is to be interpreted as a single integer. */
1599 if (*c_result
== CHAR_MAX
)
1601 result
= SCM_BOOL_F
;
1603 result
= SCM_I_MAKINUM (*c_result
);
1609 #if (defined P_CS_PRECEDES) && (defined INT_N_CS_PRECEDES)
1612 case INT_P_CS_PRECEDES
:
1613 case INT_N_CS_PRECEDES
:
1614 #if (defined P_SEP_BY_SPACE) && (defined N_SEP_BY_SPACE)
1615 case P_SEP_BY_SPACE
:
1616 case N_SEP_BY_SPACE
:
1618 /* This is to be interpreted as a boolean. */
1619 result
= scm_from_bool (*c_result
);
1625 #if (defined P_SIGN_POSN) && (defined INT_N_SIGN_POSN)
1628 case INT_P_SIGN_POSN
:
1629 case INT_N_SIGN_POSN
:
1630 /* See `(libc) Sign of Money Amount' for the interpretation of the
1631 return value here. */
1635 result
= scm_from_latin1_symbol ("parenthesize");
1639 result
= scm_from_latin1_symbol ("sign-before");
1643 result
= scm_from_latin1_symbol ("sign-after");
1647 result
= scm_from_latin1_symbol ("sign-before-currency-symbol");
1651 result
= scm_from_latin1_symbol ("sign-after-currency-symbol");
1655 result
= scm_from_latin1_symbol ("unspecified");
1662 #ifdef HAVE_LANGINFO_CODESET
1663 result
= scm_from_stringn (c_result
, strlen (c_result
),
1665 SCM_FAILED_CONVERSION_QUESTION_MARK
);
1666 #else /* !HAVE_LANGINFO_CODESET */
1667 /* This may be incorrectly encoded if the locale differs
1668 from the c_locale. */
1669 result
= scm_from_locale_string (c_result
);
1670 #endif /* !HAVE_LANGINFO_CODESET */
1677 scm_syserror_msg (FUNC_NAME
, "`nl-langinfo' not supported on your system",
1685 /* Define the `nl_item' constants. */
1687 define_langinfo_items (void)
1689 #ifdef HAVE_LANGINFO_H
1691 #define DEFINE_NLITEM_CONSTANT(_item) \
1692 scm_c_define (# _item, scm_from_int (_item))
1694 DEFINE_NLITEM_CONSTANT (CODESET
);
1696 /* Abbreviated days of the week. */
1697 DEFINE_NLITEM_CONSTANT (ABDAY_1
);
1698 DEFINE_NLITEM_CONSTANT (ABDAY_2
);
1699 DEFINE_NLITEM_CONSTANT (ABDAY_3
);
1700 DEFINE_NLITEM_CONSTANT (ABDAY_4
);
1701 DEFINE_NLITEM_CONSTANT (ABDAY_5
);
1702 DEFINE_NLITEM_CONSTANT (ABDAY_6
);
1703 DEFINE_NLITEM_CONSTANT (ABDAY_7
);
1705 /* Long-named days of the week. */
1706 DEFINE_NLITEM_CONSTANT (DAY_1
); /* Sunday */
1707 DEFINE_NLITEM_CONSTANT (DAY_2
); /* Monday */
1708 DEFINE_NLITEM_CONSTANT (DAY_3
); /* Tuesday */
1709 DEFINE_NLITEM_CONSTANT (DAY_4
); /* Wednesday */
1710 DEFINE_NLITEM_CONSTANT (DAY_5
); /* Thursday */
1711 DEFINE_NLITEM_CONSTANT (DAY_6
); /* Friday */
1712 DEFINE_NLITEM_CONSTANT (DAY_7
); /* Saturday */
1714 /* Abbreviated month names. */
1715 DEFINE_NLITEM_CONSTANT (ABMON_1
); /* Jan */
1716 DEFINE_NLITEM_CONSTANT (ABMON_2
);
1717 DEFINE_NLITEM_CONSTANT (ABMON_3
);
1718 DEFINE_NLITEM_CONSTANT (ABMON_4
);
1719 DEFINE_NLITEM_CONSTANT (ABMON_5
);
1720 DEFINE_NLITEM_CONSTANT (ABMON_6
);
1721 DEFINE_NLITEM_CONSTANT (ABMON_7
);
1722 DEFINE_NLITEM_CONSTANT (ABMON_8
);
1723 DEFINE_NLITEM_CONSTANT (ABMON_9
);
1724 DEFINE_NLITEM_CONSTANT (ABMON_10
);
1725 DEFINE_NLITEM_CONSTANT (ABMON_11
);
1726 DEFINE_NLITEM_CONSTANT (ABMON_12
);
1728 /* Long month names. */
1729 DEFINE_NLITEM_CONSTANT (MON_1
); /* January */
1730 DEFINE_NLITEM_CONSTANT (MON_2
);
1731 DEFINE_NLITEM_CONSTANT (MON_3
);
1732 DEFINE_NLITEM_CONSTANT (MON_4
);
1733 DEFINE_NLITEM_CONSTANT (MON_5
);
1734 DEFINE_NLITEM_CONSTANT (MON_6
);
1735 DEFINE_NLITEM_CONSTANT (MON_7
);
1736 DEFINE_NLITEM_CONSTANT (MON_8
);
1737 DEFINE_NLITEM_CONSTANT (MON_9
);
1738 DEFINE_NLITEM_CONSTANT (MON_10
);
1739 DEFINE_NLITEM_CONSTANT (MON_11
);
1740 DEFINE_NLITEM_CONSTANT (MON_12
);
1742 DEFINE_NLITEM_CONSTANT (AM_STR
); /* Ante meridiem string. */
1743 DEFINE_NLITEM_CONSTANT (PM_STR
); /* Post meridiem string. */
1745 DEFINE_NLITEM_CONSTANT (D_T_FMT
); /* Date and time format for strftime. */
1746 DEFINE_NLITEM_CONSTANT (D_FMT
); /* Date format for strftime. */
1747 DEFINE_NLITEM_CONSTANT (T_FMT
); /* Time format for strftime. */
1748 DEFINE_NLITEM_CONSTANT (T_FMT_AMPM
);/* 12-hour time format for strftime. */
1751 DEFINE_NLITEM_CONSTANT (ERA
); /* Alternate era. */
1754 DEFINE_NLITEM_CONSTANT (ERA_D_FMT
); /* Date in alternate era format. */
1757 DEFINE_NLITEM_CONSTANT (ERA_D_T_FMT
); /* Date and time in alternate era
1761 DEFINE_NLITEM_CONSTANT (ERA_T_FMT
); /* Time in alternate era format. */
1765 DEFINE_NLITEM_CONSTANT (ALT_DIGITS
); /* Alternate symbols for digits. */
1767 DEFINE_NLITEM_CONSTANT (RADIXCHAR
);
1768 DEFINE_NLITEM_CONSTANT (THOUSEP
);
1771 DEFINE_NLITEM_CONSTANT (YESEXPR
);
1774 DEFINE_NLITEM_CONSTANT (NOEXPR
);
1777 #ifdef CRNCYSTR /* currency symbol */
1778 DEFINE_NLITEM_CONSTANT (CRNCYSTR
);
1781 /* GNU extensions. */
1784 DEFINE_NLITEM_CONSTANT (ERA_YEAR
); /* Year in alternate era format. */
1787 /* LC_MONETARY category: formatting of monetary quantities.
1788 These items each correspond to a member of `struct lconv',
1789 defined in <locale.h>. */
1790 #ifdef INT_CURR_SYMBOL
1791 DEFINE_NLITEM_CONSTANT (INT_CURR_SYMBOL
);
1793 #ifdef MON_DECIMAL_POINT
1794 DEFINE_NLITEM_CONSTANT (MON_DECIMAL_POINT
);
1796 #ifdef MON_THOUSANDS_SEP
1797 DEFINE_NLITEM_CONSTANT (MON_THOUSANDS_SEP
);
1800 DEFINE_NLITEM_CONSTANT (MON_GROUPING
);
1802 #ifdef POSITIVE_SIGN
1803 DEFINE_NLITEM_CONSTANT (POSITIVE_SIGN
);
1805 #ifdef NEGATIVE_SIGN
1806 DEFINE_NLITEM_CONSTANT (NEGATIVE_SIGN
);
1809 DEFINE_NLITEM_CONSTANT (GROUPING
);
1811 #ifdef INT_FRAC_DIGITS
1812 DEFINE_NLITEM_CONSTANT (INT_FRAC_DIGITS
);
1815 DEFINE_NLITEM_CONSTANT (FRAC_DIGITS
);
1817 #ifdef P_CS_PRECEDES
1818 DEFINE_NLITEM_CONSTANT (P_CS_PRECEDES
);
1820 #ifdef P_SEP_BY_SPACE
1821 DEFINE_NLITEM_CONSTANT (P_SEP_BY_SPACE
);
1823 #ifdef N_CS_PRECEDES
1824 DEFINE_NLITEM_CONSTANT (N_CS_PRECEDES
);
1826 #ifdef N_SEP_BY_SPACE
1827 DEFINE_NLITEM_CONSTANT (N_SEP_BY_SPACE
);
1830 DEFINE_NLITEM_CONSTANT (P_SIGN_POSN
);
1833 DEFINE_NLITEM_CONSTANT (N_SIGN_POSN
);
1835 #ifdef INT_P_CS_PRECEDES
1836 DEFINE_NLITEM_CONSTANT (INT_P_CS_PRECEDES
);
1838 #ifdef INT_P_SEP_BY_SPACE
1839 DEFINE_NLITEM_CONSTANT (INT_P_SEP_BY_SPACE
);
1841 #ifdef INT_N_CS_PRECEDES
1842 DEFINE_NLITEM_CONSTANT (INT_N_CS_PRECEDES
);
1844 #ifdef INT_N_SEP_BY_SPACE
1845 DEFINE_NLITEM_CONSTANT (INT_N_SEP_BY_SPACE
);
1847 #ifdef INT_P_SIGN_POSN
1848 DEFINE_NLITEM_CONSTANT (INT_P_SIGN_POSN
);
1850 #ifdef INT_N_SIGN_POSN
1851 DEFINE_NLITEM_CONSTANT (INT_N_SIGN_POSN
);
1854 #undef DEFINE_NLITEM_CONSTANT
1856 #endif /* HAVE_NL_TYPES_H */
1863 SCM global_locale_smob
;
1865 #ifdef HAVE_NL_LANGINFO
1866 scm_add_feature ("nl-langinfo");
1867 define_langinfo_items ();
1870 #include "libguile/i18n.x"
1872 /* Initialize the global locale object with a special `locale' SMOB. */
1873 /* XXX: We don't define it as `LC_GLOBAL_LOCALE' because of bugs as of
1874 glibc <= 2.11 not (yet) worked around by Gnulib. See
1875 http://sourceware.org/bugzilla/show_bug.cgi?id=11009 for details. */
1876 SCM_NEWSMOB (global_locale_smob
, scm_tc16_locale_smob_type
, NULL
);
1877 SCM_VARIABLE_SET (scm_global_locale
, global_locale_smob
);
1881 scm_bootstrap_i18n ()
1883 scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION
,
1885 (scm_t_extension_init_func
) scm_init_i18n
,