1 /* Copyright (C) 2006 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
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful,
9 * but 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 02110-1301 USA
18 #define _GNU_SOURCE /* Ask for glibc's `newlocale' API */
26 #elif defined __GNUC__
27 # define alloca __builtin_alloca
29 # define alloca __alloca
30 #elif defined _MSC_VER
32 # define alloca _alloca
38 void *alloca (size_t);
41 #include "libguile/_scm.h"
42 #include "libguile/feature.h"
43 #include "libguile/i18n.h"
44 #include "libguile/strings.h"
45 #include "libguile/chars.h"
46 #include "libguile/dynwind.h"
47 #include "libguile/validate.h"
48 #include "libguile/values.h"
51 #include <string.h> /* `strcoll ()' */
52 #include <ctype.h> /* `toupper ()' et al. */
55 #if (defined HAVE_NEWLOCALE) && (defined HAVE_STRCOLL_L)
56 # define USE_GNU_LOCALE_API
59 #ifndef USE_GNU_LOCALE_API
60 # include "libguile/posix.h" /* for `scm_i_locale_mutex' */
63 #ifndef HAVE_SETLOCALE
65 setlocale (int category
, const char *name
)
74 /* Locale objects, string and character collation, and other locale-dependent
77 A large part of the code here deals with emulating glibc's reentrant
78 locale API on non-GNU systems. The emulation is a bit "brute-force":
79 Whenever a `-locale<?' procedure is passed a locale object, then:
81 1. The `scm_t_locale_mutex' is locked.
82 2. A series of `setlocale ()' call is performed to store the current
83 locale for each category in an `scm_t_locale_settings' object.
84 3. A series of `setlocale ()' call is made to install each of the locale
85 categories of each of the base locales of each locale object,
86 recursively, starting from the last locale object of the chain.
87 4. The settings captured in step (2) are restored.
88 5. The `scm_t_locale_mutex' is released.
90 Hopefully, some smart standard will make that hack useless someday...
91 A similar API can be found in MzScheme starting from version 200:
92 http://download.plt-scheme.org/chronology/mzmr200alpha14.html .
94 Note: We don't wrap glibc's `uselocale ()' call because it sets the locale
95 of the current _thread_ (unlike `setlocale ()') and doing so would require
96 maintaining per-thread locale information on non-GNU systems and always
97 re-installing this locale upon locale-dependent calls. */
100 #ifndef USE_GNU_LOCALE_API
102 /* Provide the locale category masks as found in glibc (copied from
103 <locale.h> as found in glibc 2.3.6). This must be kept in sync with
104 `locale-categories.h'. */
106 # define LC_CTYPE_MASK (1 << LC_CTYPE)
107 # define LC_COLLATE_MASK (1 << LC_COLLATE)
108 # define LC_MESSAGES_MASK (1 << LC_MESSAGES)
109 # define LC_MONETARY_MASK (1 << LC_MONETARY)
110 # define LC_NUMERIC_MASK (1 << LC_NUMERIC)
111 # define LC_TIME_MASK (1 << LC_TIME)
114 # define LC_PAPER_MASK (1 << LC_PAPER)
116 # define LC_PAPER_MASK 0
119 # define LC_NAME_MASK (1 << LC_NAME)
121 # define LC_NAME_MASK 0
124 # define LC_ADDRESS_MASK (1 << LC_ADDRESS)
126 # define LC_ADDRESS_MASK 0
129 # define LC_TELEPHONE_MASK (1 << LC_TELEPHONE)
131 # define LC_TELEPHONE_MASK 0
133 # ifdef LC_MEASUREMENT
134 # define LC_MEASUREMENT_MASK (1 << LC_MEASUREMENT)
136 # define LC_MEASUREMENT_MASK 0
138 # ifdef LC_IDENTIFICATION
139 # define LC_IDENTIFICATION_MASK (1 << LC_IDENTIFICATION)
141 # define LC_IDENTIFICATION_MASK 0
144 # define LC_ALL_MASK (LC_CTYPE_MASK \
153 | LC_TELEPHONE_MASK \
154 | LC_MEASUREMENT_MASK \
155 | LC_IDENTIFICATION_MASK \
158 /* Locale objects as returned by `make-locale' on non-GNU systems. */
159 typedef struct scm_locale
161 SCM base_locale
; /* a `locale' object */
168 /* Alias for glibc's locale type. */
169 typedef locale_t scm_t_locale
;
173 /* Validate parameter ARG as a locale object and set C_LOCALE to the
174 corresponding C locale object. */
175 #define SCM_VALIDATE_LOCALE_COPY(_pos, _arg, _c_locale) \
178 SCM_VALIDATE_SMOB ((_pos), (_arg), locale_smob_type); \
179 (_c_locale) = (scm_t_locale)SCM_SMOB_DATA (_arg); \
183 /* Validate optional parameter ARG as either undefined or bound to a locale
184 object. Set C_LOCALE to the corresponding C locale object or NULL. */
185 #define SCM_VALIDATE_OPTIONAL_LOCALE_COPY(_pos, _arg, _c_locale) \
188 if ((_arg) != SCM_UNDEFINED) \
189 SCM_VALIDATE_LOCALE_COPY (_pos, _arg, _c_locale); \
191 (_c_locale) = NULL; \
196 SCM_SMOB (scm_tc16_locale_smob_type
, "locale", 0);
198 SCM_SMOB_FREE (scm_tc16_locale_smob_type
, smob_locale_free
, locale
)
200 scm_t_locale c_locale
;
202 c_locale
= (scm_t_locale
)SCM_SMOB_DATA (locale
);
204 #ifdef USE_GNU_LOCALE_API
205 freelocale ((locale_t
)c_locale
);
207 c_locale
->base_locale
= SCM_UNDEFINED
;
208 free (c_locale
->locale_name
);
210 scm_gc_free (c_locale
, sizeof (* c_locale
), "locale");
216 #ifndef USE_GNU_LOCALE_API
218 smob_locale_mark (SCM locale
)
220 scm_t_locale c_locale
;
222 c_locale
= (scm_t_locale
)SCM_SMOB_DATA (locale
);
223 return (c_locale
->base_locale
);
228 SCM_DEFINE (scm_make_locale
, "make-locale", 2, 1, 0,
229 (SCM category_mask
, SCM locale_name
, SCM base_locale
),
230 "Return a reference to a data structure representing a set of "
231 "locale datasets. Unlike for the @var{category} parameter for "
232 "@code{setlocale}, the @var{category_mask} parameter here uses "
233 "a single bit for each category, made by OR'ing together "
234 "@code{LC_*_MASK} bits.")
235 #define FUNC_NAME s_scm_make_locale
237 SCM locale
= SCM_BOOL_F
;
240 scm_t_locale c_base_locale
, c_locale
;
242 SCM_VALIDATE_INT_COPY (1, category_mask
, c_category_mask
);
243 SCM_VALIDATE_STRING (2, locale_name
);
244 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, base_locale
, c_base_locale
);
246 c_locale_name
= scm_to_locale_string (locale_name
);
248 #ifdef USE_GNU_LOCALE_API
250 c_locale
= newlocale (c_category_mask
, c_locale_name
, c_base_locale
);
255 SCM_NEWSMOB (locale
, scm_tc16_locale_smob_type
, c_locale
);
257 free (c_locale_name
);
261 c_locale
= scm_gc_malloc (sizeof (* c_locale
), "locale");
262 c_locale
->base_locale
= base_locale
;
264 c_locale
->category_mask
= c_category_mask
;
265 c_locale
->locale_name
= c_locale_name
;
267 SCM_NEWSMOB (locale
, scm_tc16_locale_smob_type
, c_locale
);
275 SCM_DEFINE (scm_locale_p
, "locale?", 1, 0, 0,
277 "Return true if @var{obj} is a locale object.")
278 #define FUNC_NAME s_scm_locale_p
280 if (SCM_SMOB_PREDICATE (scm_tc16_locale_smob_type
, obj
))
289 #ifndef USE_GNU_LOCALE_API /* Emulate GNU's reentrant locale API. */
292 /* Maximum number of chained locales (via `base_locale'). */
293 #define LOCALE_STACK_SIZE_MAX 256
297 #define SCM_DEFINE_LOCALE_CATEGORY(_name) char * _name;
298 #include "locale-categories.h"
299 #undef SCM_DEFINE_LOCALE_CATEGORY
300 } scm_t_locale_settings
;
302 /* Fill out SETTINGS according to the current locale settings. On success
303 zero is returned and SETTINGS is properly initialized. */
305 get_current_locale_settings (scm_t_locale_settings
*settings
)
307 const char *locale_name
;
309 #define SCM_DEFINE_LOCALE_CATEGORY(_name) \
311 SCM_SYSCALL (locale_name = setlocale (LC_ ## _name, NULL)); \
315 settings-> _name = strdup (locale_name); \
316 if (settings-> _name == NULL) \
320 #include "locale-categories.h"
321 #undef SCM_DEFINE_LOCALE_CATEGORY
332 /* Restore locale settings SETTINGS. On success, return zero. */
334 restore_locale_settings (const scm_t_locale_settings
*settings
)
338 #define SCM_DEFINE_LOCALE_CATEGORY(_name) \
339 SCM_SYSCALL (result = setlocale (LC_ ## _name, settings-> _name)); \
340 if (result == NULL) \
343 #include "locale-categories.h"
344 #undef SCM_DEFINE_LOCALE_CATEGORY
352 /* Free memory associated with SETTINGS. */
354 free_locale_settings (scm_t_locale_settings
*settings
)
356 #define SCM_DEFINE_LOCALE_CATEGORY(_name) \
357 free (settings-> _name); \
358 settings->_name = NULL;
359 #include "locale-categories.h"
360 #undef SCM_DEFINE_LOCALE_CATEGORY
363 /* Install the locale named LOCALE_NAME for all the categories listed in
366 install_locale_categories (const char *locale_name
, int category_mask
)
370 if (category_mask
== LC_ALL_MASK
)
372 SCM_SYSCALL (result
= setlocale (LC_ALL
, locale_name
));
378 #define SCM_DEFINE_LOCALE_CATEGORY(_name) \
379 if (category_mask & LC_ ## _name ## _MASK) \
381 SCM_SYSCALL (result = setlocale (LC_ ## _name, locale_name)); \
382 if (result == NULL) \
385 #include "locale-categories.h"
386 #undef SCM_DEFINE_LOCALE_CATEGORY
395 /* Install LOCALE, recursively installing its base locales first. On
396 success, zero is returned. */
398 install_locale (scm_t_locale locale
)
400 scm_t_locale stack
[LOCALE_STACK_SIZE_MAX
];
401 size_t stack_size
= 0;
402 int stack_offset
= 0;
403 const char *result
= NULL
;
405 /* Build up a locale stack by traversing the `base_locale' link. */
408 if (stack_size
>= LOCALE_STACK_SIZE_MAX
)
409 /* We cannot use `scm_error ()' here because otherwise the locale
410 mutex may remain locked. */
413 stack
[stack_size
++] = locale
;
415 if (locale
->base_locale
!= SCM_UNDEFINED
)
416 locale
= (scm_t_locale
)SCM_SMOB_DATA (locale
->base_locale
);
420 while (locale
!= NULL
);
422 /* Install the C locale to start from a pristine state. */
423 SCM_SYSCALL (result
= setlocale (LC_ALL
, "C"));
427 /* Install the locales in reverse order. */
428 for (stack_offset
= stack_size
- 1;
435 locale
= stack
[stack_offset
];
436 err
= install_locale_categories (locale
->locale_name
,
437 locale
->category_mask
);
448 /* Leave the locked locale section. */
450 leave_locale_section (const scm_t_locale_settings
*settings
)
452 /* Restore the previous locale settings. */
453 (void)restore_locale_settings (settings
);
455 scm_i_pthread_mutex_unlock (&scm_i_locale_mutex
);
458 /* Enter a locked locale section. */
460 enter_locale_section (scm_t_locale locale
,
461 scm_t_locale_settings
*prev_locale
)
465 scm_i_pthread_mutex_lock (&scm_i_locale_mutex
);
467 err
= get_current_locale_settings (prev_locale
);
470 scm_i_pthread_mutex_unlock (&scm_i_locale_mutex
);
474 err
= install_locale (locale
);
477 leave_locale_section (prev_locale
);
478 free_locale_settings (prev_locale
);
484 /* Throw an exception corresponding to error ERR. */
486 scm_locale_error (const char *func_name
, int err
)
490 s_err
= scm_from_int (err
);
491 scm_error (scm_system_error_key
, func_name
,
492 "Failed to install locale",
493 scm_cons (scm_strerror (s_err
), SCM_EOL
),
494 scm_cons (s_err
, SCM_EOL
));
497 /* Convenient macro to run STATEMENT in the locale context of C_LOCALE. */
498 #define RUN_IN_LOCALE_SECTION(_c_locale, _statement) \
502 scm_t_locale_settings lsec_prev_locale; \
504 lsec_err = enter_locale_section ((_c_locale), &lsec_prev_locale); \
506 scm_locale_error (FUNC_NAME, lsec_err); \
511 leave_locale_section (&lsec_prev_locale); \
512 free_locale_settings (&lsec_prev_locale); \
517 #endif /* !USE_GNU_LOCALE_API */
520 /* Locale-dependent string comparison. */
522 /* Compare null-terminated strings C_S1 and C_S2 according to LOCALE. Return
523 an integer whose sign is the same as the difference between C_S1 and
526 compare_strings (const char *c_s1
, const char *c_s2
, SCM locale
,
527 const char *func_name
)
528 #define FUNC_NAME func_name
531 scm_t_locale c_locale
;
533 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale
, c_locale
);
537 #ifdef USE_GNU_LOCALE_API
538 result
= strcoll_l (c_s1
, c_s2
, c_locale
);
541 RUN_IN_LOCALE_SECTION (c_locale
, result
= strcoll (c_s1
, c_s2
));
543 result
= strcmp (c_s1
, c_s2
);
545 #endif /* !USE_GNU_LOCALE_API */
550 result
= strcoll (c_s1
, c_s2
);
552 result
= strcmp (c_s1
, c_s2
);
559 /* Store into DST an upper-case version of SRC. */
561 str_upcase (register char *dst
, register const char *src
)
563 for (; *src
!= '\0'; src
++, dst
++)
564 *dst
= toupper (*src
);
569 str_downcase (register char *dst
, register const char *src
)
571 for (; *src
!= '\0'; src
++, dst
++)
572 *dst
= tolower (*src
);
576 #ifdef USE_GNU_LOCALE_API
578 str_upcase_l (register char *dst
, register const char *src
,
581 for (; *src
!= '\0'; src
++, dst
++)
582 *dst
= toupper_l (*src
, locale
);
587 str_downcase_l (register char *dst
, register const char *src
,
590 for (; *src
!= '\0'; src
++, dst
++)
591 *dst
= tolower_l (*src
, locale
);
597 /* Compare null-terminated strings C_S1 and C_S2 in a case-independent way
598 according to LOCALE. Return an integer whose sign is the same as the
599 difference between C_S1 and C_S2. */
601 compare_strings_ci (const char *c_s1
, const char *c_s2
, SCM locale
,
602 const char *func_name
)
603 #define FUNC_NAME func_name
606 scm_t_locale c_locale
;
609 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale
, c_locale
);
611 c_us1
= (char *) alloca (strlen (c_s1
) + 1);
612 c_us2
= (char *) alloca (strlen (c_s2
) + 1);
616 #ifdef USE_GNU_LOCALE_API
617 str_upcase_l (c_us1
, c_s1
, c_locale
);
618 str_upcase_l (c_us2
, c_s2
, c_locale
);
620 result
= strcoll_l (c_us1
, c_us2
, c_locale
);
623 scm_t_locale_settings prev_locale
;
625 err
= enter_locale_section (c_locale
, &prev_locale
);
628 scm_locale_error (func_name
, err
);
632 str_upcase (c_us1
, c_s1
);
633 str_upcase (c_us2
, c_s2
);
636 result
= strcoll (c_us1
, c_us2
);
638 result
= strcmp (c_us1
, c_us2
);
639 #endif /* !HAVE_STRCOLL */
641 leave_locale_section (&prev_locale
);
642 free_locale_settings (&prev_locale
);
643 #endif /* !USE_GNU_LOCALE_API */
647 str_upcase (c_us1
, c_s1
);
648 str_upcase (c_us2
, c_s2
);
651 result
= strcoll (c_us1
, c_us2
);
653 result
= strcmp (c_us1
, c_us2
);
662 SCM_DEFINE (scm_string_locale_lt
, "string-locale<?", 2, 1, 0,
663 (SCM s1
, SCM s2
, SCM locale
),
664 "Compare strings @var{s1} and @var{s2} in a locale-dependent way."
665 "If @var{locale} is provided, it should be locale object (as "
666 "returned by @code{make-locale}) and will be used to perform the "
667 "comparison; otherwise, the current system locale is used.")
668 #define FUNC_NAME s_scm_string_locale_lt
671 const char *c_s1
, *c_s2
;
673 SCM_VALIDATE_STRING (1, s1
);
674 SCM_VALIDATE_STRING (2, s2
);
676 c_s1
= scm_i_string_chars (s1
);
677 c_s2
= scm_i_string_chars (s2
);
679 result
= compare_strings (c_s1
, c_s2
, locale
, FUNC_NAME
);
681 scm_remember_upto_here_2 (s1
, s2
);
683 return scm_from_bool (result
< 0);
687 SCM_DEFINE (scm_string_locale_gt
, "string-locale>?", 2, 1, 0,
688 (SCM s1
, SCM s2
, SCM locale
),
689 "Compare strings @var{s1} and @var{s2} in a locale-dependent way."
690 "If @var{locale} is provided, it should be locale object (as "
691 "returned by @code{make-locale}) and will be used to perform the "
692 "comparison; otherwise, the current system locale is used.")
693 #define FUNC_NAME s_scm_string_locale_gt
696 const char *c_s1
, *c_s2
;
698 SCM_VALIDATE_STRING (1, s1
);
699 SCM_VALIDATE_STRING (2, s2
);
701 c_s1
= scm_i_string_chars (s1
);
702 c_s2
= scm_i_string_chars (s2
);
704 result
= compare_strings (c_s1
, c_s2
, locale
, FUNC_NAME
);
706 scm_remember_upto_here_2 (s1
, s2
);
708 return scm_from_bool (result
> 0);
712 SCM_DEFINE (scm_string_locale_ci_lt
, "string-locale-ci<?", 2, 1, 0,
713 (SCM s1
, SCM s2
, SCM locale
),
714 "Compare strings @var{s1} and @var{s2} in a case-insensitive, "
715 "and locale-dependent way. If @var{locale} is provided, it "
716 "should be locale object (as returned by @code{make-locale}) "
717 "and will be used to perform the comparison; otherwise, the "
718 "current system locale is used.")
719 #define FUNC_NAME s_scm_string_locale_ci_lt
722 const char *c_s1
, *c_s2
;
724 SCM_VALIDATE_STRING (1, s1
);
725 SCM_VALIDATE_STRING (2, s2
);
727 c_s1
= scm_i_string_chars (s1
);
728 c_s2
= scm_i_string_chars (s2
);
730 result
= compare_strings_ci (c_s1
, c_s2
, locale
, FUNC_NAME
);
732 scm_remember_upto_here_2 (s1
, s2
);
734 return scm_from_bool (result
< 0);
738 SCM_DEFINE (scm_string_locale_ci_gt
, "string-locale-ci>?", 2, 1, 0,
739 (SCM s1
, SCM s2
, SCM locale
),
740 "Compare strings @var{s1} and @var{s2} in a case-insensitive, "
741 "and locale-dependent way. If @var{locale} is provided, it "
742 "should be locale object (as returned by @code{make-locale}) "
743 "and will be used to perform the comparison; otherwise, the "
744 "current system locale is used.")
745 #define FUNC_NAME s_scm_string_locale_ci_gt
748 const char *c_s1
, *c_s2
;
750 SCM_VALIDATE_STRING (1, s1
);
751 SCM_VALIDATE_STRING (2, s2
);
753 c_s1
= scm_i_string_chars (s1
);
754 c_s2
= scm_i_string_chars (s2
);
756 result
= compare_strings_ci (c_s1
, c_s2
, locale
, FUNC_NAME
);
758 scm_remember_upto_here_2 (s1
, s2
);
760 return scm_from_bool (result
> 0);
764 SCM_DEFINE (scm_string_locale_ci_eq
, "string-locale-ci=?", 2, 1, 0,
765 (SCM s1
, SCM s2
, SCM locale
),
766 "Compare strings @var{s1} and @var{s2} in a case-insensitive, "
767 "and locale-dependent way. If @var{locale} is provided, it "
768 "should be locale object (as returned by @code{make-locale}) "
769 "and will be used to perform the comparison; otherwise, the "
770 "current system locale is used.")
771 #define FUNC_NAME s_scm_string_locale_ci_eq
774 const char *c_s1
, *c_s2
;
776 SCM_VALIDATE_STRING (1, s1
);
777 SCM_VALIDATE_STRING (2, s2
);
779 c_s1
= scm_i_string_chars (s1
);
780 c_s2
= scm_i_string_chars (s2
);
782 result
= compare_strings_ci (c_s1
, c_s2
, locale
, FUNC_NAME
);
784 scm_remember_upto_here_2 (s1
, s2
);
786 return scm_from_bool (result
== 0);
791 SCM_DEFINE (scm_char_locale_lt
, "char-locale<?", 2, 1, 0,
792 (SCM c1
, SCM c2
, SCM locale
),
793 "Return true if character @var{c1} is lower than @var{c2} "
794 "according to @var{locale} or to the current locale.")
795 #define FUNC_NAME s_scm_char_locale_lt
797 char c_c1
[2], c_c2
[2];
799 SCM_VALIDATE_CHAR (1, c1
);
800 SCM_VALIDATE_CHAR (2, c2
);
802 c_c1
[0] = (char)SCM_CHAR (c1
); c_c1
[1] = '\0';
803 c_c2
[0] = (char)SCM_CHAR (c2
); c_c2
[1] = '\0';
805 return scm_from_bool (compare_strings (c_c1
, c_c2
, locale
, FUNC_NAME
) < 0);
809 SCM_DEFINE (scm_char_locale_gt
, "char-locale>?", 2, 1, 0,
810 (SCM c1
, SCM c2
, SCM locale
),
811 "Return true if character @var{c1} is greater than @var{c2} "
812 "according to @var{locale} or to the current locale.")
813 #define FUNC_NAME s_scm_char_locale_gt
815 char c_c1
[2], c_c2
[2];
817 SCM_VALIDATE_CHAR (1, c1
);
818 SCM_VALIDATE_CHAR (2, c2
);
820 c_c1
[0] = (char)SCM_CHAR (c1
); c_c1
[1] = '\0';
821 c_c2
[0] = (char)SCM_CHAR (c2
); c_c2
[1] = '\0';
823 return scm_from_bool (compare_strings (c_c1
, c_c2
, locale
, FUNC_NAME
) > 0);
827 SCM_DEFINE (scm_char_locale_ci_lt
, "char-locale-ci<?", 2, 1, 0,
828 (SCM c1
, SCM c2
, SCM locale
),
829 "Return true if character @var{c1} is lower than @var{c2}, "
830 "in a case insensitive way according to @var{locale} or to "
831 "the current locale.")
832 #define FUNC_NAME s_scm_char_locale_ci_lt
835 char c_c1
[2], c_c2
[2];
837 SCM_VALIDATE_CHAR (1, c1
);
838 SCM_VALIDATE_CHAR (2, c2
);
840 c_c1
[0] = (char)SCM_CHAR (c1
); c_c1
[1] = '\0';
841 c_c2
[0] = (char)SCM_CHAR (c2
); c_c2
[1] = '\0';
843 result
= compare_strings_ci (c_c1
, c_c2
, locale
, FUNC_NAME
);
845 return scm_from_bool (result
< 0);
849 SCM_DEFINE (scm_char_locale_ci_gt
, "char-locale-ci>?", 2, 1, 0,
850 (SCM c1
, SCM c2
, SCM locale
),
851 "Return true if character @var{c1} is greater than @var{c2}, "
852 "in a case insensitive way according to @var{locale} or to "
853 "the current locale.")
854 #define FUNC_NAME s_scm_char_locale_ci_gt
857 char c_c1
[2], c_c2
[2];
859 SCM_VALIDATE_CHAR (1, c1
);
860 SCM_VALIDATE_CHAR (2, c2
);
862 c_c1
[0] = (char)SCM_CHAR (c1
); c_c1
[1] = '\0';
863 c_c2
[0] = (char)SCM_CHAR (c2
); c_c2
[1] = '\0';
865 result
= compare_strings_ci (c_c1
, c_c2
, locale
, FUNC_NAME
);
867 return scm_from_bool (result
> 0);
871 SCM_DEFINE (scm_char_locale_ci_eq
, "char-locale-ci=?", 2, 1, 0,
872 (SCM c1
, SCM c2
, SCM locale
),
873 "Return true if character @var{c1} is equal to @var{c2}, "
874 "in a case insensitive way according to @var{locale} or to "
875 "the current locale.")
876 #define FUNC_NAME s_scm_char_locale_ci_eq
879 char c_c1
[2], c_c2
[2];
881 SCM_VALIDATE_CHAR (1, c1
);
882 SCM_VALIDATE_CHAR (2, c2
);
884 c_c1
[0] = (char)SCM_CHAR (c1
); c_c1
[1] = '\0';
885 c_c2
[0] = (char)SCM_CHAR (c2
); c_c2
[1] = '\0';
887 result
= compare_strings_ci (c_c1
, c_c2
, locale
, FUNC_NAME
);
889 return scm_from_bool (result
== 0);
895 /* Locale-dependent alphabetic character mapping. */
897 SCM_DEFINE (scm_char_locale_downcase
, "char-locale-downcase", 1, 1, 0,
898 (SCM chr
, SCM locale
),
899 "Return the lowercase character that corresponds to @var{chr} "
900 "according to either @var{locale} or the current locale.")
901 #define FUNC_NAME s_scm_char_locale_downcase
905 scm_t_locale c_locale
;
907 SCM_VALIDATE_CHAR (1, chr
);
908 c_chr
= SCM_CHAR (chr
);
910 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale
, c_locale
);
912 if (c_locale
!= NULL
)
914 #ifdef USE_GNU_LOCALE_API
915 c_result
= tolower_l (c_chr
, c_locale
);
917 RUN_IN_LOCALE_SECTION (c_locale
, c_result
= tolower (c_chr
));
921 c_result
= tolower (c_chr
);
923 return (SCM_MAKE_CHAR (c_result
));
927 SCM_DEFINE (scm_char_locale_upcase
, "char-locale-upcase", 1, 1, 0,
928 (SCM chr
, SCM locale
),
929 "Return the uppercase character that corresponds to @var{chr} "
930 "according to either @var{locale} or the current locale.")
931 #define FUNC_NAME s_scm_char_locale_upcase
935 scm_t_locale c_locale
;
937 SCM_VALIDATE_CHAR (1, chr
);
938 c_chr
= SCM_CHAR (chr
);
940 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale
, c_locale
);
942 if (c_locale
!= NULL
)
944 #ifdef USE_GNU_LOCALE_API
945 c_result
= toupper_l (c_chr
, c_locale
);
947 RUN_IN_LOCALE_SECTION (c_locale
, c_result
= toupper (c_chr
));
951 c_result
= toupper (c_chr
);
953 return (SCM_MAKE_CHAR (c_result
));
957 SCM_DEFINE (scm_string_locale_upcase
, "string-locale-upcase", 1, 1, 0,
958 (SCM str
, SCM locale
),
959 "Return a new string that is the uppercase version of "
960 "@var{str} according to either @var{locale} or the current "
962 #define FUNC_NAME s_scm_string_locale_upcase
966 scm_t_locale c_locale
;
968 SCM_VALIDATE_STRING (1, str
);
969 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale
, c_locale
);
971 c_str
= scm_i_string_chars (str
);
972 c_ustr
= (char *) alloca (strlen (c_str
) + 1);
976 #ifdef USE_GNU_LOCALE_API
977 str_upcase_l (c_ustr
, c_str
, c_locale
);
979 RUN_IN_LOCALE_SECTION (c_locale
, str_upcase (c_ustr
, c_str
));
983 str_upcase (c_ustr
, c_str
);
985 scm_remember_upto_here (str
);
987 return (scm_from_locale_string (c_ustr
));
991 SCM_DEFINE (scm_string_locale_downcase
, "string-locale-downcase", 1, 1, 0,
992 (SCM str
, SCM locale
),
993 "Return a new string that is the down-case version of "
994 "@var{str} according to either @var{locale} or the current "
996 #define FUNC_NAME s_scm_string_locale_downcase
1000 scm_t_locale c_locale
;
1002 SCM_VALIDATE_STRING (1, str
);
1003 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale
, c_locale
);
1005 c_str
= scm_i_string_chars (str
);
1006 c_lstr
= (char *) alloca (strlen (c_str
) + 1);
1010 #ifdef USE_GNU_LOCALE_API
1011 str_downcase_l (c_lstr
, c_str
, c_locale
);
1013 RUN_IN_LOCALE_SECTION (c_locale
, str_downcase (c_lstr
, c_str
));
1017 str_downcase (c_lstr
, c_str
);
1019 scm_remember_upto_here (str
);
1021 return (scm_from_locale_string (c_lstr
));
1025 /* Note: We don't provide mutative versions of `string-locale-(up|down)case'
1026 because, in some languages, a single downcase character maps to a couple
1027 of uppercase characters. Read the SRFI-13 document for a detailed
1028 discussion about this. */
1032 /* Locale-dependent number parsing. */
1034 SCM_DEFINE (scm_locale_string_to_integer
, "locale-string->integer",
1035 1, 2, 0, (SCM str
, SCM base
, SCM locale
),
1036 "Convert string @var{str} into an integer according to either "
1037 "@var{locale} (a locale object as returned by @code{make-locale}) "
1038 "or the current process locale. Return two values: an integer "
1039 "(on success) or @code{#f}, and the number of characters read "
1040 "from @var{str} (@code{0} on failure).")
1041 #define FUNC_NAME s_scm_locale_string_to_integer
1048 scm_t_locale c_locale
;
1050 SCM_VALIDATE_STRING (1, str
);
1051 c_str
= scm_i_string_chars (str
);
1053 if (base
!= SCM_UNDEFINED
)
1054 SCM_VALIDATE_INT_COPY (2, base
, c_base
);
1058 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale
, c_locale
);
1060 if (c_locale
!= NULL
)
1062 #ifdef USE_GNU_LOCALE_API
1063 c_result
= strtol_l (c_str
, &c_endptr
, c_base
, c_locale
);
1065 RUN_IN_LOCALE_SECTION (c_locale
,
1066 c_result
= strtol (c_str
, &c_endptr
, c_base
));
1070 c_result
= strtol (c_str
, &c_endptr
, c_base
);
1072 scm_remember_upto_here (str
);
1074 if (c_endptr
== c_str
)
1075 result
= SCM_BOOL_F
;
1077 result
= scm_from_long (c_result
);
1079 return (scm_values (scm_list_2 (result
, scm_from_long (c_endptr
- c_str
))));
1083 SCM_DEFINE (scm_locale_string_to_inexact
, "locale-string->inexact",
1084 1, 1, 0, (SCM str
, SCM locale
),
1085 "Convert string @var{str} into an inexact number according to "
1086 "either @var{locale} (a locale object as returned by "
1087 "@code{make-locale}) or the current process locale. Return "
1088 "two values: an inexact number (on success) or @code{#f}, and "
1089 "the number of characters read from @var{str} (@code{0} on "
1091 #define FUNC_NAME s_scm_locale_string_to_inexact
1097 scm_t_locale c_locale
;
1099 SCM_VALIDATE_STRING (1, str
);
1100 c_str
= scm_i_string_chars (str
);
1102 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale
, c_locale
);
1104 if (c_locale
!= NULL
)
1106 #ifdef USE_GNU_LOCALE_API
1107 c_result
= strtod_l (c_str
, &c_endptr
, c_locale
);
1109 RUN_IN_LOCALE_SECTION (c_locale
,
1110 c_result
= strtod (c_str
, &c_endptr
));
1114 c_result
= strtod (c_str
, &c_endptr
);
1116 scm_remember_upto_here (str
);
1118 if (c_endptr
== c_str
)
1119 result
= SCM_BOOL_F
;
1121 result
= scm_from_double (c_result
);
1123 return (scm_values (scm_list_2 (result
, scm_from_long (c_endptr
- c_str
))));
1132 scm_add_feature ("ice-9-i18n");
1134 #define _SCM_STRINGIFY_LC(_name) # _name
1135 #define SCM_STRINGIFY_LC(_name) _SCM_STRINGIFY_LC (_name)
1137 /* Define all the relevant `_MASK' variables. */
1138 #define SCM_DEFINE_LOCALE_CATEGORY(_name) \
1139 scm_c_define ("LC_" SCM_STRINGIFY_LC (_name) "_MASK", \
1140 SCM_I_MAKINUM (LC_ ## _name ## _MASK));
1141 #include "locale-categories.h"
1143 #undef SCM_DEFINE_LOCALE_CATEGORY
1144 #undef SCM_STRINGIFY_LC
1145 #undef _SCM_STRINGIFY_LC
1147 scm_c_define ("LC_ALL_MASK", SCM_I_MAKINUM (LC_ALL_MASK
));
1149 #include "libguile/i18n.x"
1151 #ifndef USE_GNU_LOCALE_API
1152 scm_set_smob_mark (scm_tc16_locale_smob_type
, smob_locale_mark
);