HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
i18n: Avoid needless heap allocation.
[bpt/guile.git] / libguile / i18n.c
CommitLineData
49c9839e 1/* Copyright (C) 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
9361f762
MV		 2 *
3 * This library is free software; you can redistribute it and/or
53befeb7
NJ		 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.
9361f762 7 *
53befeb7
NJ		 8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
9361f762
MV		 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
53befeb7
NJ		 15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
16 * 02110-1301 USA
9361f762
MV		 17 */
18
dbb605f5 19#ifdef HAVE_CONFIG_H
9361f762
MV		 20# include <config.h>
21#endif
22
f7439099 23#include <alloca.h>
b89c4943 24
9361f762 25#include "libguile/_scm.h"
756e8a3a 26#include "libguile/extensions.h"
9361f762
MV		 27#include "libguile/feature.h"
28#include "libguile/i18n.h"
29#include "libguile/strings.h"
b89c4943 30#include "libguile/chars.h"
9361f762 31#include "libguile/dynwind.h"
b89c4943
LC		 32#include "libguile/validate.h"
33#include "libguile/values.h"
a2f00b9b 34#include "libguile/threads.h"
9361f762 35
9361f762 36#include <locale.h>
b89c4943
LC		 37#include <string.h> /* `strcoll ()' */
38#include <ctype.h> /* `toupper ()' et al. */
39#include <errno.h>
5b878445
MG		 40#include <unicase.h>
41#include <unistr.h>
9361f762 42
b89c4943 43#if (defined HAVE_NEWLOCALE) && (defined HAVE_STRCOLL_L)
a2f00b9b
LC		 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
83fda470
LC		 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 */
b89c4943 57# define USE_GNU_LOCALE_API
9361f762 58#endif
b89c4943 59
a2f00b9b
LC		 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>
9361f762 69#endif
b89c4943
LC		 70
71#ifndef HAVE_SETLOCALE
72static inline char *
73setlocale (int category, const char *name)
74{
75 errno = ENOSYS;
76 return NULL;
77}
9361f762 78#endif
b89c4943 79
a2f00b9b
LC		 80/* Helper stringification macro. */
81#define SCM_I18N_STRINGIFY(_name) # _name
82
b89c4943
LC		 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
a2f00b9b 92 1. The `scm_i_locale_mutex' is locked.
b89c4943 93 2. A series of `setlocale ()' call is performed to store the current
a2f00b9b 94 locale for each category in an `scm_t_locale' object.
b89c4943
LC		 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.
a2f00b9b 99 5. The `scm_i_locale_mutex' is released.
b89c4943 100
a2f00b9b 101 Hopefully, the X/Open standard will eventually make this hack useless.
b89c4943
LC		 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
a2f00b9b
LC		 109/* Return the category mask corresponding to CAT. */
110#define SCM_LOCALE_CATEGORY_MASK(_cat) LC_ ## _cat ## _MASK
111
112
b89c4943
LC		 113#ifndef USE_GNU_LOCALE_API
114
a2f00b9b
LC		 115/* Provide the locale category masks as found in glibc. This must be kept in
116 sync with `locale-categories.h'. */
b89c4943 117
a2f00b9b
LC		 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
b89c4943
LC		 124
125# ifdef LC_PAPER
a2f00b9b 126# define LC_PAPER_MASK 64
b89c4943
LC		 127# else
128# define LC_PAPER_MASK 0
129# endif
130# ifdef LC_NAME
a2f00b9b 131# define LC_NAME_MASK 128
b89c4943
LC		 132# else
133# define LC_NAME_MASK 0
134# endif
135# ifdef LC_ADDRESS
a2f00b9b 136# define LC_ADDRESS_MASK 256
b89c4943
LC		 137# else
138# define LC_ADDRESS_MASK 0
139# endif
140# ifdef LC_TELEPHONE
a2f00b9b 141# define LC_TELEPHONE_MASK 512
b89c4943
LC		 142# else
143# define LC_TELEPHONE_MASK 0
144# endif
145# ifdef LC_MEASUREMENT
a2f00b9b 146# define LC_MEASUREMENT_MASK 1024
b89c4943
LC		 147# else
148# define LC_MEASUREMENT_MASK 0
149# endif
150# ifdef LC_IDENTIFICATION
a2f00b9b 151# define LC_IDENTIFICATION_MASK 2048
b89c4943
LC		 152# else
153# define LC_IDENTIFICATION_MASK 0
154# endif
155
a2f00b9b
LC		 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 \
b89c4943
LC		 168 )
169
170/* Locale objects as returned by `make-locale' on non-GNU systems. */
171typedef struct scm_locale
172{
173 SCM base_locale; /* a `locale' object */
174 char *locale_name;
175 int category_mask;
176} *scm_t_locale;
177
a2f00b9b
LC		 178
179/* Free the resources used by LOCALE. */
180static inline void
181scm_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 */
b89c4943
LC		 188
189/* Alias for glibc's locale type. */
190typedef locale_t scm_t_locale;
191
a2f00b9b
LC		 192#define scm_i_locale_free freelocale
193
194#endif /* USE_GNU_LOCALE_API */
195
196
197/* A locale object denoting the global locale. */
198SCM_GLOBAL_VARIABLE (scm_global_locale, "%global-locale");
199
b89c4943
LC		 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
224SCM_SMOB (scm_tc16_locale_smob_type, "locale", 0);
225
226SCM_SMOB_FREE (scm_tc16_locale_smob_type, smob_locale_free, locale)
227{
228 scm_t_locale c_locale;
229
a2f00b9b
LC		 230 c_locale = (scm_t_locale) SCM_SMOB_DATA (locale);
231 scm_i_locale_free (c_locale);
b89c4943
LC		 232
233 return 0;
234}
235
9361f762 236
a2f00b9b 237static void inline scm_locale_error (const char *, int) SCM_NORETURN;
b89c4943 238
a2f00b9b
LC		 239/* Throw an exception corresponding to error ERR. */
240static void inline
241scm_locale_error (const char *func_name, int err)
242{
243 scm_syserror_msg (func_name,
244 "Failed to install locale",
245 SCM_EOL, err);
b89c4943 246}
b89c4943
LC		 247
248
249\f
a2f00b9b
LC		 250/* Emulating GNU's reentrant locale API. */
251#ifndef USE_GNU_LOCALE_API
b89c4943
LC		 252
253
254/* Maximum number of chained locales (via `base_locale'). */
255#define LOCALE_STACK_SIZE_MAX 256
256
257typedef 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. */
266static int
267get_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)); \
a2f00b9b 274 if (locale_name == NULL) \
b89c4943
LC		 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:
a2f00b9b 288 return EINVAL;
9361f762 289
b89c4943
LC		 290 handle_oom:
291 return ENOMEM;
292}
293
294/* Restore locale settings SETTINGS. On success, return zero. */
295static int
296restore_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:
a2f00b9b 311 return EINVAL;
b89c4943
LC		 312}
313
314/* Free memory associated with SETTINGS. */
315static void
316free_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}
9361f762 324
b89c4943
LC		 325/* Install the locale named LOCALE_NAME for all the categories listed in
326 CATEGORY_MASK. */
327static int
328install_locale_categories (const char *locale_name, int category_mask)
329{
330 const char *result;
9361f762 331
b89c4943 332 if (category_mask == LC_ALL_MASK)
9361f762 333 {
b89c4943
LC		 334 SCM_SYSCALL (result = setlocale (LC_ALL, locale_name));
335 if (result == NULL)
336 goto handle_error;
9361f762
MV		 337 }
338 else
339 {
b89c4943 340#define SCM_DEFINE_LOCALE_CATEGORY(_name) \
a2f00b9b 341 if (category_mask & SCM_LOCALE_CATEGORY_MASK (_name)) \
b89c4943
LC		 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 }
9361f762 350
b89c4943 351 return 0;
9361f762 352
b89c4943 353 handle_error:
a2f00b9b 354 return EINVAL;
b89c4943
LC		 355}
356
357/* Install LOCALE, recursively installing its base locales first. On
358 success, zero is returned. */
359static int
360install_locale (scm_t_locale locale)
361{
362 scm_t_locale stack[LOCALE_STACK_SIZE_MAX];
a2f00b9b 363 int category_mask = 0;
b89c4943
LC		 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
a2f00b9b
LC		 378 /* Keep track of which categories have already been taken into
379 account. */
380 category_mask |= locale->category_mask;
381
b89c4943 382 if (locale->base_locale != SCM_UNDEFINED)
a2f00b9b 383 locale = (scm_t_locale) SCM_SMOB_DATA (locale->base_locale);
9361f762 384 else
b89c4943
LC		 385 locale = NULL;
386 }
a2f00b9b 387 while ((locale != NULL) && (category_mask != LC_ALL_MASK));
9361f762 388
b89c4943
LC		 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;
9361f762
MV		 407 }
408
b89c4943 409 return 0;
9361f762 410
b89c4943 411 handle_error:
a2f00b9b 412 return EINVAL;
9361f762 413}
9361f762 414
b89c4943
LC		 415/* Leave the locked locale section. */
416static inline void
417leave_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}
9361f762 424
b89c4943
LC		 425/* Enter a locked locale section. */
426static inline int
427enter_locale_section (scm_t_locale locale,
428 scm_t_locale_settings *prev_locale)
9361f762 429{
b89c4943
LC		 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 }
9361f762 440
b89c4943
LC		 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
b89c4943
LC		 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
a2f00b9b
LC		 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. */
474static int
475get_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
5b878445 509#else /* USE_GNU_LOCALE_API */
a2f00b9b 510
5b878445 511/* Convenient macro to run STATEMENT in the locale context of C_LOCALE. */
12f0c3e5
LC		 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 } \
5b878445
MG		 521 while (0)
522
523
524#endif /* USE_GNU_LOCALE_API */
9361f762 525
a2f00b9b
LC		 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). */
536static inline int
537category_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. */
570static int
571category_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
592SCM_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);
a2f00b9b
LC		 688
689 if (err)
690 goto fail;
691 else
1445e449
LC		 692 {
693 leave_locale_section (&prev_locale);
694 SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale);
695 }
a2f00b9b
LC		 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
713SCM_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
b89c4943 723\f
a2f00b9b
LC		 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
df047aa2
LC		 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 = (scm_t_wchar *) 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. */
b89c4943 752static inline int
5b878445 753compare_u32_strings (SCM s1, SCM s2, SCM locale, const char *func_name)
b89c4943
LC		 754#define FUNC_NAME func_name
755{
756 int result;
757 scm_t_locale c_locale;
5b878445
MG		 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_strcmp ((const scm_t_uint32 *) c_s1,
770 (const scm_t_uint32 *) c_s2);
771
5b878445
MG		 772 scm_remember_upto_here_2 (s1, s2);
773 scm_remember_upto_here (locale);
774 return result;
775}
776#undef FUNC_NAME
777
778static inline int
779u32_locale_casecoll (const char *func_name, const scm_t_uint32 *c_s1,
780 const scm_t_uint32 *c_s2)
781{
782 int result, ret;
783 const char *loc = uc_locale_language ();
784
785
786 ret = u32_casecoll (c_s1, u32_strlen (c_s1),
787 c_s2, u32_strlen (c_s2),
788 loc, UNINORM_NFC, &result);
789 if (ret != 0)
790 scm_syserror (func_name);
791
792 return result;
793}
794
795static inline int
796compare_u32_strings_ci (SCM s1, SCM s2, SCM locale, const char *func_name)
797#define FUNC_NAME func_name
798{
799 int ret, result;
800 scm_t_locale c_locale;
801 scm_t_wchar *c_s1, *c_s2;
b89c4943 802 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale);
9361f762 803
5b878445
MG		 804 SCM_STRING_TO_U32_BUF (s1, c_s1);
805 SCM_STRING_TO_U32_BUF (s2, c_s2);
806
b89c4943 807 if (c_locale)
5b878445
MG		 808 RUN_IN_LOCALE_SECTION
809 (c_locale,
810 result = u32_locale_casecoll (func_name,
811 (const scm_t_uint32 *) c_s1,
812 (const scm_t_uint32 *) c_s2)
813 );
814 else
9361f762 815 {
5b878445
MG		 816 /* Passing NULL to u32_casecmp to do the default,
817 language-independent case folding. */
818 ret = u32_casecmp ((const scm_t_uint32 *) c_s1,
819 u32_strlen ((const scm_t_uint32 *) c_s1),
820 (const scm_t_uint32 *) c_s2,
821 u32_strlen ((const scm_t_uint32 *) c_s2),
822 NULL, UNINORM_NFC, &result);
823 if (ret != 0)
824 scm_syserror (func_name);
9361f762 825 }
b89c4943 826
5b878445
MG		 827 scm_remember_upto_here_2 (s1, s2);
828 scm_remember_upto_here (locale);
b89c4943
LC		 829
830 return result;
831}
832#undef FUNC_NAME
833
834/* Store into DST an upper-case version of SRC. */
835static inline void
836str_upcase (register char *dst, register const char *src)
837{
838 for (; *src != '\0'; src++, dst++)
4e641322 839 *dst = toupper ((int) *src);
b89c4943
LC		 840 *dst = '\0';
841}
842
843static inline void
844str_downcase (register char *dst, register const char *src)
845{
846 for (; *src != '\0'; src++, dst++)
4e641322 847 *dst = tolower ((int) *src);
b89c4943
LC		 848 *dst = '\0';
849}
850
851#ifdef USE_GNU_LOCALE_API
852static inline void
853str_upcase_l (register char *dst, register const char *src,
854 scm_t_locale locale)
855{
856 for (; *src != '\0'; src++, dst++)
857 *dst = toupper_l (*src, locale);
858 *dst = '\0';
859}
860
861static inline void
862str_downcase_l (register char *dst, register const char *src,
863 scm_t_locale locale)
864{
865 for (; *src != '\0'; src++, dst++)
866 *dst = tolower_l (*src, locale);
867 *dst = '\0';
868}
869#endif
870
871
b89c4943
LC		 872SCM_DEFINE (scm_string_locale_lt, "string-locale<?", 2, 1, 0,
873 (SCM s1, SCM s2, SCM locale),
874 "Compare strings @var{s1} and @var{s2} in a locale-dependent way."
875 "If @var{locale} is provided, it should be locale object (as "
876 "returned by @code{make-locale}) and will be used to perform the "
877 "comparison; otherwise, the current system locale is used.")
878#define FUNC_NAME s_scm_string_locale_lt
9361f762 879{
b89c4943 880 int result;
9361f762 881
b89c4943
LC		 882 SCM_VALIDATE_STRING (1, s1);
883 SCM_VALIDATE_STRING (2, s2);
9361f762 884
5b878445 885 result = compare_u32_strings (s1, s2, locale, FUNC_NAME);
b89c4943
LC		 886
887 return scm_from_bool (result < 0);
888}
889#undef FUNC_NAME
890
891SCM_DEFINE (scm_string_locale_gt, "string-locale>?", 2, 1, 0,
892 (SCM s1, SCM s2, SCM locale),
893 "Compare strings @var{s1} and @var{s2} in a locale-dependent way."
894 "If @var{locale} is provided, it should be locale object (as "
895 "returned by @code{make-locale}) and will be used to perform the "
896 "comparison; otherwise, the current system locale is used.")
897#define FUNC_NAME s_scm_string_locale_gt
898{
899 int result;
b89c4943
LC		 900
901 SCM_VALIDATE_STRING (1, s1);
902 SCM_VALIDATE_STRING (2, s2);
903
5b878445 904 result = compare_u32_strings (s1, s2, locale, FUNC_NAME);
b89c4943
LC		 905
906 return scm_from_bool (result > 0);
907}
908#undef FUNC_NAME
909
910SCM_DEFINE (scm_string_locale_ci_lt, "string-locale-ci<?", 2, 1, 0,
911 (SCM s1, SCM s2, SCM locale),
912 "Compare strings @var{s1} and @var{s2} in a case-insensitive, "
913 "and locale-dependent way. If @var{locale} is provided, it "
914 "should be locale object (as returned by @code{make-locale}) "
915 "and will be used to perform the comparison; otherwise, the "
916 "current system locale is used.")
917#define FUNC_NAME s_scm_string_locale_ci_lt
918{
919 int result;
b89c4943
LC		 920
921 SCM_VALIDATE_STRING (1, s1);
922 SCM_VALIDATE_STRING (2, s2);
923
5b878445 924 result = compare_u32_strings_ci (s1, s2, locale, FUNC_NAME);
b89c4943
LC		 925
926 return scm_from_bool (result < 0);
927}
928#undef FUNC_NAME
929
930SCM_DEFINE (scm_string_locale_ci_gt, "string-locale-ci>?", 2, 1, 0,
931 (SCM s1, SCM s2, SCM locale),
932 "Compare strings @var{s1} and @var{s2} in a case-insensitive, "
933 "and locale-dependent way. If @var{locale} is provided, it "
934 "should be locale object (as returned by @code{make-locale}) "
935 "and will be used to perform the comparison; otherwise, the "
936 "current system locale is used.")
937#define FUNC_NAME s_scm_string_locale_ci_gt
938{
939 int result;
b89c4943
LC		 940
941 SCM_VALIDATE_STRING (1, s1);
942 SCM_VALIDATE_STRING (2, s2);
943
5b878445 944 result = compare_u32_strings_ci (s1, s2, locale, FUNC_NAME);
b89c4943
LC		 945
946 return scm_from_bool (result > 0);
947}
948#undef FUNC_NAME
949
950SCM_DEFINE (scm_string_locale_ci_eq, "string-locale-ci=?", 2, 1, 0,
951 (SCM s1, SCM s2, SCM locale),
952 "Compare strings @var{s1} and @var{s2} in a case-insensitive, "
953 "and locale-dependent way. If @var{locale} is provided, it "
954 "should be locale object (as returned by @code{make-locale}) "
955 "and will be used to perform the comparison; otherwise, the "
956 "current system locale is used.")
957#define FUNC_NAME s_scm_string_locale_ci_eq
958{
959 int result;
b89c4943
LC		 960
961 SCM_VALIDATE_STRING (1, s1);
962 SCM_VALIDATE_STRING (2, s2);
963
5b878445 964 result = compare_u32_strings_ci (s1, s2, locale, FUNC_NAME);
b89c4943
LC		 965
966 return scm_from_bool (result == 0);
967}
968#undef FUNC_NAME
969
970
971SCM_DEFINE (scm_char_locale_lt, "char-locale<?", 2, 1, 0,
972 (SCM c1, SCM c2, SCM locale),
973 "Return true if character @var{c1} is lower than @var{c2} "
974 "according to @var{locale} or to the current locale.")
975#define FUNC_NAME s_scm_char_locale_lt
976{
5b878445 977 int result;
b89c4943
LC		 978
979 SCM_VALIDATE_CHAR (1, c1);
980 SCM_VALIDATE_CHAR (2, c2);
981
5b878445
MG		 982 result = compare_u32_strings (scm_string (scm_list_1 (c1)),
983 scm_string (scm_list_1 (c2)),
984 locale, FUNC_NAME);
b89c4943 985
5b878445 986 return scm_from_bool (result < 0);
b89c4943
LC		 987}
988#undef FUNC_NAME
989
990SCM_DEFINE (scm_char_locale_gt, "char-locale>?", 2, 1, 0,
991 (SCM c1, SCM c2, SCM locale),
992 "Return true if character @var{c1} is greater than @var{c2} "
993 "according to @var{locale} or to the current locale.")
994#define FUNC_NAME s_scm_char_locale_gt
995{
5b878445 996 int result;
b89c4943
LC		 997
998 SCM_VALIDATE_CHAR (1, c1);
999 SCM_VALIDATE_CHAR (2, c2);
1000
5b878445
MG		 1001 result = compare_u32_strings (scm_string (scm_list_1 (c1)),
1002 scm_string (scm_list_1 (c2)),
1003 locale, FUNC_NAME);
b89c4943 1004
5b878445 1005 return scm_from_bool (result > 0);
b89c4943
LC		 1006}
1007#undef FUNC_NAME
1008
1009SCM_DEFINE (scm_char_locale_ci_lt, "char-locale-ci<?", 2, 1, 0,
1010 (SCM c1, SCM c2, SCM locale),
1011 "Return true if character @var{c1} is lower than @var{c2}, "
1012 "in a case insensitive way according to @var{locale} or to "
1013 "the current locale.")
1014#define FUNC_NAME s_scm_char_locale_ci_lt
1015{
1016 int result;
b89c4943
LC		 1017
1018 SCM_VALIDATE_CHAR (1, c1);
1019 SCM_VALIDATE_CHAR (2, c2);
1020
5b878445
MG		 1021 result = compare_u32_strings_ci (scm_string (scm_list_1 (c1)),
1022 scm_string (scm_list_1 (c2)),
1023 locale, FUNC_NAME);
b89c4943
LC		 1024
1025 return scm_from_bool (result < 0);
1026}
1027#undef FUNC_NAME
1028
1029SCM_DEFINE (scm_char_locale_ci_gt, "char-locale-ci>?", 2, 1, 0,
1030 (SCM c1, SCM c2, SCM locale),
1031 "Return true if character @var{c1} is greater than @var{c2}, "
1032 "in a case insensitive way according to @var{locale} or to "
1033 "the current locale.")
1034#define FUNC_NAME s_scm_char_locale_ci_gt
1035{
1036 int result;
b89c4943
LC		 1037
1038 SCM_VALIDATE_CHAR (1, c1);
1039 SCM_VALIDATE_CHAR (2, c2);
1040
5b878445
MG		 1041 result = compare_u32_strings_ci (scm_string (scm_list_1 (c1)),
1042 scm_string (scm_list_1 (c2)),
1043 locale, FUNC_NAME);
b89c4943
LC		 1044
1045 return scm_from_bool (result > 0);
1046}
1047#undef FUNC_NAME
1048
1049SCM_DEFINE (scm_char_locale_ci_eq, "char-locale-ci=?", 2, 1, 0,
1050 (SCM c1, SCM c2, SCM locale),
1051 "Return true if character @var{c1} is equal to @var{c2}, "
1052 "in a case insensitive way according to @var{locale} or to "
1053 "the current locale.")
1054#define FUNC_NAME s_scm_char_locale_ci_eq
1055{
1056 int result;
b89c4943
LC		 1057
1058 SCM_VALIDATE_CHAR (1, c1);
1059 SCM_VALIDATE_CHAR (2, c2);
1060
5b878445
MG		 1061 result = compare_u32_strings_ci (scm_string (scm_list_1 (c1)),
1062 scm_string (scm_list_1 (c2)),
1063 locale, FUNC_NAME);
b89c4943
LC		 1064
1065 return scm_from_bool (result == 0);
1066}
1067#undef FUNC_NAME
1068
1069
1070\f
1071/* Locale-dependent alphabetic character mapping. */
1072
1073SCM_DEFINE (scm_char_locale_downcase, "char-locale-downcase", 1, 1, 0,
1074 (SCM chr, SCM locale),
1075 "Return the lowercase character that corresponds to @var{chr} "
1076 "according to either @var{locale} or the current locale.")
1077#define FUNC_NAME s_scm_char_locale_downcase
1078{
1079 char c_chr;
1080 int c_result;
1081 scm_t_locale c_locale;
1082
1083 SCM_VALIDATE_CHAR (1, chr);
1084 c_chr = SCM_CHAR (chr);
1085
1086 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
1087
1088 if (c_locale != NULL)
9361f762 1089 {
b89c4943 1090#ifdef USE_GNU_LOCALE_API
4e641322 1091 c_result = tolower_l ((int) c_chr, c_locale);
b89c4943 1092#else
4e641322 1093 RUN_IN_LOCALE_SECTION (c_locale, c_result = tolower ((int) c_chr));
b89c4943 1094#endif
9361f762 1095 }
b89c4943 1096 else
4e641322 1097 c_result = tolower ((int) c_chr);
9361f762 1098
b89c4943 1099 return (SCM_MAKE_CHAR (c_result));
9361f762
MV		 1100}
1101#undef FUNC_NAME
1102
b89c4943
LC		 1103SCM_DEFINE (scm_char_locale_upcase, "char-locale-upcase", 1, 1, 0,
1104 (SCM chr, SCM locale),
1105 "Return the uppercase character that corresponds to @var{chr} "
1106 "according to either @var{locale} or the current locale.")
1107#define FUNC_NAME s_scm_char_locale_upcase
9361f762 1108{
b89c4943
LC		 1109 char c_chr;
1110 int c_result;
1111 scm_t_locale c_locale;
1112
1113 SCM_VALIDATE_CHAR (1, chr);
1114 c_chr = SCM_CHAR (chr);
9361f762 1115
b89c4943 1116 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
9361f762 1117
b89c4943
LC		 1118 if (c_locale != NULL)
1119 {
1120#ifdef USE_GNU_LOCALE_API
4e641322 1121 c_result = toupper_l ((int) c_chr, c_locale);
b89c4943 1122#else
4e641322 1123 RUN_IN_LOCALE_SECTION (c_locale, c_result = toupper ((int) c_chr));
b89c4943
LC		 1124#endif
1125 }
9361f762 1126 else
4e641322 1127 c_result = toupper ((int) c_chr);
b89c4943
LC		 1128
1129 return (SCM_MAKE_CHAR (c_result));
1130}
1131#undef FUNC_NAME
1132
1133SCM_DEFINE (scm_string_locale_upcase, "string-locale-upcase", 1, 1, 0,
1134 (SCM str, SCM locale),
1135 "Return a new string that is the uppercase version of "
1136 "@var{str} according to either @var{locale} or the current "
1137 "locale.")
1138#define FUNC_NAME s_scm_string_locale_upcase
1139{
1140 const char *c_str;
1141 char *c_ustr;
1142 scm_t_locale c_locale;
1143
1144 SCM_VALIDATE_STRING (1, str);
1145 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
1146
1147 c_str = scm_i_string_chars (str);
1148 c_ustr = (char *) alloca (strlen (c_str) + 1);
1149
1150 if (c_locale)
9361f762 1151 {
b89c4943
LC		 1152#ifdef USE_GNU_LOCALE_API
1153 str_upcase_l (c_ustr, c_str, c_locale);
1154#else
1155 RUN_IN_LOCALE_SECTION (c_locale, str_upcase (c_ustr, c_str));
1156#endif
9361f762 1157 }
b89c4943
LC		 1158 else
1159 str_upcase (c_ustr, c_str);
1160
1161 scm_remember_upto_here (str);
1162
1163 return (scm_from_locale_string (c_ustr));
1164}
1165#undef FUNC_NAME
9361f762 1166
b89c4943
LC		 1167SCM_DEFINE (scm_string_locale_downcase, "string-locale-downcase", 1, 1, 0,
1168 (SCM str, SCM locale),
1169 "Return a new string that is the down-case version of "
1170 "@var{str} according to either @var{locale} or the current "
1171 "locale.")
1172#define FUNC_NAME s_scm_string_locale_downcase
1173{
1174 const char *c_str;
1175 char *c_lstr;
1176 scm_t_locale c_locale;
1177
1178 SCM_VALIDATE_STRING (1, str);
1179 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
9361f762 1180
b89c4943
LC		 1181 c_str = scm_i_string_chars (str);
1182 c_lstr = (char *) alloca (strlen (c_str) + 1);
9361f762 1183
b89c4943
LC		 1184 if (c_locale)
1185 {
1186#ifdef USE_GNU_LOCALE_API
1187 str_downcase_l (c_lstr, c_str, c_locale);
1188#else
1189 RUN_IN_LOCALE_SECTION (c_locale, str_downcase (c_lstr, c_str));
1190#endif
1191 }
9361f762 1192 else
b89c4943 1193 str_downcase (c_lstr, c_str);
9361f762 1194
b89c4943
LC		 1195 scm_remember_upto_here (str);
1196
1197 return (scm_from_locale_string (c_lstr));
9361f762
MV		 1198}
1199#undef FUNC_NAME
1200
b89c4943
LC		 1201/* Note: We don't provide mutative versions of `string-locale-(up|down)case'
1202 because, in some languages, a single downcase character maps to a couple
1203 of uppercase characters. Read the SRFI-13 document for a detailed
1204 discussion about this. */
1205
1206
1207\f
1208/* Locale-dependent number parsing. */
1209
1210SCM_DEFINE (scm_locale_string_to_integer, "locale-string->integer",
1211 1, 2, 0, (SCM str, SCM base, SCM locale),
1212 "Convert string @var{str} into an integer according to either "
1213 "@var{locale} (a locale object as returned by @code{make-locale}) "
1214 "or the current process locale. Return two values: an integer "
1215 "(on success) or @code{#f}, and the number of characters read "
1216 "from @var{str} (@code{0} on failure).")
1217#define FUNC_NAME s_scm_locale_string_to_integer
9361f762 1218{
9361f762 1219 SCM result;
b89c4943
LC		 1220 long c_result;
1221 int c_base;
1222 const char *c_str;
1223 char *c_endptr;
1224 scm_t_locale c_locale;
9361f762 1225
b89c4943
LC		 1226 SCM_VALIDATE_STRING (1, str);
1227 c_str = scm_i_string_chars (str);
9361f762 1228
b89c4943
LC		 1229 if (base != SCM_UNDEFINED)
1230 SCM_VALIDATE_INT_COPY (2, base, c_base);
9361f762 1231 else
b89c4943
LC		 1232 c_base = 10;
1233
1234 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale);
1235
1236 if (c_locale != NULL)
9361f762 1237 {
b89c4943
LC		 1238#ifdef USE_GNU_LOCALE_API
1239 c_result = strtol_l (c_str, &c_endptr, c_base, c_locale);
1240#else
1241 RUN_IN_LOCALE_SECTION (c_locale,
1242 c_result = strtol (c_str, &c_endptr, c_base));
1243#endif
9361f762 1244 }
b89c4943
LC		 1245 else
1246 c_result = strtol (c_str, &c_endptr, c_base);
1247
1248 scm_remember_upto_here (str);
1249
1250 if (c_endptr == c_str)
1251 result = SCM_BOOL_F;
1252 else
1253 result = scm_from_long (c_result);
1254
1255 return (scm_values (scm_list_2 (result, scm_from_long (c_endptr - c_str))));
1256}
1257#undef FUNC_NAME
1258
1259SCM_DEFINE (scm_locale_string_to_inexact, "locale-string->inexact",
1260 1, 1, 0, (SCM str, SCM locale),
1261 "Convert string @var{str} into an inexact number according to "
1262 "either @var{locale} (a locale object as returned by "
1263 "@code{make-locale}) or the current process locale. Return "
1264 "two values: an inexact number (on success) or @code{#f}, and "
1265 "the number of characters read from @var{str} (@code{0} on "
1266 "failure).")
1267#define FUNC_NAME s_scm_locale_string_to_inexact
1268{
1269 SCM result;
1270 double c_result;
1271 const char *c_str;
1272 char *c_endptr;
1273 scm_t_locale c_locale;
9361f762 1274
b89c4943
LC		 1275 SCM_VALIDATE_STRING (1, str);
1276 c_str = scm_i_string_chars (str);
9361f762 1277
b89c4943 1278 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
9361f762 1279
b89c4943
LC		 1280 if (c_locale != NULL)
1281 {
1282#ifdef USE_GNU_LOCALE_API
1283 c_result = strtod_l (c_str, &c_endptr, c_locale);
1284#else
1285 RUN_IN_LOCALE_SECTION (c_locale,
1286 c_result = strtod (c_str, &c_endptr));
1287#endif
1288 }
9361f762 1289 else
b89c4943
LC		 1290 c_result = strtod (c_str, &c_endptr);
1291
1292 scm_remember_upto_here (str);
1293
1294 if (c_endptr == c_str)
9361f762 1295 result = SCM_BOOL_F;
b89c4943
LC		 1296 else
1297 result = scm_from_double (c_result);
9361f762 1298
b89c4943 1299 return (scm_values (scm_list_2 (result, scm_from_long (c_endptr - c_str))));
9361f762
MV		 1300}
1301#undef FUNC_NAME
1302
b89c4943 1303\f
a2f00b9b
LC		 1304/* Language information, aka. `nl_langinfo ()'. */
1305
1306/* FIXME: Issues related to `nl-langinfo'.
1307
1308 1. The `CODESET' value is not normalized. This is a secondary issue, but
1309 still a practical issue. See
1310 http://www.cl.cam.ac.uk/~mgk25/ucs/norm_charmap.c for codeset
1311 normalization.
1312
1313 2. `nl_langinfo ()' is not available on Windows.
1314
1315 3. `nl_langinfo ()' may return strings encoded in a locale different from
1316 the current one, thereby defeating `scm_from_locale_string ()'.
1317 Example: support the current locale is "Latin-1" and one asks:
1318
1319 (nl-langinfo DAY_1 (make-locale LC_ALL "eo_EO.UTF-8"))
1320
1321 The result will be a UTF-8 string. However, `scm_from_locale_string',
1322 which expects a Latin-1 string, won't be able to make much sense of the
1323 returned string. Thus, we'd need an `scm_from_string ()' variant where
1324 the locale (or charset) is explicitly passed. */
1325
1326
1327SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
1328 (SCM item, SCM locale),
1329 "Return a string denoting locale information for @var{item} "
1330 "in the current locale or that specified by @var{locale}. "
1331 "The semantics and arguments are the same as those of the "
1332 "X/Open @code{nl_langinfo} function (@pxref{The Elegant and "
1333 "Fast Way, @code{nl_langinfo},, libc, The GNU C Library "
1334 "Reference Manual}).")
1335#define FUNC_NAME s_scm_nl_langinfo
1336{
1337#ifdef HAVE_NL_LANGINFO
1338 SCM result;
1339 nl_item c_item;
1340 char *c_result;
1341 scm_t_locale c_locale;
1342
1343 SCM_VALIDATE_INT_COPY (2, item, c_item);
1344 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
1345
1346 /* Sadly, `nl_langinfo ()' returns a pointer to a static string. According
1347 to SuS v2, that static string may be modified by subsequent calls to
1348 `nl_langinfo ()' as well as by calls to `setlocale ()'. Thus, we must
1349 acquire the locale mutex before doing invoking `nl_langinfo ()'. See
1350 http://opengroup.org/onlinepubs/007908799/xsh/nl_langinfo.html for
1351 details. */
1352
1353 scm_i_pthread_mutex_lock (&scm_i_locale_mutex);
1354 if (c_locale != NULL)
1355 {
1356#ifdef USE_GNU_LOCALE_API
1357 c_result = nl_langinfo_l (c_item, c_locale);
1358#else
1359 /* We can't use `RUN_IN_LOCALE_SECTION ()' here because the locale
1360 mutex is already taken. */
1361 int lsec_err;
1362 scm_t_locale_settings lsec_prev_locale;
1363
1364 lsec_err = get_current_locale_settings (&lsec_prev_locale);
1365 if (lsec_err)
1366 scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
1367 else
1368 {
1369 lsec_err = install_locale (c_locale);
1370 if (lsec_err)
1371 {
1372 leave_locale_section (&lsec_prev_locale);
1373 free_locale_settings (&lsec_prev_locale);
1374 }
1375 }
1376
1377 if (lsec_err)
1378 scm_locale_error (FUNC_NAME, lsec_err);
1379 else
1380 {
1381 c_result = nl_langinfo (c_item);
1382
1445e449 1383 restore_locale_settings (&lsec_prev_locale);
a2f00b9b
LC		 1384 free_locale_settings (&lsec_prev_locale);
1385 }
1386#endif
1387 }
1388 else
1389 c_result = nl_langinfo (c_item);
1390
1391 c_result = strdup (c_result);
1392 scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
1393
1394 if (c_result == NULL)
1395 result = SCM_BOOL_F;
1396 else
1397 {
a2f00b9b
LC		 1398 switch (c_item)
1399 {
afb49959 1400#if (defined GROUPING) && (defined MON_GROUPING)
a2f00b9b
LC		 1401 case GROUPING:
1402 case MON_GROUPING:
a2f00b9b 1403 {
afb49959 1404 char *p;
a2f00b9b 1405
afb49959
LC		 1406 /* In this cases, the result is to be interpreted as a list of
1407 numbers. If the last item is `CHARS_MAX', it has the special
1408 meaning "no more grouping". */
1409 result = SCM_EOL;
1410 for (p = c_result; (*p != '\0') && (*p != CHAR_MAX); p++)
1411 result = scm_cons (SCM_I_MAKINUM ((int) *p), result);
a2f00b9b 1412
afb49959
LC		 1413 {
1414 SCM last_pair = result;
a2f00b9b 1415
afb49959
LC		 1416 result = scm_reverse_x (result, SCM_EOL);
1417
1418 if (*p != CHAR_MAX)
1419 {
1420 /* Cyclic grouping information. */
1421 if (last_pair != SCM_EOL)
1422 SCM_SETCDR (last_pair, result);
1423 }
1424 }
a2f00b9b 1425
afb49959
LC		 1426 free (c_result);
1427 break;
1428 }
1429#endif
1430
1431#if (defined FRAC_DIGITS) && (defined INT_FRAC_DIGITS)
a2f00b9b
LC		 1432 case FRAC_DIGITS:
1433 case INT_FRAC_DIGITS:
1434 /* This is to be interpreted as a single integer. */
1435 if (*c_result == CHAR_MAX)
1436 /* Unspecified. */
1437 result = SCM_BOOL_F;
1438 else
1439 result = SCM_I_MAKINUM (*c_result);
1440
1441 free (c_result);
1442 break;
afb49959 1443#endif
a2f00b9b 1444
afb49959 1445#if (defined P_CS_PRECEDES) && (defined INT_N_CS_PRECEDES)
a2f00b9b
LC		 1446 case P_CS_PRECEDES:
1447 case N_CS_PRECEDES:
1448 case INT_P_CS_PRECEDES:
1449 case INT_N_CS_PRECEDES:
afb49959 1450#if (defined P_SEP_BY_SPACE) && (defined N_SEP_BY_SPACE)
a2f00b9b
LC		 1451 case P_SEP_BY_SPACE:
1452 case N_SEP_BY_SPACE:
afb49959 1453#endif
a2f00b9b
LC		 1454 /* This is to be interpreted as a boolean. */
1455 result = scm_from_bool (*c_result);
1456
1457 free (c_result);
1458 break;
afb49959 1459#endif
a2f00b9b 1460
afb49959 1461#if (defined P_SIGN_POSN) && (defined INT_N_SIGN_POSN)
a2f00b9b
LC		 1462 case P_SIGN_POSN:
1463 case N_SIGN_POSN:
1464 case INT_P_SIGN_POSN:
1465 case INT_N_SIGN_POSN:
1466 /* See `(libc) Sign of Money Amount' for the interpretation of the
1467 return value here. */
1468 switch (*c_result)
1469 {
1470 case 0:
1471 result = scm_from_locale_symbol ("parenthesize");
1472 break;
1473
1474 case 1:
1475 result = scm_from_locale_symbol ("sign-before");
1476 break;
1477
1478 case 2:
1479 result = scm_from_locale_symbol ("sign-after");
1480 break;
1481
1482 case 3:
1483 result = scm_from_locale_symbol ("sign-before-currency-symbol");
1484 break;
1485
1486 case 4:
1487 result = scm_from_locale_symbol ("sign-after-currency-symbol");
1488 break;
1489
1490 default:
1491 result = scm_from_locale_symbol ("unspecified");
1492 }
1493 break;
afb49959 1494#endif
a2f00b9b
LC		 1495
1496 default:
1497 /* FIXME: `locale_string ()' is not appropriate here because of
1498 encoding issues (see comment above). */
1499 result = scm_take_locale_string (c_result);
1500 }
1501 }
1502
1503 return result;
1504#else
1505 scm_syserror_msg (FUNC_NAME, "`nl-langinfo' not supported on your system",
1506 SCM_EOL, ENOSYS);
1507
1508 return SCM_BOOL_F;
1509#endif
1510}
1511#undef FUNC_NAME
1512
1513/* Define the `nl_item' constants. */
1514static inline void
1515define_langinfo_items (void)
9361f762 1516{
a2f00b9b
LC		 1517#if (defined HAVE_NL_TYPES_H) && (defined HAVE_LANGINFO_H)
1518
1519#define DEFINE_NLITEM_CONSTANT(_item) \
1520 scm_c_define (# _item, scm_from_int (_item))
1521
1522 DEFINE_NLITEM_CONSTANT (CODESET);
1523
1524 /* Abbreviated days of the week. */
1525 DEFINE_NLITEM_CONSTANT (ABDAY_1);
1526 DEFINE_NLITEM_CONSTANT (ABDAY_2);
1527 DEFINE_NLITEM_CONSTANT (ABDAY_3);
1528 DEFINE_NLITEM_CONSTANT (ABDAY_4);
1529 DEFINE_NLITEM_CONSTANT (ABDAY_5);
1530 DEFINE_NLITEM_CONSTANT (ABDAY_6);
1531 DEFINE_NLITEM_CONSTANT (ABDAY_7);
1532
1533 /* Long-named days of the week. */
1534 DEFINE_NLITEM_CONSTANT (DAY_1); /* Sunday */
1535 DEFINE_NLITEM_CONSTANT (DAY_2); /* Monday */
1536 DEFINE_NLITEM_CONSTANT (DAY_3); /* Tuesday */
1537 DEFINE_NLITEM_CONSTANT (DAY_4); /* Wednesday */
1538 DEFINE_NLITEM_CONSTANT (DAY_5); /* Thursday */
1539 DEFINE_NLITEM_CONSTANT (DAY_6); /* Friday */
1540 DEFINE_NLITEM_CONSTANT (DAY_7); /* Saturday */
1541
1542 /* Abbreviated month names. */
1543 DEFINE_NLITEM_CONSTANT (ABMON_1); /* Jan */
1544 DEFINE_NLITEM_CONSTANT (ABMON_2);
1545 DEFINE_NLITEM_CONSTANT (ABMON_3);
1546 DEFINE_NLITEM_CONSTANT (ABMON_4);
1547 DEFINE_NLITEM_CONSTANT (ABMON_5);
1548 DEFINE_NLITEM_CONSTANT (ABMON_6);
1549 DEFINE_NLITEM_CONSTANT (ABMON_7);
1550 DEFINE_NLITEM_CONSTANT (ABMON_8);
1551 DEFINE_NLITEM_CONSTANT (ABMON_9);
1552 DEFINE_NLITEM_CONSTANT (ABMON_10);
1553 DEFINE_NLITEM_CONSTANT (ABMON_11);
1554 DEFINE_NLITEM_CONSTANT (ABMON_12);
1555
1556 /* Long month names. */
1557 DEFINE_NLITEM_CONSTANT (MON_1); /* January */
1558 DEFINE_NLITEM_CONSTANT (MON_2);
1559 DEFINE_NLITEM_CONSTANT (MON_3);
1560 DEFINE_NLITEM_CONSTANT (MON_4);
1561 DEFINE_NLITEM_CONSTANT (MON_5);
1562 DEFINE_NLITEM_CONSTANT (MON_6);
1563 DEFINE_NLITEM_CONSTANT (MON_7);
1564 DEFINE_NLITEM_CONSTANT (MON_8);
1565 DEFINE_NLITEM_CONSTANT (MON_9);
1566 DEFINE_NLITEM_CONSTANT (MON_10);
1567 DEFINE_NLITEM_CONSTANT (MON_11);
1568 DEFINE_NLITEM_CONSTANT (MON_12);
1569
1570 DEFINE_NLITEM_CONSTANT (AM_STR); /* Ante meridiem string. */
1571 DEFINE_NLITEM_CONSTANT (PM_STR); /* Post meridiem string. */
1572
1573 DEFINE_NLITEM_CONSTANT (D_T_FMT); /* Date and time format for strftime. */
1574 DEFINE_NLITEM_CONSTANT (D_FMT); /* Date format for strftime. */
1575 DEFINE_NLITEM_CONSTANT (T_FMT); /* Time format for strftime. */
1576 DEFINE_NLITEM_CONSTANT (T_FMT_AMPM);/* 12-hour time format for strftime. */
1577
1578 DEFINE_NLITEM_CONSTANT (ERA); /* Alternate era. */
1579 DEFINE_NLITEM_CONSTANT (ERA_D_FMT); /* Date in alternate era format. */
1580 DEFINE_NLITEM_CONSTANT (ERA_D_T_FMT); /* Date and time in alternate era
1581 format. */
1582 DEFINE_NLITEM_CONSTANT (ERA_T_FMT); /* Time in alternate era format. */
1583
1584 DEFINE_NLITEM_CONSTANT (ALT_DIGITS); /* Alternate symbols for digits. */
1585 DEFINE_NLITEM_CONSTANT (RADIXCHAR);
1586 DEFINE_NLITEM_CONSTANT (THOUSEP);
1587
1588#ifdef YESEXPR
1589 DEFINE_NLITEM_CONSTANT (YESEXPR);
1590#endif
1591#ifdef NOEXPR
1592 DEFINE_NLITEM_CONSTANT (NOEXPR);
1593#endif
b89c4943 1594
a2f00b9b
LC		 1595#ifdef CRNCYSTR /* currency symbol */
1596 DEFINE_NLITEM_CONSTANT (CRNCYSTR);
1597#endif
b89c4943 1598
a2f00b9b 1599 /* GNU extensions. */
b89c4943 1600
a2f00b9b
LC		 1601#ifdef ERA_YEAR
1602 DEFINE_NLITEM_CONSTANT (ERA_YEAR); /* Year in alternate era format. */
1603#endif
b89c4943 1604
a2f00b9b
LC		 1605 /* LC_MONETARY category: formatting of monetary quantities.
1606 These items each correspond to a member of `struct lconv',
1607 defined in <locale.h>. */
1608#ifdef INT_CURR_SYMBOL
1609 DEFINE_NLITEM_CONSTANT (INT_CURR_SYMBOL);
1610#endif
1611#ifdef MON_DECIMAL_POINT
1612 DEFINE_NLITEM_CONSTANT (MON_DECIMAL_POINT);
1613#endif
1614#ifdef MON_THOUSANDS_SEP
1615 DEFINE_NLITEM_CONSTANT (MON_THOUSANDS_SEP);
1616#endif
1617#ifdef MON_GROUPING
1618 DEFINE_NLITEM_CONSTANT (MON_GROUPING);
1619#endif
1620#ifdef POSITIVE_SIGN
1621 DEFINE_NLITEM_CONSTANT (POSITIVE_SIGN);
1622#endif
1623#ifdef NEGATIVE_SIGN
1624 DEFINE_NLITEM_CONSTANT (NEGATIVE_SIGN);
1625#endif
1626#ifdef GROUPING
1627 DEFINE_NLITEM_CONSTANT (GROUPING);
1628#endif
1629#ifdef INT_FRAC_DIGITS
1630 DEFINE_NLITEM_CONSTANT (INT_FRAC_DIGITS);
1631#endif
1632#ifdef FRAC_DIGITS
1633 DEFINE_NLITEM_CONSTANT (FRAC_DIGITS);
1634#endif
1635#ifdef P_CS_PRECEDES
1636 DEFINE_NLITEM_CONSTANT (P_CS_PRECEDES);
1637#endif
1638#ifdef P_SEP_BY_SPACE
1639 DEFINE_NLITEM_CONSTANT (P_SEP_BY_SPACE);
1640#endif
1641#ifdef N_CS_PRECEDES
1642 DEFINE_NLITEM_CONSTANT (N_CS_PRECEDES);
1643#endif
1644#ifdef N_SEP_BY_SPACE
1645 DEFINE_NLITEM_CONSTANT (N_SEP_BY_SPACE);
1646#endif
1647#ifdef P_SIGN_POSN
1648 DEFINE_NLITEM_CONSTANT (P_SIGN_POSN);
1649#endif
1650#ifdef N_SIGN_POSN
1651 DEFINE_NLITEM_CONSTANT (N_SIGN_POSN);
1652#endif
1653#ifdef INT_P_CS_PRECEDES
1654 DEFINE_NLITEM_CONSTANT (INT_P_CS_PRECEDES);
1655#endif
1656#ifdef INT_P_SEP_BY_SPACE
1657 DEFINE_NLITEM_CONSTANT (INT_P_SEP_BY_SPACE);
1658#endif
1659#ifdef INT_N_CS_PRECEDES
1660 DEFINE_NLITEM_CONSTANT (INT_N_CS_PRECEDES);
1661#endif
1662#ifdef INT_N_SEP_BY_SPACE
1663 DEFINE_NLITEM_CONSTANT (INT_N_SEP_BY_SPACE);
1664#endif
1665#ifdef INT_P_SIGN_POSN
1666 DEFINE_NLITEM_CONSTANT (INT_P_SIGN_POSN);
1667#endif
1668#ifdef INT_N_SIGN_POSN
1669 DEFINE_NLITEM_CONSTANT (INT_N_SIGN_POSN);
1670#endif
1671
1672#undef DEFINE_NLITEM_CONSTANT
1673
1674#endif /* HAVE_NL_TYPES_H */
1675}
1676
1677\f
1678void
1679scm_init_i18n ()
1680{
1681 SCM global_locale_smob;
1682
1683#ifdef HAVE_NL_LANGINFO
1684 scm_add_feature ("nl-langinfo");
1685 define_langinfo_items ();
1686#endif
b89c4943 1687
9361f762 1688#include "libguile/i18n.x"
b89c4943 1689
a2f00b9b
LC		 1690 /* Initialize the global locale object with a special `locale' SMOB. */
1691 SCM_NEWSMOB (global_locale_smob, scm_tc16_locale_smob_type, NULL);
1692 SCM_VARIABLE_SET (scm_global_locale, global_locale_smob);
9361f762
MV		 1693}
1694
756e8a3a
LC		 1695void
1696scm_bootstrap_i18n ()
1697{
1698 scm_c_register_extension ("libguile", "scm_init_i18n",
1699 (scm_t_extension_init_func) scm_init_i18n,
1700 NULL);
1701
1702}
1703
9361f762
MV		 1704
1705/*
1706 Local Variables:
1707 c-file-style: "gnu"
1708 End:
1709*/
Unnamed repository; edit this file 'description' to name the repository.