HCoop / bpt / guile.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
Fix stylistic issues revealed by "make syntax-check".
[bpt/guile.git] / libguile / i18n.c
1 /* Copyright (C) 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
2 *
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.
7 *
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.
12 *
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
16 * 02110-1301 USA
17 */
18
19 #ifdef HAVE_CONFIG_H
20 # include <config.h>
21 #endif
22
23 #include <alloca.h>
24
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"
35
36 #include <locale.h>
37 #include <string.h> /* `strcoll ()' */
38 #include <ctype.h> /* `toupper ()' et al. */
39 #include <errno.h>
40 #include <unicase.h>
41 #include <unistr.h>
42
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:
46
47 http://people.redhat.com/drepper/tllocale.ps.gz
48
49 It is now also implemented by Darwin:
50
51 http://developer.apple.com/documentation/Darwin/Reference/ManPages/man3/newlocale.3.html
52
53 The whole API was eventually standardized in the ``Open Group Base
54 Specifications Issue 7'' (aka. "POSIX 2008"):
55
56 http://www.opengroup.org/onlinepubs/9699919799/basedefs/locale.h.html */
57 # define USE_GNU_LOCALE_API
58 #endif
59
60 #if (defined USE_GNU_LOCALE_API) && (defined HAVE_XLOCALE_H)
61 # include <xlocale.h>
62 #endif
63
64 #include "libguile/posix.h" /* for `scm_i_locale_mutex' */
65
66 #if (defined HAVE_LANGINFO_H) && (defined HAVE_NL_TYPES_H)
67 # include <langinfo.h>
68 # include <nl_types.h>
69 #endif
70
71 #ifndef HAVE_SETLOCALE
72 static inline char *
73 setlocale (int category, const char *name)
74 {
75 errno = ENOSYS;
76 return NULL;
77 }
78 #endif
79
80 /* Helper stringification macro. */
81 #define SCM_I18N_STRINGIFY(_name) # _name
82
83
84 \f
85 /* Locale objects, string and character collation, and other locale-dependent
86 string operations.
87
88 A large part of the code here deals with emulating glibc's reentrant
89 locale API on non-GNU systems. The emulation is a bit "brute-force":
90 Whenever a `-locale<?' procedure is passed a locale object, then:
91
92 1. The `scm_i_locale_mutex' is locked.
93 2. A series of `setlocale ()' call is performed to store the current
94 locale for each category in an `scm_t_locale' object.
95 3. A series of `setlocale ()' call is made to install each of the locale
96 categories of each of the base locales of each locale object,
97 recursively, starting from the last locale object of the chain.
98 4. The settings captured in step (2) are restored.
99 5. The `scm_i_locale_mutex' is released.
100
101 Hopefully, the X/Open standard will eventually make this hack useless.
102
103 Note: We don't wrap glibc's `uselocale ()' call because it sets the locale
104 of the current _thread_ (unlike `setlocale ()') and doing so would require
105 maintaining per-thread locale information on non-GNU systems and always
106 re-installing this locale upon locale-dependent calls. */
107
108
109 /* Return the category mask corresponding to CAT. */
110 #define SCM_LOCALE_CATEGORY_MASK(_cat) LC_ ## _cat ## _MASK
111
112
113 #ifndef USE_GNU_LOCALE_API
114
115 /* Provide the locale category masks as found in glibc. This must be kept in
116 sync with `locale-categories.h'. */
117
118 # define LC_CTYPE_MASK 1
119 # define LC_COLLATE_MASK 2
120 # define LC_MESSAGES_MASK 4
121 # define LC_MONETARY_MASK 8
122 # define LC_NUMERIC_MASK 16
123 # define LC_TIME_MASK 32
124
125 # ifdef LC_PAPER
126 # define LC_PAPER_MASK 64
127 # else
128 # define LC_PAPER_MASK 0
129 # endif
130 # ifdef LC_NAME
131 # define LC_NAME_MASK 128
132 # else
133 # define LC_NAME_MASK 0
134 # endif
135 # ifdef LC_ADDRESS
136 # define LC_ADDRESS_MASK 256
137 # else
138 # define LC_ADDRESS_MASK 0
139 # endif
140 # ifdef LC_TELEPHONE
141 # define LC_TELEPHONE_MASK 512
142 # else
143 # define LC_TELEPHONE_MASK 0
144 # endif
145 # ifdef LC_MEASUREMENT
146 # define LC_MEASUREMENT_MASK 1024
147 # else
148 # define LC_MEASUREMENT_MASK 0
149 # endif
150 # ifdef LC_IDENTIFICATION
151 # define LC_IDENTIFICATION_MASK 2048
152 # else
153 # define LC_IDENTIFICATION_MASK 0
154 # endif
155
156 # define LC_ALL_MASK (LC_CTYPE_MASK \
157 | LC_NUMERIC_MASK \
158 | LC_TIME_MASK \
159 | LC_COLLATE_MASK \
160 | LC_MONETARY_MASK \
161 | LC_MESSAGES_MASK \
162 | LC_PAPER_MASK \
163 | LC_NAME_MASK \
164 | LC_ADDRESS_MASK \
165 | LC_TELEPHONE_MASK \
166 | LC_MEASUREMENT_MASK \
167 | LC_IDENTIFICATION_MASK \
168 )
169
170 /* Locale objects as returned by `make-locale' on non-GNU systems. */
171 typedef struct scm_locale
172 {
173 SCM base_locale; /* a `locale' object */
174 char *locale_name;
175 int category_mask;
176 } *scm_t_locale;
177
178
179 /* Free the resources used by LOCALE. */
180 static inline void
181 scm_i_locale_free (scm_t_locale locale)
182 {
183 free (locale->locale_name);
184 locale->locale_name = NULL;
185 }
186
187 #else /* USE_GNU_LOCALE_API */
188
189 /* Alias for glibc's locale type. */
190 typedef locale_t scm_t_locale;
191
192 #define scm_i_locale_free freelocale
193
194 #endif /* USE_GNU_LOCALE_API */
195
196
197 /* A locale object denoting the global locale. */
198 SCM_GLOBAL_VARIABLE (scm_global_locale, "%global-locale");
199
200
201 /* Validate parameter ARG as a locale object and set C_LOCALE to the
202 corresponding C locale object. */
203 #define SCM_VALIDATE_LOCALE_COPY(_pos, _arg, _c_locale) \
204 do \
205 { \
206 SCM_VALIDATE_SMOB ((_pos), (_arg), locale_smob_type); \
207 (_c_locale) = (scm_t_locale)SCM_SMOB_DATA (_arg); \
208 } \
209 while (0)
210
211 /* Validate optional parameter ARG as either undefined or bound to a locale
212 object. Set C_LOCALE to the corresponding C locale object or NULL. */
213 #define SCM_VALIDATE_OPTIONAL_LOCALE_COPY(_pos, _arg, _c_locale) \
214 do \
215 { \
216 if ((_arg) != SCM_UNDEFINED) \
217 SCM_VALIDATE_LOCALE_COPY (_pos, _arg, _c_locale); \
218 else \
219 (_c_locale) = NULL; \
220 } \
221 while (0)
222
223
224 SCM_SMOB (scm_tc16_locale_smob_type, "locale", 0);
225
226 SCM_SMOB_FREE (scm_tc16_locale_smob_type, smob_locale_free, locale)
227 {
228 scm_t_locale c_locale;
229
230 c_locale = (scm_t_locale) SCM_SMOB_DATA (locale);
231 scm_i_locale_free (c_locale);
232
233 return 0;
234 }
235
236
237 static void inline scm_locale_error (const char *, int) SCM_NORETURN;
238
239 /* Throw an exception corresponding to error ERR. */
240 static void inline
241 scm_locale_error (const char *func_name, int err)
242 {
243 scm_syserror_msg (func_name,
244 "Failed to install locale",
245 SCM_EOL, err);
246 }
247
248
249 \f
250 /* Emulating GNU's reentrant locale API. */
251 #ifndef USE_GNU_LOCALE_API
252
253
254 /* Maximum number of chained locales (via `base_locale'). */
255 #define LOCALE_STACK_SIZE_MAX 256
256
257 typedef struct
258 {
259 #define SCM_DEFINE_LOCALE_CATEGORY(_name) char * _name;
260 #include "locale-categories.h"
261 #undef SCM_DEFINE_LOCALE_CATEGORY
262 } scm_t_locale_settings;
263
264 /* Fill out SETTINGS according to the current locale settings. On success
265 zero is returned and SETTINGS is properly initialized. */
266 static int
267 get_current_locale_settings (scm_t_locale_settings *settings)
268 {
269 const char *locale_name;
270
271 #define SCM_DEFINE_LOCALE_CATEGORY(_name) \
272 { \
273 SCM_SYSCALL (locale_name = setlocale (LC_ ## _name, NULL)); \
274 if (locale_name == NULL) \
275 goto handle_error; \
276 \
277 settings-> _name = strdup (locale_name); \
278 if (settings-> _name == NULL) \
279 goto handle_oom; \
280 }
281
282 #include "locale-categories.h"
283 #undef SCM_DEFINE_LOCALE_CATEGORY
284
285 return 0;
286
287 handle_error:
288 return EINVAL;
289
290 handle_oom:
291 return ENOMEM;
292 }
293
294 /* Restore locale settings SETTINGS. On success, return zero. */
295 static int
296 restore_locale_settings (const scm_t_locale_settings *settings)
297 {
298 const char *result;
299
300 #define SCM_DEFINE_LOCALE_CATEGORY(_name) \
301 SCM_SYSCALL (result = setlocale (LC_ ## _name, settings-> _name)); \
302 if (result == NULL) \
303 goto handle_error;
304
305 #include "locale-categories.h"
306 #undef SCM_DEFINE_LOCALE_CATEGORY
307
308 return 0;
309
310 handle_error:
311 return EINVAL;
312 }
313
314 /* Free memory associated with SETTINGS. */
315 static void
316 free_locale_settings (scm_t_locale_settings *settings)
317 {
318 #define SCM_DEFINE_LOCALE_CATEGORY(_name) \
319 free (settings-> _name); \
320 settings->_name = NULL;
321 #include "locale-categories.h"
322 #undef SCM_DEFINE_LOCALE_CATEGORY
323 }
324
325 /* Install the locale named LOCALE_NAME for all the categories listed in
326 CATEGORY_MASK. */
327 static int
328 install_locale_categories (const char *locale_name, int category_mask)
329 {
330 const char *result;
331
332 if (category_mask == LC_ALL_MASK)
333 {
334 SCM_SYSCALL (result = setlocale (LC_ALL, locale_name));
335 if (result == NULL)
336 goto handle_error;
337 }
338 else
339 {
340 #define SCM_DEFINE_LOCALE_CATEGORY(_name) \
341 if (category_mask & SCM_LOCALE_CATEGORY_MASK (_name)) \
342 { \
343 SCM_SYSCALL (result = setlocale (LC_ ## _name, locale_name)); \
344 if (result == NULL) \
345 goto handle_error; \
346 }
347 #include "locale-categories.h"
348 #undef SCM_DEFINE_LOCALE_CATEGORY
349 }
350
351 return 0;
352
353 handle_error:
354 return EINVAL;
355 }
356
357 /* Install LOCALE, recursively installing its base locales first. On
358 success, zero is returned. */
359 static int
360 install_locale (scm_t_locale locale)
361 {
362 scm_t_locale stack[LOCALE_STACK_SIZE_MAX];
363 int category_mask = 0;
364 size_t stack_size = 0;
365 int stack_offset = 0;
366 const char *result = NULL;
367
368 /* Build up a locale stack by traversing the `base_locale' link. */
369 do
370 {
371 if (stack_size >= LOCALE_STACK_SIZE_MAX)
372 /* We cannot use `scm_error ()' here because otherwise the locale
373 mutex may remain locked. */
374 return EINVAL;
375
376 stack[stack_size++] = locale;
377
378 /* Keep track of which categories have already been taken into
379 account. */
380 category_mask |= locale->category_mask;
381
382 if (locale->base_locale != SCM_UNDEFINED)
383 locale = (scm_t_locale) SCM_SMOB_DATA (locale->base_locale);
384 else
385 locale = NULL;
386 }
387 while ((locale != NULL) && (category_mask != LC_ALL_MASK));
388
389 /* Install the C locale to start from a pristine state. */
390 SCM_SYSCALL (result = setlocale (LC_ALL, "C"));
391 if (result == NULL)
392 goto handle_error;
393
394 /* Install the locales in reverse order. */
395 for (stack_offset = stack_size - 1;
396 stack_offset >= 0;
397 stack_offset--)
398 {
399 int err;
400 scm_t_locale locale;
401
402 locale = stack[stack_offset];
403 err = install_locale_categories (locale->locale_name,
404 locale->category_mask);
405 if (err)
406 goto handle_error;
407 }
408
409 return 0;
410
411 handle_error:
412 return EINVAL;
413 }
414
415 /* Leave the locked locale section. */
416 static inline void
417 leave_locale_section (const scm_t_locale_settings *settings)
418 {
419 /* Restore the previous locale settings. */
420 (void)restore_locale_settings (settings);
421
422 scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
423 }
424
425 /* Enter a locked locale section. */
426 static inline int
427 enter_locale_section (scm_t_locale locale,
428 scm_t_locale_settings *prev_locale)
429 {
430 int err;
431
432 scm_i_pthread_mutex_lock (&scm_i_locale_mutex);
433
434 err = get_current_locale_settings (prev_locale);
435 if (err)
436 {
437 scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
438 return err;
439 }
440
441 err = install_locale (locale);
442 if (err)
443 {
444 leave_locale_section (prev_locale);
445 free_locale_settings (prev_locale);
446 }
447
448 return err;
449 }
450
451 /* Convenient macro to run STATEMENT in the locale context of C_LOCALE. */
452 #define RUN_IN_LOCALE_SECTION(_c_locale, _statement) \
453 do \
454 { \
455 int lsec_err; \
456 scm_t_locale_settings lsec_prev_locale; \
457 \
458 lsec_err = enter_locale_section ((_c_locale), &lsec_prev_locale); \
459 if (lsec_err) \
460 scm_locale_error (FUNC_NAME, lsec_err); \
461 else \
462 { \
463 _statement ; \
464 \
465 leave_locale_section (&lsec_prev_locale); \
466 free_locale_settings (&lsec_prev_locale); \
467 } \
468 } \
469 while (0)
470
471 /* Convert the current locale settings into a locale SMOB. On success, zero
472 is returned and RESULT points to the new SMOB. Otherwise, an error is
473 returned. */
474 static int
475 get_current_locale (SCM *result)
476 {
477 int err = 0;
478 scm_t_locale c_locale;
479 const char *current_locale;
480
481 c_locale = scm_gc_malloc (sizeof (* c_locale), "locale");
482
483
484 scm_i_pthread_mutex_lock (&scm_i_locale_mutex);
485
486 c_locale->category_mask = LC_ALL_MASK;
487 c_locale->base_locale = SCM_UNDEFINED;
488
489 current_locale = setlocale (LC_ALL, NULL);
490 if (current_locale != NULL)
491 {
492 c_locale->locale_name = strdup (current_locale);
493 if (c_locale->locale_name == NULL)
494 err = ENOMEM;
495 }
496 else
497 err = EINVAL;
498
499 scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
500
501 if (err)
502 scm_gc_free (c_locale, sizeof (* c_locale), "locale");
503 else
504 SCM_NEWSMOB (*result, scm_tc16_locale_smob_type, c_locale);
505
506 return err;
507 }
508
509 #else /* USE_GNU_LOCALE_API */
510
511 /* Convenient macro to run STATEMENT in the locale context of C_LOCALE. */
512 #define RUN_IN_LOCALE_SECTION(_c_locale, _statement) \
513 do \
514 { \
515 scm_t_locale old_loc; \
516 \
517 old_loc = uselocale (_c_locale); \
518 _statement ; \
519 uselocale (old_loc); \
520 } \
521 while (0)
522
523
524 #endif /* USE_GNU_LOCALE_API */
525
526
527 \f
528 /* `make-locale' can take either category lists or single categories (the
529 `LC_*' integer constants). */
530 #define SCM_LIST_OR_INTEGER_P(arg) \
531 (scm_is_integer (arg) || scm_is_true (scm_list_p (arg)))
532
533
534 /* Return the category mask corresponding to CATEGORY (an `LC_' integer
535 constant). */
536 static inline int
537 category_to_category_mask (SCM category,
538 const char *func_name, int pos)
539 {
540 int c_category;
541 int c_category_mask;
542
543 c_category = scm_to_int (category);
544
545 #define SCM_DEFINE_LOCALE_CATEGORY(_name) \
546 case LC_ ## _name: \
547 c_category_mask = SCM_LOCALE_CATEGORY_MASK (_name); \
548 break;
549
550 switch (c_category)
551 {
552 #include "locale-categories.h"
553
554 case LC_ALL:
555 c_category_mask = LC_ALL_MASK;
556 break;
557
558 default:
559 scm_wrong_type_arg_msg (func_name, pos, category,
560 "locale category");
561 }
562
563 #undef SCM_DEFINE_LOCALE_CATEGORY
564
565 return c_category_mask;
566 }
567
568 /* Convert CATEGORIES, a list of locale categories or a single category (an
569 integer), into a category mask. */
570 static int
571 category_list_to_category_mask (SCM categories,
572 const char *func_name, int pos)
573 {
574 int c_category_mask = 0;
575
576 if (scm_is_integer (categories))
577 c_category_mask = category_to_category_mask (categories,
578 func_name, pos);
579 else
580 for (; !scm_is_null (categories); categories = SCM_CDR (categories))
581 {
582 SCM category = SCM_CAR (categories);
583
584 c_category_mask |=
585 category_to_category_mask (category, func_name, pos);
586 }
587
588 return c_category_mask;
589 }
590
591
592 SCM_DEFINE (scm_make_locale, "make-locale", 2, 1, 0,
593 (SCM category_list, SCM locale_name, SCM base_locale),
594 "Return a reference to a data structure representing a set of "
595 "locale datasets. @var{category_list} should be either a list "
596 "of locale categories or a single category as used with "
597 "@code{setlocale} (@pxref{Locales, @code{setlocale}}) and "
598 "@var{locale_name} should be the name of the locale considered "
599 "(e.g., @code{\"sl_SI\"}). Optionally, if @code{base_locale} is "
600 "passed, it should be a locale object denoting settings for "
601 "categories not listed in @var{category_list}.")
602 #define FUNC_NAME s_scm_make_locale
603 {
604 SCM locale = SCM_BOOL_F;
605 int err = 0;
606 int c_category_mask;
607 char *c_locale_name;
608 scm_t_locale c_base_locale, c_locale;
609
610 SCM_MAKE_VALIDATE (1, category_list, LIST_OR_INTEGER_P);
611 SCM_VALIDATE_STRING (2, locale_name);
612 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, base_locale, c_base_locale);
613
614 c_category_mask = category_list_to_category_mask (category_list,
615 FUNC_NAME, 1);
616 c_locale_name = scm_to_locale_string (locale_name);
617
618 #ifdef USE_GNU_LOCALE_API
619
620 if (scm_is_eq (base_locale, SCM_VARIABLE_REF (scm_global_locale)))
621 {
622 /* Fetch the current locale and turn in into a `locale_t'. Don't
623 duplicate the resulting `locale_t' because we want it to be consumed
624 by `newlocale ()'. */
625 char *current_locale;
626
627 scm_i_pthread_mutex_lock (&scm_i_locale_mutex);
628
629 current_locale = setlocale (LC_ALL, NULL);
630 c_base_locale = newlocale (LC_ALL_MASK, current_locale, NULL);
631
632 scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
633
634 if (c_base_locale == (locale_t) 0)
635 scm_locale_error (FUNC_NAME, errno);
636 }
637 else if (c_base_locale != (locale_t) 0)
638 {
639 /* C_BASE_LOCALE is to be consumed by `newlocale ()' so it needs to be
640 duplicated before. */
641 c_base_locale = duplocale (c_base_locale);
642 if (c_base_locale == (locale_t) 0)
643 {
644 err = errno;
645 goto fail;
646 }
647 }
648
649 c_locale = newlocale (c_category_mask, c_locale_name, c_base_locale);
650
651 free (c_locale_name);
652
653 if (c_locale == (locale_t) 0)
654 {
655 if (scm_is_eq (base_locale, SCM_VARIABLE_REF (scm_global_locale)))
656 /* The base locale object was created lazily and must be freed. */
657 freelocale (c_base_locale);
658
659 scm_locale_error (FUNC_NAME, errno);
660 }
661 else
662 SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale);
663
664 #else
665
666 c_locale = scm_gc_malloc (sizeof (* c_locale), "locale");
667
668 c_locale->category_mask = c_category_mask;
669 c_locale->locale_name = c_locale_name;
670
671 if (scm_is_eq (base_locale, SCM_VARIABLE_REF (scm_global_locale)))
672 {
673 /* Get the current locale settings and turn them into a locale
674 object. */
675 err = get_current_locale (&base_locale);
676 if (err)
677 goto fail;
678 }
679
680 c_locale->base_locale = base_locale;
681
682 {
683 /* Try out the new locale and raise an exception if it doesn't work. */
684 int err;
685 scm_t_locale_settings prev_locale;
686
687 err = enter_locale_section (c_locale, &prev_locale);
688
689 if (err)
690 goto fail;
691 else
692 {
693 leave_locale_section (&prev_locale);
694 SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale);
695 }
696 }
697
698 #endif
699
700 return locale;
701
702 fail:
703 #ifndef USE_GNU_LOCALE_API
704 scm_gc_free (c_locale, sizeof (* c_locale), "locale");
705 #endif
706 free (c_locale_name);
707 scm_locale_error (FUNC_NAME, err);
708
709 return SCM_BOOL_F;
710 }
711 #undef FUNC_NAME
712
713 SCM_DEFINE (scm_locale_p, "locale?", 1, 0, 0,
714 (SCM obj),
715 "Return true if @var{obj} is a locale object.")
716 #define FUNC_NAME s_scm_locale_p
717 {
718 return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_locale_smob_type, obj));
719 }
720 #undef FUNC_NAME
721
722
723 \f
724 /* Locale-dependent string comparison.
725
726 A similar API can be found in MzScheme starting from version 200:
727 http://download.plt-scheme.org/chronology/mzmr200alpha14.html . */
728
729 #define SCM_STRING_TO_U32_BUF(s1, c_s1) \
730 do \
731 { \
732 if (scm_i_is_narrow_string (s1)) \
733 { \
734 size_t i, len; \
735 const char *buf = scm_i_string_chars (s1); \
736 \
737 len = scm_i_string_length (s1); \
738 c_s1 = alloca (sizeof (scm_t_wchar) * (len + 1)); \
739 \
740 for (i = 0; i < len; i ++) \
741 c_s1[i] = (unsigned char ) buf[i]; \
742 c_s1[len] = 0; \
743 } \
744 else \
745 c_s1 = (scm_t_wchar *) scm_i_string_wide_chars (s1); \
746 } while (0)
747
748
749 /* Compare UTF-32 strings according to LOCALE. Returns a negative value if
750 S1 compares smaller than S2, a positive value if S1 compares larger than
751 S2, or 0 if they compare equal. */
752 static inline int
753 compare_u32_strings (SCM s1, SCM s2, SCM locale, const char *func_name)
754 #define FUNC_NAME func_name
755 {
756 int result;
757 scm_t_locale c_locale;
758 scm_t_wchar *c_s1, *c_s2;
759 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale);
760
761 SCM_STRING_TO_U32_BUF (s1, c_s1);
762 SCM_STRING_TO_U32_BUF (s2, c_s2);
763
764 if (c_locale)
765 RUN_IN_LOCALE_SECTION (c_locale,
766 result = u32_strcoll ((const scm_t_uint32 *) c_s1,
767 (const scm_t_uint32 *) c_s2));
768 else
769 result = u32_strcoll ((const scm_t_uint32 *) c_s1,
770 (const scm_t_uint32 *) c_s2);
771
772 scm_remember_upto_here_2 (s1, s2);
773 scm_remember_upto_here (locale);
774 return result;
775 }
776 #undef FUNC_NAME
777
778 /* Return the current language of the locale. */
779 static const char *
780 locale_language ()
781 {
782 /* FIXME: If the locale has been set with 'uselocale',
783 libunistring's uc_locale_language will return the incorrect
784 language: it will return the language appropriate for the global
785 (non-thread-specific) locale.
786
787 There appears to be no portable way to extract the language from
788 the thread-specific locale_t. There is no LANGUAGE capability in
789 nl_langinfo or nl_langinfo_l.
790
791 Thus, uc_locale_language needs to be fixed upstream. */
792 return uc_locale_language ();
793 }
794
795 static inline int
796 u32_locale_casecoll (const char *func_name, const scm_t_uint32 *c_s1,
797 const scm_t_uint32 *c_s2,
798 int *result)
799 {
800 /* Note: Since this is called from `RUN_IN_LOCALE_SECTION', it must note
801 make any non-local exit. */
802
803 int ret;
804 const char *loc = locale_language ();
805
806 ret = u32_casecoll (c_s1, u32_strlen (c_s1),
807 c_s2, u32_strlen (c_s2),
808 loc, UNINORM_NFC, result);
809
810 return ret == 0 ? ret : errno;
811 }
812
813 static inline int
814 compare_u32_strings_ci (SCM s1, SCM s2, SCM locale, const char *func_name)
815 #define FUNC_NAME func_name
816 {
817 int result, ret = 0;
818 scm_t_locale c_locale;
819 scm_t_wchar *c_s1, *c_s2;
820 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale);
821
822 SCM_STRING_TO_U32_BUF (s1, c_s1);
823 SCM_STRING_TO_U32_BUF (s2, c_s2);
824
825 if (c_locale)
826 RUN_IN_LOCALE_SECTION
827 (c_locale,
828 ret = u32_locale_casecoll (func_name,
829 (const scm_t_uint32 *) c_s1,
830 (const scm_t_uint32 *) c_s2,
831 &result));
832 else
833 ret = u32_locale_casecoll (func_name,
834 (const scm_t_uint32 *) c_s1,
835 (const scm_t_uint32 *) c_s2,
836 &result);
837
838 if (SCM_UNLIKELY (ret != 0))
839 {
840 errno = ret;
841 scm_syserror (FUNC_NAME);
842 }
843
844 scm_remember_upto_here_2 (s1, s2);
845 scm_remember_upto_here (locale);
846
847 return result;
848 }
849 #undef FUNC_NAME
850
851 /* Store into DST an upper-case version of SRC. */
852 static inline void
853 str_upcase (register char *dst, register const char *src)
854 {
855 for (; *src != '\0'; src++, dst++)
856 *dst = toupper ((int) *src);
857 *dst = '\0';
858 }
859
860 static inline void
861 str_downcase (register char *dst, register const char *src)
862 {
863 for (; *src != '\0'; src++, dst++)
864 *dst = tolower ((int) *src);
865 *dst = '\0';
866 }
867
868 #ifdef USE_GNU_LOCALE_API
869 static inline void
870 str_upcase_l (register char *dst, register const char *src,
871 scm_t_locale locale)
872 {
873 for (; *src != '\0'; src++, dst++)
874 *dst = toupper_l (*src, locale);
875 *dst = '\0';
876 }
877
878 static inline void
879 str_downcase_l (register char *dst, register const char *src,
880 scm_t_locale locale)
881 {
882 for (; *src != '\0'; src++, dst++)
883 *dst = tolower_l (*src, locale);
884 *dst = '\0';
885 }
886 #endif
887
888
889 SCM_DEFINE (scm_string_locale_lt, "string-locale<?", 2, 1, 0,
890 (SCM s1, SCM s2, SCM locale),
891 "Compare strings @var{s1} and @var{s2} in a locale-dependent way."
892 "If @var{locale} is provided, it should be locale object (as "
893 "returned by @code{make-locale}) and will be used to perform the "
894 "comparison; otherwise, the current system locale is used.")
895 #define FUNC_NAME s_scm_string_locale_lt
896 {
897 int result;
898
899 SCM_VALIDATE_STRING (1, s1);
900 SCM_VALIDATE_STRING (2, s2);
901
902 result = compare_u32_strings (s1, s2, locale, FUNC_NAME);
903
904 return scm_from_bool (result < 0);
905 }
906 #undef FUNC_NAME
907
908 SCM_DEFINE (scm_string_locale_gt, "string-locale>?", 2, 1, 0,
909 (SCM s1, SCM s2, SCM locale),
910 "Compare strings @var{s1} and @var{s2} in a locale-dependent way."
911 "If @var{locale} is provided, it should be locale object (as "
912 "returned by @code{make-locale}) and will be used to perform the "
913 "comparison; otherwise, the current system locale is used.")
914 #define FUNC_NAME s_scm_string_locale_gt
915 {
916 int result;
917
918 SCM_VALIDATE_STRING (1, s1);
919 SCM_VALIDATE_STRING (2, s2);
920
921 result = compare_u32_strings (s1, s2, locale, FUNC_NAME);
922
923 return scm_from_bool (result > 0);
924 }
925 #undef FUNC_NAME
926
927 SCM_DEFINE (scm_string_locale_ci_lt, "string-locale-ci<?", 2, 1, 0,
928 (SCM s1, SCM s2, SCM locale),
929 "Compare strings @var{s1} and @var{s2} in a case-insensitive, "
930 "and locale-dependent way. If @var{locale} is provided, it "
931 "should be locale object (as returned by @code{make-locale}) "
932 "and will be used to perform the comparison; otherwise, the "
933 "current system locale is used.")
934 #define FUNC_NAME s_scm_string_locale_ci_lt
935 {
936 int result;
937
938 SCM_VALIDATE_STRING (1, s1);
939 SCM_VALIDATE_STRING (2, s2);
940
941 result = compare_u32_strings_ci (s1, s2, locale, FUNC_NAME);
942
943 return scm_from_bool (result < 0);
944 }
945 #undef FUNC_NAME
946
947 SCM_DEFINE (scm_string_locale_ci_gt, "string-locale-ci>?", 2, 1, 0,
948 (SCM s1, SCM s2, SCM locale),
949 "Compare strings @var{s1} and @var{s2} in a case-insensitive, "
950 "and locale-dependent way. If @var{locale} is provided, it "
951 "should be locale object (as returned by @code{make-locale}) "
952 "and will be used to perform the comparison; otherwise, the "
953 "current system locale is used.")
954 #define FUNC_NAME s_scm_string_locale_ci_gt
955 {
956 int result;
957
958 SCM_VALIDATE_STRING (1, s1);
959 SCM_VALIDATE_STRING (2, s2);
960
961 result = compare_u32_strings_ci (s1, s2, locale, FUNC_NAME);
962
963 return scm_from_bool (result > 0);
964 }
965 #undef FUNC_NAME
966
967 SCM_DEFINE (scm_string_locale_ci_eq, "string-locale-ci=?", 2, 1, 0,
968 (SCM s1, SCM s2, SCM locale),
969 "Compare strings @var{s1} and @var{s2} in a case-insensitive, "
970 "and locale-dependent way. If @var{locale} is provided, it "
971 "should be locale object (as returned by @code{make-locale}) "
972 "and will be used to perform the comparison; otherwise, the "
973 "current system locale is used.")
974 #define FUNC_NAME s_scm_string_locale_ci_eq
975 {
976 int result;
977
978 SCM_VALIDATE_STRING (1, s1);
979 SCM_VALIDATE_STRING (2, s2);
980
981 result = compare_u32_strings_ci (s1, s2, locale, FUNC_NAME);
982
983 return scm_from_bool (result == 0);
984 }
985 #undef FUNC_NAME
986
987
988 SCM_DEFINE (scm_char_locale_lt, "char-locale<?", 2, 1, 0,
989 (SCM c1, SCM c2, SCM locale),
990 "Return true if character @var{c1} is lower than @var{c2} "
991 "according to @var{locale} or to the current locale.")
992 #define FUNC_NAME s_scm_char_locale_lt
993 {
994 int result;
995
996 SCM_VALIDATE_CHAR (1, c1);
997 SCM_VALIDATE_CHAR (2, c2);
998
999 result = compare_u32_strings (scm_string (scm_list_1 (c1)),
1000 scm_string (scm_list_1 (c2)),
1001 locale, FUNC_NAME);
1002
1003 return scm_from_bool (result < 0);
1004 }
1005 #undef FUNC_NAME
1006
1007 SCM_DEFINE (scm_char_locale_gt, "char-locale>?", 2, 1, 0,
1008 (SCM c1, SCM c2, SCM locale),
1009 "Return true if character @var{c1} is greater than @var{c2} "
1010 "according to @var{locale} or to the current locale.")
1011 #define FUNC_NAME s_scm_char_locale_gt
1012 {
1013 int result;
1014
1015 SCM_VALIDATE_CHAR (1, c1);
1016 SCM_VALIDATE_CHAR (2, c2);
1017
1018 result = compare_u32_strings (scm_string (scm_list_1 (c1)),
1019 scm_string (scm_list_1 (c2)),
1020 locale, FUNC_NAME);
1021
1022 return scm_from_bool (result > 0);
1023 }
1024 #undef FUNC_NAME
1025
1026 SCM_DEFINE (scm_char_locale_ci_lt, "char-locale-ci<?", 2, 1, 0,
1027 (SCM c1, SCM c2, SCM locale),
1028 "Return true if character @var{c1} is lower than @var{c2}, "
1029 "in a case insensitive way according to @var{locale} or to "
1030 "the current locale.")
1031 #define FUNC_NAME s_scm_char_locale_ci_lt
1032 {
1033 int result;
1034
1035 SCM_VALIDATE_CHAR (1, c1);
1036 SCM_VALIDATE_CHAR (2, c2);
1037
1038 result = compare_u32_strings_ci (scm_string (scm_list_1 (c1)),
1039 scm_string (scm_list_1 (c2)),
1040 locale, FUNC_NAME);
1041
1042 return scm_from_bool (result < 0);
1043 }
1044 #undef FUNC_NAME
1045
1046 SCM_DEFINE (scm_char_locale_ci_gt, "char-locale-ci>?", 2, 1, 0,
1047 (SCM c1, SCM c2, SCM locale),
1048 "Return true if character @var{c1} is greater than @var{c2}, "
1049 "in a case insensitive way according to @var{locale} or to "
1050 "the current locale.")
1051 #define FUNC_NAME s_scm_char_locale_ci_gt
1052 {
1053 int result;
1054
1055 SCM_VALIDATE_CHAR (1, c1);
1056 SCM_VALIDATE_CHAR (2, c2);
1057
1058 result = compare_u32_strings_ci (scm_string (scm_list_1 (c1)),
1059 scm_string (scm_list_1 (c2)),
1060 locale, FUNC_NAME);
1061
1062 return scm_from_bool (result > 0);
1063 }
1064 #undef FUNC_NAME
1065
1066 SCM_DEFINE (scm_char_locale_ci_eq, "char-locale-ci=?", 2, 1, 0,
1067 (SCM c1, SCM c2, SCM locale),
1068 "Return true if character @var{c1} is equal to @var{c2}, "
1069 "in a case insensitive way according to @var{locale} or to "
1070 "the current locale.")
1071 #define FUNC_NAME s_scm_char_locale_ci_eq
1072 {
1073 int result;
1074
1075 SCM_VALIDATE_CHAR (1, c1);
1076 SCM_VALIDATE_CHAR (2, c2);
1077
1078 result = compare_u32_strings_ci (scm_string (scm_list_1 (c1)),
1079 scm_string (scm_list_1 (c2)),
1080 locale, FUNC_NAME);
1081
1082 return scm_from_bool (result == 0);
1083 }
1084 #undef FUNC_NAME
1085
1086
1087 \f
1088 /* Locale-dependent alphabetic character mapping. */
1089
1090 static inline int
1091 u32_locale_tocase (const scm_t_uint32 *c_s1, size_t len,
1092 scm_t_uint32 **p_c_s2, size_t * p_len2,
1093 scm_t_uint32 *(*func) (const scm_t_uint32 *, size_t,
1094 const char *, uninorm_t,
1095 scm_t_uint32 *, size_t *))
1096 {
1097 /* Note: Since this is called from `RUN_IN_LOCALE_SECTION', it must not
1098 make any non-local exit. */
1099
1100 scm_t_uint32 *ret;
1101 const char *loc = locale_language ();
1102
1103 /* The first NULL here indicates that no NFC or NFKC normalization
1104 is done. The second NULL means the return buffer is
1105 malloc'ed here. */
1106 ret = func (c_s1, len, loc, NULL, NULL, p_len2);
1107
1108 if (ret == NULL)
1109 {
1110 *p_c_s2 = (scm_t_uint32 *) NULL;
1111 *p_len2 = 0;
1112 return errno;
1113 }
1114 *p_c_s2 = ret;
1115
1116 return 0;
1117 }
1118
1119
1120
1121 SCM_DEFINE (scm_char_locale_downcase, "char-locale-downcase", 1, 1, 0,
1122 (SCM chr, SCM locale),
1123 "Return the lowercase character that corresponds to @var{chr} "
1124 "according to either @var{locale} or the current locale.")
1125 #define FUNC_NAME s_scm_char_locale_downcase
1126 {
1127 int ret;
1128 scm_t_locale c_locale;
1129 scm_t_wchar *buf;
1130 scm_t_uint32 *downbuf;
1131 size_t downlen;
1132 SCM str, downchar;
1133
1134 SCM_VALIDATE_CHAR (1, chr);
1135 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
1136
1137 str = scm_i_make_wide_string (1, &buf);
1138 buf[0] = SCM_CHAR (chr);
1139
1140 if (c_locale != NULL)
1141 RUN_IN_LOCALE_SECTION (c_locale, ret =
1142 u32_locale_tocase ((scm_t_uint32 *) buf, 1,
1143 &downbuf,
1144 &downlen, u32_tolower));
1145 else
1146 ret =
1147 u32_locale_tocase ((scm_t_uint32 *) buf, 1, &downbuf,
1148 &downlen, u32_tolower);
1149
1150 if (SCM_UNLIKELY (ret != 0))
1151 {
1152 errno = ret;
1153 scm_syserror (FUNC_NAME);
1154 }
1155
1156 if (downlen == 1)
1157 downchar = SCM_MAKE_CHAR ((scm_t_wchar) downbuf[0]);
1158 else
1159 downchar = chr;
1160 free (downbuf);
1161
1162 return downchar;
1163 }
1164 #undef FUNC_NAME
1165
1166 SCM_DEFINE (scm_char_locale_upcase, "char-locale-upcase", 1, 1, 0,
1167 (SCM chr, SCM locale),
1168 "Return the uppercase character that corresponds to @var{chr} "
1169 "according to either @var{locale} or the current locale.")
1170 #define FUNC_NAME s_scm_char_locale_upcase
1171 {
1172 int ret;
1173 scm_t_locale c_locale;
1174 scm_t_wchar *buf;
1175 scm_t_uint32 *upbuf;
1176 size_t uplen;
1177 SCM str, upchar;
1178
1179 SCM_VALIDATE_CHAR (1, chr);
1180 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
1181
1182 str = scm_i_make_wide_string (1, &buf);
1183 buf[0] = SCM_CHAR (chr);
1184
1185 if (c_locale != NULL)
1186 RUN_IN_LOCALE_SECTION (c_locale, ret =
1187 u32_locale_tocase ((scm_t_uint32 *) buf, 1,
1188 &upbuf,
1189 &uplen, u32_toupper));
1190 else
1191 ret =
1192 u32_locale_tocase ((scm_t_uint32 *) buf, 1, &upbuf,
1193 &uplen, u32_toupper);
1194
1195 if (SCM_UNLIKELY (ret != 0))
1196 {
1197 errno = ret;
1198 scm_syserror (FUNC_NAME);
1199 }
1200 if (uplen == 1)
1201 upchar = SCM_MAKE_CHAR ((scm_t_wchar) upbuf[0]);
1202 else
1203 upchar = chr;
1204 free (upbuf);
1205 return upchar;
1206 }
1207 #undef FUNC_NAME
1208
1209 SCM_DEFINE (scm_string_locale_upcase, "string-locale-upcase", 1, 1, 0,
1210 (SCM str, SCM locale),
1211 "Return a new string that is the uppercase version of "
1212 "@var{str} according to either @var{locale} or the current "
1213 "locale.")
1214 #define FUNC_NAME s_scm_string_locale_upcase
1215 {
1216 scm_t_wchar *c_str, *c_buf;
1217 scm_t_uint32 *c_upstr;
1218 size_t len, uplen;
1219 int ret;
1220 scm_t_locale c_locale;
1221 SCM upstr;
1222
1223 SCM_VALIDATE_STRING (1, str);
1224 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
1225 len = scm_i_string_length (str);
1226 if (len == 0)
1227 return scm_nullstr;
1228 SCM_STRING_TO_U32_BUF (str, c_str);
1229
1230 if (c_locale)
1231 RUN_IN_LOCALE_SECTION (c_locale, ret =
1232 u32_locale_tocase ((scm_t_uint32 *) c_str, len,
1233 &c_upstr,
1234 &uplen, u32_toupper));
1235 else
1236 ret =
1237 u32_locale_tocase ((scm_t_uint32 *) c_str, len,
1238 &c_upstr, &uplen, u32_toupper);
1239
1240 scm_remember_upto_here (str);
1241
1242 if (SCM_UNLIKELY (ret != 0))
1243 {
1244 errno = ret;
1245 scm_syserror (FUNC_NAME);
1246 }
1247
1248 upstr = scm_i_make_wide_string (uplen, &c_buf);
1249 memcpy (c_buf, c_upstr, uplen * sizeof (scm_t_wchar));
1250 free (c_upstr);
1251
1252 scm_i_try_narrow_string (upstr);
1253
1254 return upstr;
1255 }
1256 #undef FUNC_NAME
1257
1258 SCM_DEFINE (scm_string_locale_downcase, "string-locale-downcase", 1, 1, 0,
1259 (SCM str, SCM locale),
1260 "Return a new string that is the down-case version of "
1261 "@var{str} according to either @var{locale} or the current "
1262 "locale.")
1263 #define FUNC_NAME s_scm_string_locale_downcase
1264 {
1265 scm_t_wchar *c_str, *c_buf;
1266 scm_t_uint32 *c_downstr;
1267 size_t len, downlen;
1268 int ret;
1269 scm_t_locale c_locale;
1270 SCM downstr;
1271
1272 SCM_VALIDATE_STRING (1, str);
1273 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
1274 len = scm_i_string_length (str);
1275 if (len == 0)
1276 return scm_nullstr;
1277 SCM_STRING_TO_U32_BUF (str, c_str);
1278
1279 if (c_locale)
1280 RUN_IN_LOCALE_SECTION (c_locale, ret =
1281 u32_locale_tocase ((scm_t_uint32 *) c_str, len,
1282 &c_downstr,
1283 &downlen, u32_tolower));
1284 else
1285 ret =
1286 u32_locale_tocase ((scm_t_uint32 *) c_str, len,
1287 &c_downstr, &downlen, u32_tolower);
1288
1289 scm_remember_upto_here (str);
1290
1291 if (SCM_UNLIKELY (ret != 0))
1292 {
1293 errno = ret;
1294 scm_syserror (FUNC_NAME);
1295 }
1296
1297 downstr = scm_i_make_wide_string (downlen, &c_buf);
1298 memcpy (c_buf, c_downstr, downlen * sizeof (scm_t_wchar));
1299 free (c_downstr);
1300
1301 scm_i_try_narrow_string (downstr);
1302
1303 return downstr;
1304 }
1305 #undef FUNC_NAME
1306
1307 /* Note: We don't provide mutative versions of `string-locale-(up|down)case'
1308 because, in some languages, a single downcase character maps to a couple
1309 of uppercase characters. Read the SRFI-13 document for a detailed
1310 discussion about this. */
1311
1312
1313 \f
1314 /* Locale-dependent number parsing. */
1315
1316 SCM_DEFINE (scm_locale_string_to_integer, "locale-string->integer",
1317 1, 2, 0, (SCM str, SCM base, SCM locale),
1318 "Convert string @var{str} into an integer according to either "
1319 "@var{locale} (a locale object as returned by @code{make-locale}) "
1320 "or the current process locale. Return two values: an integer "
1321 "(on success) or @code{#f}, and the number of characters read "
1322 "from @var{str} (@code{0} on failure).")
1323 #define FUNC_NAME s_scm_locale_string_to_integer
1324 {
1325 SCM result;
1326 long c_result;
1327 int c_base;
1328 const char *c_str;
1329 char *c_endptr;
1330 scm_t_locale c_locale;
1331
1332 SCM_VALIDATE_STRING (1, str);
1333 c_str = scm_i_string_chars (str);
1334
1335 if (base != SCM_UNDEFINED)
1336 SCM_VALIDATE_INT_COPY (2, base, c_base);
1337 else
1338 c_base = 10;
1339
1340 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale);
1341
1342 if (c_locale != NULL)
1343 {
1344 #ifdef USE_GNU_LOCALE_API
1345 c_result = strtol_l (c_str, &c_endptr, c_base, c_locale);
1346 #else
1347 RUN_IN_LOCALE_SECTION (c_locale,
1348 c_result = strtol (c_str, &c_endptr, c_base));
1349 #endif
1350 }
1351 else
1352 c_result = strtol (c_str, &c_endptr, c_base);
1353
1354 scm_remember_upto_here (str);
1355
1356 if (c_endptr == c_str)
1357 result = SCM_BOOL_F;
1358 else
1359 result = scm_from_long (c_result);
1360
1361 return (scm_values (scm_list_2 (result, scm_from_long (c_endptr - c_str))));
1362 }
1363 #undef FUNC_NAME
1364
1365 SCM_DEFINE (scm_locale_string_to_inexact, "locale-string->inexact",
1366 1, 1, 0, (SCM str, SCM locale),
1367 "Convert string @var{str} into an inexact number according to "
1368 "either @var{locale} (a locale object as returned by "
1369 "@code{make-locale}) or the current process locale. Return "
1370 "two values: an inexact number (on success) or @code{#f}, and "
1371 "the number of characters read from @var{str} (@code{0} on "
1372 "failure).")
1373 #define FUNC_NAME s_scm_locale_string_to_inexact
1374 {
1375 SCM result;
1376 double c_result;
1377 const char *c_str;
1378 char *c_endptr;
1379 scm_t_locale c_locale;
1380
1381 SCM_VALIDATE_STRING (1, str);
1382 c_str = scm_i_string_chars (str);
1383
1384 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
1385
1386 if (c_locale != NULL)
1387 {
1388 #ifdef USE_GNU_LOCALE_API
1389 c_result = strtod_l (c_str, &c_endptr, c_locale);
1390 #else
1391 RUN_IN_LOCALE_SECTION (c_locale,
1392 c_result = strtod (c_str, &c_endptr));
1393 #endif
1394 }
1395 else
1396 c_result = strtod (c_str, &c_endptr);
1397
1398 scm_remember_upto_here (str);
1399
1400 if (c_endptr == c_str)
1401 result = SCM_BOOL_F;
1402 else
1403 result = scm_from_double (c_result);
1404
1405 return (scm_values (scm_list_2 (result, scm_from_long (c_endptr - c_str))));
1406 }
1407 #undef FUNC_NAME
1408
1409 \f
1410 /* Language information, aka. `nl_langinfo ()'. */
1411
1412 /* FIXME: Issues related to `nl-langinfo'.
1413
1414 1. The `CODESET' value is not normalized. This is a secondary issue, but
1415 still a practical issue. See
1416 http://www.cl.cam.ac.uk/~mgk25/ucs/norm_charmap.c for codeset
1417 normalization.
1418
1419 2. `nl_langinfo ()' is not available on Windows.
1420
1421 3. `nl_langinfo ()' may return strings encoded in a locale different from
1422 the current one.
1423 For example:
1424
1425 (nl-langinfo DAY_1 (make-locale LC_ALL "eo_EO.UTF-8"))
1426
1427 returns a result that is a UTF-8 string, regardless of the
1428 setting of the current locale. If nl_langinfo supports CODESET,
1429 we can convert the string properly using scm_from_stringn. If
1430 CODESET is not supported, we won't be able to make much sense of
1431 the returned string. */
1432
1433
1434 SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
1435 (SCM item, SCM locale),
1436 "Return a string denoting locale information for @var{item} "
1437 "in the current locale or that specified by @var{locale}. "
1438 "The semantics and arguments are the same as those of the "
1439 "X/Open @code{nl_langinfo} function (@pxref{The Elegant and "
1440 "Fast Way, @code{nl_langinfo},, libc, The GNU C Library "
1441 "Reference Manual}).")
1442 #define FUNC_NAME s_scm_nl_langinfo
1443 {
1444 #ifdef HAVE_NL_LANGINFO
1445 SCM result;
1446 nl_item c_item;
1447 char *c_result;
1448 scm_t_locale c_locale;
1449 #ifdef HAVE_LANGINFO_CODESET
1450 char *codeset;
1451 #endif
1452
1453 SCM_VALIDATE_INT_COPY (2, item, c_item);
1454 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
1455
1456 /* Sadly, `nl_langinfo ()' returns a pointer to a static string. According
1457 to SuS v2, that static string may be modified by subsequent calls to
1458 `nl_langinfo ()' as well as by calls to `setlocale ()'. Thus, we must
1459 acquire the locale mutex before doing invoking `nl_langinfo ()'. See
1460 http://opengroup.org/onlinepubs/007908799/xsh/nl_langinfo.html for
1461 details. */
1462
1463 scm_i_pthread_mutex_lock (&scm_i_locale_mutex);
1464 if (c_locale != NULL)
1465 {
1466 #ifdef USE_GNU_LOCALE_API
1467 c_result = nl_langinfo_l (c_item, c_locale);
1468 #ifdef HAVE_LANGINFO_CODESET
1469 codeset = nl_langinfo_l (CODESET, c_locale);
1470 #endif /* HAVE_LANGINFO_CODESET */
1471 #else /* !USE_GNU_LOCALE_API */
1472 /* We can't use `RUN_IN_LOCALE_SECTION ()' here because the locale
1473 mutex is already taken. */
1474 int lsec_err;
1475 scm_t_locale_settings lsec_prev_locale;
1476
1477 lsec_err = get_current_locale_settings (&lsec_prev_locale);
1478 if (lsec_err)
1479 scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
1480 else
1481 {
1482 lsec_err = install_locale (c_locale);
1483 if (lsec_err)
1484 {
1485 leave_locale_section (&lsec_prev_locale);
1486 free_locale_settings (&lsec_prev_locale);
1487 }
1488 }
1489
1490 if (lsec_err)
1491 scm_locale_error (FUNC_NAME, lsec_err);
1492 else
1493 {
1494 c_result = nl_langinfo (c_item);
1495 #ifdef HAVE_LANGINFO_CODESET
1496 codeset = nl_langinfo (CODESET);
1497 #endif /* HAVE_LANGINFO_CODESET */
1498
1499 restore_locale_settings (&lsec_prev_locale);
1500 free_locale_settings (&lsec_prev_locale);
1501 }
1502 #endif
1503 }
1504 else
1505 {
1506 c_result = nl_langinfo (c_item);
1507 #ifdef HAVE_LANGINFO_CODESET
1508 codeset = nl_langinfo (CODESET);
1509 #endif /* HAVE_LANGINFO_CODESET */
1510 }
1511
1512 c_result = strdup (c_result);
1513 scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
1514
1515 if (c_result == NULL)
1516 result = SCM_BOOL_F;
1517 else
1518 {
1519 switch (c_item)
1520 {
1521 #if (defined GROUPING) && (defined MON_GROUPING)
1522 case GROUPING:
1523 case MON_GROUPING:
1524 {
1525 char *p;
1526
1527 /* In this cases, the result is to be interpreted as a list of
1528 numbers. If the last item is `CHARS_MAX', it has the special
1529 meaning "no more grouping". */
1530 result = SCM_EOL;
1531 for (p = c_result; (*p != '\0') && (*p != CHAR_MAX); p++)
1532 result = scm_cons (SCM_I_MAKINUM ((int) *p), result);
1533
1534 {
1535 SCM last_pair = result;
1536
1537 result = scm_reverse_x (result, SCM_EOL);
1538
1539 if (*p != CHAR_MAX)
1540 {
1541 /* Cyclic grouping information. */
1542 if (last_pair != SCM_EOL)
1543 SCM_SETCDR (last_pair, result);
1544 }
1545 }
1546
1547 free (c_result);
1548 break;
1549 }
1550 #endif
1551
1552 #if (defined FRAC_DIGITS) && (defined INT_FRAC_DIGITS)
1553 case FRAC_DIGITS:
1554 case INT_FRAC_DIGITS:
1555 /* This is to be interpreted as a single integer. */
1556 if (*c_result == CHAR_MAX)
1557 /* Unspecified. */
1558 result = SCM_BOOL_F;
1559 else
1560 result = SCM_I_MAKINUM (*c_result);
1561
1562 free (c_result);
1563 break;
1564 #endif
1565
1566 #if (defined P_CS_PRECEDES) && (defined INT_N_CS_PRECEDES)
1567 case P_CS_PRECEDES:
1568 case N_CS_PRECEDES:
1569 case INT_P_CS_PRECEDES:
1570 case INT_N_CS_PRECEDES:
1571 #if (defined P_SEP_BY_SPACE) && (defined N_SEP_BY_SPACE)
1572 case P_SEP_BY_SPACE:
1573 case N_SEP_BY_SPACE:
1574 #endif
1575 /* This is to be interpreted as a boolean. */
1576 result = scm_from_bool (*c_result);
1577
1578 free (c_result);
1579 break;
1580 #endif
1581
1582 #if (defined P_SIGN_POSN) && (defined INT_N_SIGN_POSN)
1583 case P_SIGN_POSN:
1584 case N_SIGN_POSN:
1585 case INT_P_SIGN_POSN:
1586 case INT_N_SIGN_POSN:
1587 /* See `(libc) Sign of Money Amount' for the interpretation of the
1588 return value here. */
1589 switch (*c_result)
1590 {
1591 case 0:
1592 result = scm_from_locale_symbol ("parenthesize");
1593 break;
1594
1595 case 1:
1596 result = scm_from_locale_symbol ("sign-before");
1597 break;
1598
1599 case 2:
1600 result = scm_from_locale_symbol ("sign-after");
1601 break;
1602
1603 case 3:
1604 result = scm_from_locale_symbol ("sign-before-currency-symbol");
1605 break;
1606
1607 case 4:
1608 result = scm_from_locale_symbol ("sign-after-currency-symbol");
1609 break;
1610
1611 default:
1612 result = scm_from_locale_symbol ("unspecified");
1613 }
1614 break;
1615 #endif
1616
1617 default:
1618 #ifdef HAVE_LANGINFO_CODESET
1619 result = scm_from_stringn (c_result, strlen (c_result),
1620 codeset,
1621 SCM_FAILED_CONVERSION_QUESTION_MARK);
1622 #else /* !HAVE_LANGINFO_CODESET */
1623 /* This may be incorrectly encoded if the locale differs
1624 from the c_locale. */
1625 result = scm_from_locale_string (c_result);
1626 #endif /* !HAVE_LANGINFO_CODESET */
1627 free (c_result);
1628 }
1629 }
1630
1631 return result;
1632 #else
1633 scm_syserror_msg (FUNC_NAME, "`nl-langinfo' not supported on your system",
1634 SCM_EOL, ENOSYS);
1635
1636 return SCM_BOOL_F;
1637 #endif
1638 }
1639 #undef FUNC_NAME
1640
1641 /* Define the `nl_item' constants. */
1642 static inline void
1643 define_langinfo_items (void)
1644 {
1645 #if (defined HAVE_NL_TYPES_H) && (defined HAVE_LANGINFO_H)
1646
1647 #define DEFINE_NLITEM_CONSTANT(_item) \
1648 scm_c_define (# _item, scm_from_int (_item))
1649
1650 DEFINE_NLITEM_CONSTANT (CODESET);
1651
1652 /* Abbreviated days of the week. */
1653 DEFINE_NLITEM_CONSTANT (ABDAY_1);
1654 DEFINE_NLITEM_CONSTANT (ABDAY_2);
1655 DEFINE_NLITEM_CONSTANT (ABDAY_3);
1656 DEFINE_NLITEM_CONSTANT (ABDAY_4);
1657 DEFINE_NLITEM_CONSTANT (ABDAY_5);
1658 DEFINE_NLITEM_CONSTANT (ABDAY_6);
1659 DEFINE_NLITEM_CONSTANT (ABDAY_7);
1660
1661 /* Long-named days of the week. */
1662 DEFINE_NLITEM_CONSTANT (DAY_1); /* Sunday */
1663 DEFINE_NLITEM_CONSTANT (DAY_2); /* Monday */
1664 DEFINE_NLITEM_CONSTANT (DAY_3); /* Tuesday */
1665 DEFINE_NLITEM_CONSTANT (DAY_4); /* Wednesday */
1666 DEFINE_NLITEM_CONSTANT (DAY_5); /* Thursday */
1667 DEFINE_NLITEM_CONSTANT (DAY_6); /* Friday */
1668 DEFINE_NLITEM_CONSTANT (DAY_7); /* Saturday */
1669
1670 /* Abbreviated month names. */
1671 DEFINE_NLITEM_CONSTANT (ABMON_1); /* Jan */
1672 DEFINE_NLITEM_CONSTANT (ABMON_2);
1673 DEFINE_NLITEM_CONSTANT (ABMON_3);
1674 DEFINE_NLITEM_CONSTANT (ABMON_4);
1675 DEFINE_NLITEM_CONSTANT (ABMON_5);
1676 DEFINE_NLITEM_CONSTANT (ABMON_6);
1677 DEFINE_NLITEM_CONSTANT (ABMON_7);
1678 DEFINE_NLITEM_CONSTANT (ABMON_8);
1679 DEFINE_NLITEM_CONSTANT (ABMON_9);
1680 DEFINE_NLITEM_CONSTANT (ABMON_10);
1681 DEFINE_NLITEM_CONSTANT (ABMON_11);
1682 DEFINE_NLITEM_CONSTANT (ABMON_12);
1683
1684 /* Long month names. */
1685 DEFINE_NLITEM_CONSTANT (MON_1); /* January */
1686 DEFINE_NLITEM_CONSTANT (MON_2);
1687 DEFINE_NLITEM_CONSTANT (MON_3);
1688 DEFINE_NLITEM_CONSTANT (MON_4);
1689 DEFINE_NLITEM_CONSTANT (MON_5);
1690 DEFINE_NLITEM_CONSTANT (MON_6);
1691 DEFINE_NLITEM_CONSTANT (MON_7);
1692 DEFINE_NLITEM_CONSTANT (MON_8);
1693 DEFINE_NLITEM_CONSTANT (MON_9);
1694 DEFINE_NLITEM_CONSTANT (MON_10);
1695 DEFINE_NLITEM_CONSTANT (MON_11);
1696 DEFINE_NLITEM_CONSTANT (MON_12);
1697
1698 DEFINE_NLITEM_CONSTANT (AM_STR); /* Ante meridiem string. */
1699 DEFINE_NLITEM_CONSTANT (PM_STR); /* Post meridiem string. */
1700
1701 DEFINE_NLITEM_CONSTANT (D_T_FMT); /* Date and time format for strftime. */
1702 DEFINE_NLITEM_CONSTANT (D_FMT); /* Date format for strftime. */
1703 DEFINE_NLITEM_CONSTANT (T_FMT); /* Time format for strftime. */
1704 DEFINE_NLITEM_CONSTANT (T_FMT_AMPM);/* 12-hour time format for strftime. */
1705
1706 DEFINE_NLITEM_CONSTANT (ERA); /* Alternate era. */
1707 DEFINE_NLITEM_CONSTANT (ERA_D_FMT); /* Date in alternate era format. */
1708 DEFINE_NLITEM_CONSTANT (ERA_D_T_FMT); /* Date and time in alternate era
1709 format. */
1710 DEFINE_NLITEM_CONSTANT (ERA_T_FMT); /* Time in alternate era format. */
1711
1712 DEFINE_NLITEM_CONSTANT (ALT_DIGITS); /* Alternate symbols for digits. */
1713 DEFINE_NLITEM_CONSTANT (RADIXCHAR);
1714 DEFINE_NLITEM_CONSTANT (THOUSEP);
1715
1716 #ifdef YESEXPR
1717 DEFINE_NLITEM_CONSTANT (YESEXPR);
1718 #endif
1719 #ifdef NOEXPR
1720 DEFINE_NLITEM_CONSTANT (NOEXPR);
1721 #endif
1722
1723 #ifdef CRNCYSTR /* currency symbol */
1724 DEFINE_NLITEM_CONSTANT (CRNCYSTR);
1725 #endif
1726
1727 /* GNU extensions. */
1728
1729 #ifdef ERA_YEAR
1730 DEFINE_NLITEM_CONSTANT (ERA_YEAR); /* Year in alternate era format. */
1731 #endif
1732
1733 /* LC_MONETARY category: formatting of monetary quantities.
1734 These items each correspond to a member of `struct lconv',
1735 defined in <locale.h>. */
1736 #ifdef INT_CURR_SYMBOL
1737 DEFINE_NLITEM_CONSTANT (INT_CURR_SYMBOL);
1738 #endif
1739 #ifdef MON_DECIMAL_POINT
1740 DEFINE_NLITEM_CONSTANT (MON_DECIMAL_POINT);
1741 #endif
1742 #ifdef MON_THOUSANDS_SEP
1743 DEFINE_NLITEM_CONSTANT (MON_THOUSANDS_SEP);
1744 #endif
1745 #ifdef MON_GROUPING
1746 DEFINE_NLITEM_CONSTANT (MON_GROUPING);
1747 #endif
1748 #ifdef POSITIVE_SIGN
1749 DEFINE_NLITEM_CONSTANT (POSITIVE_SIGN);
1750 #endif
1751 #ifdef NEGATIVE_SIGN
1752 DEFINE_NLITEM_CONSTANT (NEGATIVE_SIGN);
1753 #endif
1754 #ifdef GROUPING
1755 DEFINE_NLITEM_CONSTANT (GROUPING);
1756 #endif
1757 #ifdef INT_FRAC_DIGITS
1758 DEFINE_NLITEM_CONSTANT (INT_FRAC_DIGITS);
1759 #endif
1760 #ifdef FRAC_DIGITS
1761 DEFINE_NLITEM_CONSTANT (FRAC_DIGITS);
1762 #endif
1763 #ifdef P_CS_PRECEDES
1764 DEFINE_NLITEM_CONSTANT (P_CS_PRECEDES);
1765 #endif
1766 #ifdef P_SEP_BY_SPACE
1767 DEFINE_NLITEM_CONSTANT (P_SEP_BY_SPACE);
1768 #endif
1769 #ifdef N_CS_PRECEDES
1770 DEFINE_NLITEM_CONSTANT (N_CS_PRECEDES);
1771 #endif
1772 #ifdef N_SEP_BY_SPACE
1773 DEFINE_NLITEM_CONSTANT (N_SEP_BY_SPACE);
1774 #endif
1775 #ifdef P_SIGN_POSN
1776 DEFINE_NLITEM_CONSTANT (P_SIGN_POSN);
1777 #endif
1778 #ifdef N_SIGN_POSN
1779 DEFINE_NLITEM_CONSTANT (N_SIGN_POSN);
1780 #endif
1781 #ifdef INT_P_CS_PRECEDES
1782 DEFINE_NLITEM_CONSTANT (INT_P_CS_PRECEDES);
1783 #endif
1784 #ifdef INT_P_SEP_BY_SPACE
1785 DEFINE_NLITEM_CONSTANT (INT_P_SEP_BY_SPACE);
1786 #endif
1787 #ifdef INT_N_CS_PRECEDES
1788 DEFINE_NLITEM_CONSTANT (INT_N_CS_PRECEDES);
1789 #endif
1790 #ifdef INT_N_SEP_BY_SPACE
1791 DEFINE_NLITEM_CONSTANT (INT_N_SEP_BY_SPACE);
1792 #endif
1793 #ifdef INT_P_SIGN_POSN
1794 DEFINE_NLITEM_CONSTANT (INT_P_SIGN_POSN);
1795 #endif
1796 #ifdef INT_N_SIGN_POSN
1797 DEFINE_NLITEM_CONSTANT (INT_N_SIGN_POSN);
1798 #endif
1799
1800 #undef DEFINE_NLITEM_CONSTANT
1801
1802 #endif /* HAVE_NL_TYPES_H */
1803 }
1804
1805 \f
1806 void
1807 scm_init_i18n ()
1808 {
1809 SCM global_locale_smob;
1810
1811 #ifdef HAVE_NL_LANGINFO
1812 scm_add_feature ("nl-langinfo");
1813 define_langinfo_items ();
1814 #endif
1815
1816 #include "libguile/i18n.x"
1817
1818 /* Initialize the global locale object with a special `locale' SMOB. */
1819 SCM_NEWSMOB (global_locale_smob, scm_tc16_locale_smob_type, NULL);
1820 SCM_VARIABLE_SET (scm_global_locale, global_locale_smob);
1821 }
1822
1823 void
1824 scm_bootstrap_i18n ()
1825 {
1826 scm_c_register_extension ("libguile", "scm_init_i18n",
1827 (scm_t_extension_init_func) scm_init_i18n,
1828 NULL);
1829
1830 }
1831
1832
1833 /*
1834 Local Variables:
1835 c-file-style: "gnu"
1836 End:
1837 */
Unnamed repository; edit this file 'description' to name the repository.