HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Add the `%host-type' global variable.
[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
MG		 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 = uselocale (NULL); \
516 if (old_loc != _c_locale) \
517 { \
518 uselocale (_c_locale); \
519 _statement ; \
520 uselocale (old_loc); \
521 } \
522 else \
523 _statement; \
524 } \
525 while (0)
526
527
528#endif /* USE_GNU_LOCALE_API */
9361f762 529
a2f00b9b
LC		 530
531\f
532/* `make-locale' can take either category lists or single categories (the
533 `LC_*' integer constants). */
534#define SCM_LIST_OR_INTEGER_P(arg) \
535 (scm_is_integer (arg) || scm_is_true (scm_list_p (arg)))
536
537
538/* Return the category mask corresponding to CATEGORY (an `LC_' integer
539 constant). */
540static inline int
541category_to_category_mask (SCM category,
542 const char *func_name, int pos)
543{
544 int c_category;
545 int c_category_mask;
546
547 c_category = scm_to_int (category);
548
549#define SCM_DEFINE_LOCALE_CATEGORY(_name) \
550 case LC_ ## _name: \
551 c_category_mask = SCM_LOCALE_CATEGORY_MASK (_name); \
552 break;
553
554 switch (c_category)
555 {
556#include "locale-categories.h"
557
558 case LC_ALL:
559 c_category_mask = LC_ALL_MASK;
560 break;
561
562 default:
563 scm_wrong_type_arg_msg (func_name, pos, category,
564 "locale category");
565 }
566
567#undef SCM_DEFINE_LOCALE_CATEGORY
568
569 return c_category_mask;
570}
571
572/* Convert CATEGORIES, a list of locale categories or a single category (an
573 integer), into a category mask. */
574static int
575category_list_to_category_mask (SCM categories,
576 const char *func_name, int pos)
577{
578 int c_category_mask = 0;
579
580 if (scm_is_integer (categories))
581 c_category_mask = category_to_category_mask (categories,
582 func_name, pos);
583 else
584 for (; !scm_is_null (categories); categories = SCM_CDR (categories))
585 {
586 SCM category = SCM_CAR (categories);
587
588 c_category_mask |=
589 category_to_category_mask (category, func_name, pos);
590 }
591
592 return c_category_mask;
593}
594
595
596SCM_DEFINE (scm_make_locale, "make-locale", 2, 1, 0,
597 (SCM category_list, SCM locale_name, SCM base_locale),
598 "Return a reference to a data structure representing a set of "
599 "locale datasets. @var{category_list} should be either a list "
600 "of locale categories or a single category as used with "
601 "@code{setlocale} (@pxref{Locales, @code{setlocale}}) and "
602 "@var{locale_name} should be the name of the locale considered "
603 "(e.g., @code{\"sl_SI\"}). Optionally, if @code{base_locale} is "
604 "passed, it should be a locale object denoting settings for "
605 "categories not listed in @var{category_list}.")
606#define FUNC_NAME s_scm_make_locale
607{
608 SCM locale = SCM_BOOL_F;
609 int err = 0;
610 int c_category_mask;
611 char *c_locale_name;
612 scm_t_locale c_base_locale, c_locale;
613
614 SCM_MAKE_VALIDATE (1, category_list, LIST_OR_INTEGER_P);
615 SCM_VALIDATE_STRING (2, locale_name);
616 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, base_locale, c_base_locale);
617
618 c_category_mask = category_list_to_category_mask (category_list,
619 FUNC_NAME, 1);
620 c_locale_name = scm_to_locale_string (locale_name);
621
622#ifdef USE_GNU_LOCALE_API
623
624 if (scm_is_eq (base_locale, SCM_VARIABLE_REF (scm_global_locale)))
625 {
626 /* Fetch the current locale and turn in into a `locale_t'. Don't
627 duplicate the resulting `locale_t' because we want it to be consumed
628 by `newlocale ()'. */
629 char *current_locale;
630
631 scm_i_pthread_mutex_lock (&scm_i_locale_mutex);
632
633 current_locale = setlocale (LC_ALL, NULL);
634 c_base_locale = newlocale (LC_ALL_MASK, current_locale, NULL);
635
636 scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
637
638 if (c_base_locale == (locale_t) 0)
639 scm_locale_error (FUNC_NAME, errno);
640 }
641 else if (c_base_locale != (locale_t) 0)
642 {
643 /* C_BASE_LOCALE is to be consumed by `newlocale ()' so it needs to be
644 duplicated before. */
645 c_base_locale = duplocale (c_base_locale);
646 if (c_base_locale == (locale_t) 0)
647 {
648 err = errno;
649 goto fail;
650 }
651 }
652
653 c_locale = newlocale (c_category_mask, c_locale_name, c_base_locale);
654
655 free (c_locale_name);
656
657 if (c_locale == (locale_t) 0)
658 {
659 if (scm_is_eq (base_locale, SCM_VARIABLE_REF (scm_global_locale)))
660 /* The base locale object was created lazily and must be freed. */
661 freelocale (c_base_locale);
662
663 scm_locale_error (FUNC_NAME, errno);
664 }
665 else
666 SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale);
667
668#else
669
670 c_locale = scm_gc_malloc (sizeof (* c_locale), "locale");
671
672 c_locale->category_mask = c_category_mask;
673 c_locale->locale_name = c_locale_name;
674
675 if (scm_is_eq (base_locale, SCM_VARIABLE_REF (scm_global_locale)))
676 {
677 /* Get the current locale settings and turn them into a locale
678 object. */
679 err = get_current_locale (&base_locale);
680 if (err)
681 goto fail;
682 }
683
684 c_locale->base_locale = base_locale;
685
686 {
687 /* Try out the new locale and raise an exception if it doesn't work. */
688 int err;
689 scm_t_locale_settings prev_locale;
690
691 err = enter_locale_section (c_locale, &prev_locale);
a2f00b9b
LC		 692
693 if (err)
694 goto fail;
695 else
1445e449
LC		 696 {
697 leave_locale_section (&prev_locale);
698 SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale);
699 }
a2f00b9b
LC		 700 }
701
702#endif
703
704 return locale;
705
706 fail:
707#ifndef USE_GNU_LOCALE_API
708 scm_gc_free (c_locale, sizeof (* c_locale), "locale");
709#endif
710 free (c_locale_name);
711 scm_locale_error (FUNC_NAME, err);
712
713 return SCM_BOOL_F;
714}
715#undef FUNC_NAME
716
717SCM_DEFINE (scm_locale_p, "locale?", 1, 0, 0,
718 (SCM obj),
719 "Return true if @var{obj} is a locale object.")
720#define FUNC_NAME s_scm_locale_p
721{
722 return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_locale_smob_type, obj));
723}
724#undef FUNC_NAME
725
726
b89c4943 727\f
a2f00b9b
LC		 728/* Locale-dependent string comparison.
729
730 A similar API can be found in MzScheme starting from version 200:
731 http://download.plt-scheme.org/chronology/mzmr200alpha14.html . */
732
5b878445
MG		 733#define SCM_STRING_TO_U32_BUF(s1, c_s1) \
734 do { \
735 if (scm_i_is_narrow_string (s1)) \
736 { \
737 size_t i, len; \
738 const char *buf = scm_i_string_chars (s1); \
739 len = scm_i_string_length (s1); \
740 c_s1 = (scm_t_wchar *) scm_malloc (sizeof (scm_t_wchar) * (len + 1)); \
741 for (i = 0; i < len; i ++) \
742 c_s1[i] = (unsigned char ) buf[i]; \
743 c_s1[len] = 0; \
744 } \
745 else \
746 c_s1 = (scm_t_wchar *) scm_i_string_wide_chars (s1); \
747 } while (0)
748
749#define SCM_U32_BUF_FREE(s1, c_s1) \
750 do { \
751 if (scm_i_is_narrow_string (s1)) \
752 free (c_s1); \
753 } while (0)
754
755
756/* Compare u32 strings according to the LOCALE. Returns a negative
757 value if S1 compares smaller than S2, a positive value if S1
758 compares larger than S2, or 0 if they compare equal. */
b89c4943 759static inline int
5b878445 760compare_u32_strings (SCM s1, SCM s2, SCM locale, const char *func_name)
b89c4943
LC		 761#define FUNC_NAME func_name
762{
763 int result;
764 scm_t_locale c_locale;
5b878445
MG		 765 scm_t_wchar *c_s1, *c_s2;
766 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale);
767
768 SCM_STRING_TO_U32_BUF (s1, c_s1);
769 SCM_STRING_TO_U32_BUF (s2, c_s2);
770
771 if (c_locale)
772 RUN_IN_LOCALE_SECTION (c_locale,
773 result = u32_strcoll ((const scm_t_uint32 *) c_s1,
774 (const scm_t_uint32 *) c_s2));
775 else
776 result = u32_strcmp ((const scm_t_uint32 *) c_s1,
777 (const scm_t_uint32 *) c_s2);
778
779 SCM_U32_BUF_FREE (s1, c_s1);
780 SCM_U32_BUF_FREE (s2, c_s2);
9361f762 781
5b878445
MG		 782 scm_remember_upto_here_2 (s1, s2);
783 scm_remember_upto_here (locale);
784 return result;
785}
786#undef FUNC_NAME
787
788static inline int
789u32_locale_casecoll (const char *func_name, const scm_t_uint32 *c_s1,
790 const scm_t_uint32 *c_s2)
791{
792 int result, ret;
793 const char *loc = uc_locale_language ();
794
795
796 ret = u32_casecoll (c_s1, u32_strlen (c_s1),
797 c_s2, u32_strlen (c_s2),
798 loc, UNINORM_NFC, &result);
799 if (ret != 0)
800 scm_syserror (func_name);
801
802 return result;
803}
804
805static inline int
806compare_u32_strings_ci (SCM s1, SCM s2, SCM locale, const char *func_name)
807#define FUNC_NAME func_name
808{
809 int ret, result;
810 scm_t_locale c_locale;
811 scm_t_wchar *c_s1, *c_s2;
b89c4943 812 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale);
9361f762 813
5b878445
MG		 814 SCM_STRING_TO_U32_BUF (s1, c_s1);
815 SCM_STRING_TO_U32_BUF (s2, c_s2);
816
b89c4943 817 if (c_locale)
5b878445
MG		 818 RUN_IN_LOCALE_SECTION
819 (c_locale,
820 result = u32_locale_casecoll (func_name,
821 (const scm_t_uint32 *) c_s1,
822 (const scm_t_uint32 *) c_s2)
823 );
824 else
9361f762 825 {
5b878445
MG		 826 /* Passing NULL to u32_casecmp to do the default,
827 language-independent case folding. */
828 ret = u32_casecmp ((const scm_t_uint32 *) c_s1,
829 u32_strlen ((const scm_t_uint32 *) c_s1),
830 (const scm_t_uint32 *) c_s2,
831 u32_strlen ((const scm_t_uint32 *) c_s2),
832 NULL, UNINORM_NFC, &result);
833 if (ret != 0)
834 scm_syserror (func_name);
9361f762 835 }
5b878445
MG		 836
837 SCM_U32_BUF_FREE (s1, c_s1);
838 SCM_U32_BUF_FREE (s2, c_s2);
b89c4943 839
5b878445
MG		 840 scm_remember_upto_here_2 (s1, s2);
841 scm_remember_upto_here (locale);
b89c4943
LC		 842
843 return result;
844}
845#undef FUNC_NAME
846
847/* Store into DST an upper-case version of SRC. */
848static inline void
849str_upcase (register char *dst, register const char *src)
850{
851 for (; *src != '\0'; src++, dst++)
4e641322 852 *dst = toupper ((int) *src);
b89c4943
LC		 853 *dst = '\0';
854}
855
856static inline void
857str_downcase (register char *dst, register const char *src)
858{
859 for (; *src != '\0'; src++, dst++)
4e641322 860 *dst = tolower ((int) *src);
b89c4943
LC		 861 *dst = '\0';
862}
863
864#ifdef USE_GNU_LOCALE_API
865static inline void
866str_upcase_l (register char *dst, register const char *src,
867 scm_t_locale locale)
868{
869 for (; *src != '\0'; src++, dst++)
870 *dst = toupper_l (*src, locale);
871 *dst = '\0';
872}
873
874static inline void
875str_downcase_l (register char *dst, register const char *src,
876 scm_t_locale locale)
877{
878 for (; *src != '\0'; src++, dst++)
879 *dst = tolower_l (*src, locale);
880 *dst = '\0';
881}
882#endif
883
884
b89c4943
LC		 885SCM_DEFINE (scm_string_locale_lt, "string-locale<?", 2, 1, 0,
886 (SCM s1, SCM s2, SCM locale),
887 "Compare strings @var{s1} and @var{s2} in a locale-dependent way."
888 "If @var{locale} is provided, it should be locale object (as "
889 "returned by @code{make-locale}) and will be used to perform the "
890 "comparison; otherwise, the current system locale is used.")
891#define FUNC_NAME s_scm_string_locale_lt
9361f762 892{
b89c4943 893 int result;
9361f762 894
b89c4943
LC		 895 SCM_VALIDATE_STRING (1, s1);
896 SCM_VALIDATE_STRING (2, s2);
9361f762 897
5b878445 898 result = compare_u32_strings (s1, s2, locale, FUNC_NAME);
b89c4943
LC		 899
900 return scm_from_bool (result < 0);
901}
902#undef FUNC_NAME
903
904SCM_DEFINE (scm_string_locale_gt, "string-locale>?", 2, 1, 0,
905 (SCM s1, SCM s2, SCM locale),
906 "Compare strings @var{s1} and @var{s2} in a locale-dependent way."
907 "If @var{locale} is provided, it should be locale object (as "
908 "returned by @code{make-locale}) and will be used to perform the "
909 "comparison; otherwise, the current system locale is used.")
910#define FUNC_NAME s_scm_string_locale_gt
911{
912 int result;
b89c4943
LC		 913
914 SCM_VALIDATE_STRING (1, s1);
915 SCM_VALIDATE_STRING (2, s2);
916
5b878445 917 result = compare_u32_strings (s1, s2, locale, FUNC_NAME);
b89c4943
LC		 918
919 return scm_from_bool (result > 0);
920}
921#undef FUNC_NAME
922
923SCM_DEFINE (scm_string_locale_ci_lt, "string-locale-ci<?", 2, 1, 0,
924 (SCM s1, SCM s2, SCM locale),
925 "Compare strings @var{s1} and @var{s2} in a case-insensitive, "
926 "and locale-dependent way. If @var{locale} is provided, it "
927 "should be locale object (as returned by @code{make-locale}) "
928 "and will be used to perform the comparison; otherwise, the "
929 "current system locale is used.")
930#define FUNC_NAME s_scm_string_locale_ci_lt
931{
932 int result;
b89c4943
LC		 933
934 SCM_VALIDATE_STRING (1, s1);
935 SCM_VALIDATE_STRING (2, s2);
936
5b878445 937 result = compare_u32_strings_ci (s1, s2, locale, FUNC_NAME);
b89c4943
LC		 938
939 return scm_from_bool (result < 0);
940}
941#undef FUNC_NAME
942
943SCM_DEFINE (scm_string_locale_ci_gt, "string-locale-ci>?", 2, 1, 0,
944 (SCM s1, SCM s2, SCM locale),
945 "Compare strings @var{s1} and @var{s2} in a case-insensitive, "
946 "and locale-dependent way. If @var{locale} is provided, it "
947 "should be locale object (as returned by @code{make-locale}) "
948 "and will be used to perform the comparison; otherwise, the "
949 "current system locale is used.")
950#define FUNC_NAME s_scm_string_locale_ci_gt
951{
952 int result;
b89c4943
LC		 953
954 SCM_VALIDATE_STRING (1, s1);
955 SCM_VALIDATE_STRING (2, s2);
956
5b878445 957 result = compare_u32_strings_ci (s1, s2, locale, FUNC_NAME);
b89c4943
LC		 958
959 return scm_from_bool (result > 0);
960}
961#undef FUNC_NAME
962
963SCM_DEFINE (scm_string_locale_ci_eq, "string-locale-ci=?", 2, 1, 0,
964 (SCM s1, SCM s2, SCM locale),
965 "Compare strings @var{s1} and @var{s2} in a case-insensitive, "
966 "and locale-dependent way. If @var{locale} is provided, it "
967 "should be locale object (as returned by @code{make-locale}) "
968 "and will be used to perform the comparison; otherwise, the "
969 "current system locale is used.")
970#define FUNC_NAME s_scm_string_locale_ci_eq
971{
972 int result;
b89c4943
LC		 973
974 SCM_VALIDATE_STRING (1, s1);
975 SCM_VALIDATE_STRING (2, s2);
976
5b878445 977 result = compare_u32_strings_ci (s1, s2, locale, FUNC_NAME);
b89c4943
LC		 978
979 return scm_from_bool (result == 0);
980}
981#undef FUNC_NAME
982
983
984SCM_DEFINE (scm_char_locale_lt, "char-locale<?", 2, 1, 0,
985 (SCM c1, SCM c2, SCM locale),
986 "Return true if character @var{c1} is lower than @var{c2} "
987 "according to @var{locale} or to the current locale.")
988#define FUNC_NAME s_scm_char_locale_lt
989{
5b878445 990 int result;
b89c4943
LC		 991
992 SCM_VALIDATE_CHAR (1, c1);
993 SCM_VALIDATE_CHAR (2, c2);
994
5b878445
MG		 995 result = compare_u32_strings (scm_string (scm_list_1 (c1)),
996 scm_string (scm_list_1 (c2)),
997 locale, FUNC_NAME);
b89c4943 998
5b878445 999 return scm_from_bool (result < 0);
b89c4943
LC		 1000}
1001#undef FUNC_NAME
1002
1003SCM_DEFINE (scm_char_locale_gt, "char-locale>?", 2, 1, 0,
1004 (SCM c1, SCM c2, SCM locale),
1005 "Return true if character @var{c1} is greater than @var{c2} "
1006 "according to @var{locale} or to the current locale.")
1007#define FUNC_NAME s_scm_char_locale_gt
1008{
5b878445 1009 int result;
b89c4943
LC		 1010
1011 SCM_VALIDATE_CHAR (1, c1);
1012 SCM_VALIDATE_CHAR (2, c2);
1013
5b878445
MG		 1014 result = compare_u32_strings (scm_string (scm_list_1 (c1)),
1015 scm_string (scm_list_1 (c2)),
1016 locale, FUNC_NAME);
b89c4943 1017
5b878445 1018 return scm_from_bool (result > 0);
b89c4943
LC		 1019}
1020#undef FUNC_NAME
1021
1022SCM_DEFINE (scm_char_locale_ci_lt, "char-locale-ci<?", 2, 1, 0,
1023 (SCM c1, SCM c2, SCM locale),
1024 "Return true if character @var{c1} is lower than @var{c2}, "
1025 "in a case insensitive way according to @var{locale} or to "
1026 "the current locale.")
1027#define FUNC_NAME s_scm_char_locale_ci_lt
1028{
1029 int result;
b89c4943
LC		 1030
1031 SCM_VALIDATE_CHAR (1, c1);
1032 SCM_VALIDATE_CHAR (2, c2);
1033
5b878445
MG		 1034 result = compare_u32_strings_ci (scm_string (scm_list_1 (c1)),
1035 scm_string (scm_list_1 (c2)),
1036 locale, FUNC_NAME);
b89c4943
LC		 1037
1038 return scm_from_bool (result < 0);
1039}
1040#undef FUNC_NAME
1041
1042SCM_DEFINE (scm_char_locale_ci_gt, "char-locale-ci>?", 2, 1, 0,
1043 (SCM c1, SCM c2, SCM locale),
1044 "Return true if character @var{c1} is greater than @var{c2}, "
1045 "in a case insensitive way according to @var{locale} or to "
1046 "the current locale.")
1047#define FUNC_NAME s_scm_char_locale_ci_gt
1048{
1049 int result;
b89c4943
LC		 1050
1051 SCM_VALIDATE_CHAR (1, c1);
1052 SCM_VALIDATE_CHAR (2, c2);
1053
5b878445
MG		 1054 result = compare_u32_strings_ci (scm_string (scm_list_1 (c1)),
1055 scm_string (scm_list_1 (c2)),
1056 locale, FUNC_NAME);
b89c4943
LC		 1057
1058 return scm_from_bool (result > 0);
1059}
1060#undef FUNC_NAME
1061
1062SCM_DEFINE (scm_char_locale_ci_eq, "char-locale-ci=?", 2, 1, 0,
1063 (SCM c1, SCM c2, SCM locale),
1064 "Return true if character @var{c1} is equal to @var{c2}, "
1065 "in a case insensitive way according to @var{locale} or to "
1066 "the current locale.")
1067#define FUNC_NAME s_scm_char_locale_ci_eq
1068{
1069 int result;
b89c4943
LC		 1070
1071 SCM_VALIDATE_CHAR (1, c1);
1072 SCM_VALIDATE_CHAR (2, c2);
1073
5b878445
MG		 1074 result = compare_u32_strings_ci (scm_string (scm_list_1 (c1)),
1075 scm_string (scm_list_1 (c2)),
1076 locale, FUNC_NAME);
b89c4943
LC		 1077
1078 return scm_from_bool (result == 0);
1079}
1080#undef FUNC_NAME
1081
1082
1083\f
1084/* Locale-dependent alphabetic character mapping. */
1085
1086SCM_DEFINE (scm_char_locale_downcase, "char-locale-downcase", 1, 1, 0,
1087 (SCM chr, SCM locale),
1088 "Return the lowercase character that corresponds to @var{chr} "
1089 "according to either @var{locale} or the current locale.")
1090#define FUNC_NAME s_scm_char_locale_downcase
1091{
1092 char c_chr;
1093 int c_result;
1094 scm_t_locale c_locale;
1095
1096 SCM_VALIDATE_CHAR (1, chr);
1097 c_chr = SCM_CHAR (chr);
1098
1099 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
1100
1101 if (c_locale != NULL)
9361f762 1102 {
b89c4943 1103#ifdef USE_GNU_LOCALE_API
4e641322 1104 c_result = tolower_l ((int) c_chr, c_locale);
b89c4943 1105#else
4e641322 1106 RUN_IN_LOCALE_SECTION (c_locale, c_result = tolower ((int) c_chr));
b89c4943 1107#endif
9361f762 1108 }
b89c4943 1109 else
4e641322 1110 c_result = tolower ((int) c_chr);
9361f762 1111
b89c4943 1112 return (SCM_MAKE_CHAR (c_result));
9361f762
MV		 1113}
1114#undef FUNC_NAME
1115
b89c4943
LC		 1116SCM_DEFINE (scm_char_locale_upcase, "char-locale-upcase", 1, 1, 0,
1117 (SCM chr, SCM locale),
1118 "Return the uppercase character that corresponds to @var{chr} "
1119 "according to either @var{locale} or the current locale.")
1120#define FUNC_NAME s_scm_char_locale_upcase
9361f762 1121{
b89c4943
LC		 1122 char c_chr;
1123 int c_result;
1124 scm_t_locale c_locale;
1125
1126 SCM_VALIDATE_CHAR (1, chr);
1127 c_chr = SCM_CHAR (chr);
9361f762 1128
b89c4943 1129 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
9361f762 1130
b89c4943
LC		 1131 if (c_locale != NULL)
1132 {
1133#ifdef USE_GNU_LOCALE_API
4e641322 1134 c_result = toupper_l ((int) c_chr, c_locale);
b89c4943 1135#else
4e641322 1136 RUN_IN_LOCALE_SECTION (c_locale, c_result = toupper ((int) c_chr));
b89c4943
LC		 1137#endif
1138 }
9361f762 1139 else
4e641322 1140 c_result = toupper ((int) c_chr);
b89c4943
LC		 1141
1142 return (SCM_MAKE_CHAR (c_result));
1143}
1144#undef FUNC_NAME
1145
1146SCM_DEFINE (scm_string_locale_upcase, "string-locale-upcase", 1, 1, 0,
1147 (SCM str, SCM locale),
1148 "Return a new string that is the uppercase version of "
1149 "@var{str} according to either @var{locale} or the current "
1150 "locale.")
1151#define FUNC_NAME s_scm_string_locale_upcase
1152{
1153 const char *c_str;
1154 char *c_ustr;
1155 scm_t_locale c_locale;
1156
1157 SCM_VALIDATE_STRING (1, str);
1158 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
1159
1160 c_str = scm_i_string_chars (str);
1161 c_ustr = (char *) alloca (strlen (c_str) + 1);
1162
1163 if (c_locale)
9361f762 1164 {
b89c4943
LC		 1165#ifdef USE_GNU_LOCALE_API
1166 str_upcase_l (c_ustr, c_str, c_locale);
1167#else
1168 RUN_IN_LOCALE_SECTION (c_locale, str_upcase (c_ustr, c_str));
1169#endif
9361f762 1170 }
b89c4943
LC		 1171 else
1172 str_upcase (c_ustr, c_str);
1173
1174 scm_remember_upto_here (str);
1175
1176 return (scm_from_locale_string (c_ustr));
1177}
1178#undef FUNC_NAME
9361f762 1179
b89c4943
LC		 1180SCM_DEFINE (scm_string_locale_downcase, "string-locale-downcase", 1, 1, 0,
1181 (SCM str, SCM locale),
1182 "Return a new string that is the down-case version of "
1183 "@var{str} according to either @var{locale} or the current "
1184 "locale.")
1185#define FUNC_NAME s_scm_string_locale_downcase
1186{
1187 const char *c_str;
1188 char *c_lstr;
1189 scm_t_locale c_locale;
1190
1191 SCM_VALIDATE_STRING (1, str);
1192 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
9361f762 1193
b89c4943
LC		 1194 c_str = scm_i_string_chars (str);
1195 c_lstr = (char *) alloca (strlen (c_str) + 1);
9361f762 1196
b89c4943
LC		 1197 if (c_locale)
1198 {
1199#ifdef USE_GNU_LOCALE_API
1200 str_downcase_l (c_lstr, c_str, c_locale);
1201#else
1202 RUN_IN_LOCALE_SECTION (c_locale, str_downcase (c_lstr, c_str));
1203#endif
1204 }
9361f762 1205 else
b89c4943 1206 str_downcase (c_lstr, c_str);
9361f762 1207
b89c4943
LC		 1208 scm_remember_upto_here (str);
1209
1210 return (scm_from_locale_string (c_lstr));
9361f762
MV		 1211}
1212#undef FUNC_NAME
1213
b89c4943
LC		 1214/* Note: We don't provide mutative versions of `string-locale-(up|down)case'
1215 because, in some languages, a single downcase character maps to a couple
1216 of uppercase characters. Read the SRFI-13 document for a detailed
1217 discussion about this. */
1218
1219
1220\f
1221/* Locale-dependent number parsing. */
1222
1223SCM_DEFINE (scm_locale_string_to_integer, "locale-string->integer",
1224 1, 2, 0, (SCM str, SCM base, SCM locale),
1225 "Convert string @var{str} into an integer according to either "
1226 "@var{locale} (a locale object as returned by @code{make-locale}) "
1227 "or the current process locale. Return two values: an integer "
1228 "(on success) or @code{#f}, and the number of characters read "
1229 "from @var{str} (@code{0} on failure).")
1230#define FUNC_NAME s_scm_locale_string_to_integer
9361f762 1231{
9361f762 1232 SCM result;
b89c4943
LC		 1233 long c_result;
1234 int c_base;
1235 const char *c_str;
1236 char *c_endptr;
1237 scm_t_locale c_locale;
9361f762 1238
b89c4943
LC		 1239 SCM_VALIDATE_STRING (1, str);
1240 c_str = scm_i_string_chars (str);
9361f762 1241
b89c4943
LC		 1242 if (base != SCM_UNDEFINED)
1243 SCM_VALIDATE_INT_COPY (2, base, c_base);
9361f762 1244 else
b89c4943
LC		 1245 c_base = 10;
1246
1247 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale);
1248
1249 if (c_locale != NULL)
9361f762 1250 {
b89c4943
LC		 1251#ifdef USE_GNU_LOCALE_API
1252 c_result = strtol_l (c_str, &c_endptr, c_base, c_locale);
1253#else
1254 RUN_IN_LOCALE_SECTION (c_locale,
1255 c_result = strtol (c_str, &c_endptr, c_base));
1256#endif
9361f762 1257 }
b89c4943
LC		 1258 else
1259 c_result = strtol (c_str, &c_endptr, c_base);
1260
1261 scm_remember_upto_here (str);
1262
1263 if (c_endptr == c_str)
1264 result = SCM_BOOL_F;
1265 else
1266 result = scm_from_long (c_result);
1267
1268 return (scm_values (scm_list_2 (result, scm_from_long (c_endptr - c_str))));
1269}
1270#undef FUNC_NAME
1271
1272SCM_DEFINE (scm_locale_string_to_inexact, "locale-string->inexact",
1273 1, 1, 0, (SCM str, SCM locale),
1274 "Convert string @var{str} into an inexact number according to "
1275 "either @var{locale} (a locale object as returned by "
1276 "@code{make-locale}) or the current process locale. Return "
1277 "two values: an inexact number (on success) or @code{#f}, and "
1278 "the number of characters read from @var{str} (@code{0} on "
1279 "failure).")
1280#define FUNC_NAME s_scm_locale_string_to_inexact
1281{
1282 SCM result;
1283 double c_result;
1284 const char *c_str;
1285 char *c_endptr;
1286 scm_t_locale c_locale;
9361f762 1287
b89c4943
LC		 1288 SCM_VALIDATE_STRING (1, str);
1289 c_str = scm_i_string_chars (str);
9361f762 1290
b89c4943 1291 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
9361f762 1292
b89c4943
LC		 1293 if (c_locale != NULL)
1294 {
1295#ifdef USE_GNU_LOCALE_API
1296 c_result = strtod_l (c_str, &c_endptr, c_locale);
1297#else
1298 RUN_IN_LOCALE_SECTION (c_locale,
1299 c_result = strtod (c_str, &c_endptr));
1300#endif
1301 }
9361f762 1302 else
b89c4943
LC		 1303 c_result = strtod (c_str, &c_endptr);
1304
1305 scm_remember_upto_here (str);
1306
1307 if (c_endptr == c_str)
9361f762 1308 result = SCM_BOOL_F;
b89c4943
LC		 1309 else
1310 result = scm_from_double (c_result);
9361f762 1311
b89c4943 1312 return (scm_values (scm_list_2 (result, scm_from_long (c_endptr - c_str))));
9361f762
MV		 1313}
1314#undef FUNC_NAME
1315
b89c4943 1316\f
a2f00b9b
LC		 1317/* Language information, aka. `nl_langinfo ()'. */
1318
1319/* FIXME: Issues related to `nl-langinfo'.
1320
1321 1. The `CODESET' value is not normalized. This is a secondary issue, but
1322 still a practical issue. See
1323 http://www.cl.cam.ac.uk/~mgk25/ucs/norm_charmap.c for codeset
1324 normalization.
1325
1326 2. `nl_langinfo ()' is not available on Windows.
1327
1328 3. `nl_langinfo ()' may return strings encoded in a locale different from
1329 the current one, thereby defeating `scm_from_locale_string ()'.
1330 Example: support the current locale is "Latin-1" and one asks:
1331
1332 (nl-langinfo DAY_1 (make-locale LC_ALL "eo_EO.UTF-8"))
1333
1334 The result will be a UTF-8 string. However, `scm_from_locale_string',
1335 which expects a Latin-1 string, won't be able to make much sense of the
1336 returned string. Thus, we'd need an `scm_from_string ()' variant where
1337 the locale (or charset) is explicitly passed. */
1338
1339
1340SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
1341 (SCM item, SCM locale),
1342 "Return a string denoting locale information for @var{item} "
1343 "in the current locale or that specified by @var{locale}. "
1344 "The semantics and arguments are the same as those of the "
1345 "X/Open @code{nl_langinfo} function (@pxref{The Elegant and "
1346 "Fast Way, @code{nl_langinfo},, libc, The GNU C Library "
1347 "Reference Manual}).")
1348#define FUNC_NAME s_scm_nl_langinfo
1349{
1350#ifdef HAVE_NL_LANGINFO
1351 SCM result;
1352 nl_item c_item;
1353 char *c_result;
1354 scm_t_locale c_locale;
1355
1356 SCM_VALIDATE_INT_COPY (2, item, c_item);
1357 SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
1358
1359 /* Sadly, `nl_langinfo ()' returns a pointer to a static string. According
1360 to SuS v2, that static string may be modified by subsequent calls to
1361 `nl_langinfo ()' as well as by calls to `setlocale ()'. Thus, we must
1362 acquire the locale mutex before doing invoking `nl_langinfo ()'. See
1363 http://opengroup.org/onlinepubs/007908799/xsh/nl_langinfo.html for
1364 details. */
1365
1366 scm_i_pthread_mutex_lock (&scm_i_locale_mutex);
1367 if (c_locale != NULL)
1368 {
1369#ifdef USE_GNU_LOCALE_API
1370 c_result = nl_langinfo_l (c_item, c_locale);
1371#else
1372 /* We can't use `RUN_IN_LOCALE_SECTION ()' here because the locale
1373 mutex is already taken. */
1374 int lsec_err;
1375 scm_t_locale_settings lsec_prev_locale;
1376
1377 lsec_err = get_current_locale_settings (&lsec_prev_locale);
1378 if (lsec_err)
1379 scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
1380 else
1381 {
1382 lsec_err = install_locale (c_locale);
1383 if (lsec_err)
1384 {
1385 leave_locale_section (&lsec_prev_locale);
1386 free_locale_settings (&lsec_prev_locale);
1387 }
1388 }
1389
1390 if (lsec_err)
1391 scm_locale_error (FUNC_NAME, lsec_err);
1392 else
1393 {
1394 c_result = nl_langinfo (c_item);
1395
1445e449 1396 restore_locale_settings (&lsec_prev_locale);
a2f00b9b
LC		 1397 free_locale_settings (&lsec_prev_locale);
1398 }
1399#endif
1400 }
1401 else
1402 c_result = nl_langinfo (c_item);
1403
1404 c_result = strdup (c_result);
1405 scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
1406
1407 if (c_result == NULL)
1408 result = SCM_BOOL_F;
1409 else
1410 {
a2f00b9b
LC		 1411 switch (c_item)
1412 {
afb49959 1413#if (defined GROUPING) && (defined MON_GROUPING)
a2f00b9b
LC		 1414 case GROUPING:
1415 case MON_GROUPING:
a2f00b9b 1416 {
afb49959 1417 char *p;
a2f00b9b 1418
afb49959
LC		 1419 /* In this cases, the result is to be interpreted as a list of
1420 numbers. If the last item is `CHARS_MAX', it has the special
1421 meaning "no more grouping". */
1422 result = SCM_EOL;
1423 for (p = c_result; (*p != '\0') && (*p != CHAR_MAX); p++)
1424 result = scm_cons (SCM_I_MAKINUM ((int) *p), result);
a2f00b9b 1425
afb49959
LC		 1426 {
1427 SCM last_pair = result;
a2f00b9b 1428
afb49959
LC		 1429 result = scm_reverse_x (result, SCM_EOL);
1430
1431 if (*p != CHAR_MAX)
1432 {
1433 /* Cyclic grouping information. */
1434 if (last_pair != SCM_EOL)
1435 SCM_SETCDR (last_pair, result);
1436 }
1437 }
a2f00b9b 1438
afb49959
LC		 1439 free (c_result);
1440 break;
1441 }
1442#endif
1443
1444#if (defined FRAC_DIGITS) && (defined INT_FRAC_DIGITS)
a2f00b9b
LC		 1445 case FRAC_DIGITS:
1446 case INT_FRAC_DIGITS:
1447 /* This is to be interpreted as a single integer. */
1448 if (*c_result == CHAR_MAX)
1449 /* Unspecified. */
1450 result = SCM_BOOL_F;
1451 else
1452 result = SCM_I_MAKINUM (*c_result);
1453
1454 free (c_result);
1455 break;
afb49959 1456#endif
a2f00b9b 1457
afb49959 1458#if (defined P_CS_PRECEDES) && (defined INT_N_CS_PRECEDES)
a2f00b9b
LC		 1459 case P_CS_PRECEDES:
1460 case N_CS_PRECEDES:
1461 case INT_P_CS_PRECEDES:
1462 case INT_N_CS_PRECEDES:
afb49959 1463#if (defined P_SEP_BY_SPACE) && (defined N_SEP_BY_SPACE)
a2f00b9b
LC		 1464 case P_SEP_BY_SPACE:
1465 case N_SEP_BY_SPACE:
afb49959 1466#endif
a2f00b9b
LC		 1467 /* This is to be interpreted as a boolean. */
1468 result = scm_from_bool (*c_result);
1469
1470 free (c_result);
1471 break;
afb49959 1472#endif
a2f00b9b 1473
afb49959 1474#if (defined P_SIGN_POSN) && (defined INT_N_SIGN_POSN)
a2f00b9b
LC		 1475 case P_SIGN_POSN:
1476 case N_SIGN_POSN:
1477 case INT_P_SIGN_POSN:
1478 case INT_N_SIGN_POSN:
1479 /* See `(libc) Sign of Money Amount' for the interpretation of the
1480 return value here. */
1481 switch (*c_result)
1482 {
1483 case 0:
1484 result = scm_from_locale_symbol ("parenthesize");
1485 break;
1486
1487 case 1:
1488 result = scm_from_locale_symbol ("sign-before");
1489 break;
1490
1491 case 2:
1492 result = scm_from_locale_symbol ("sign-after");
1493 break;
1494
1495 case 3:
1496 result = scm_from_locale_symbol ("sign-before-currency-symbol");
1497 break;
1498
1499 case 4:
1500 result = scm_from_locale_symbol ("sign-after-currency-symbol");
1501 break;
1502
1503 default:
1504 result = scm_from_locale_symbol ("unspecified");
1505 }
1506 break;
afb49959 1507#endif
a2f00b9b
LC		 1508
1509 default:
1510 /* FIXME: `locale_string ()' is not appropriate here because of
1511 encoding issues (see comment above). */
1512 result = scm_take_locale_string (c_result);
1513 }
1514 }
1515
1516 return result;
1517#else
1518 scm_syserror_msg (FUNC_NAME, "`nl-langinfo' not supported on your system",
1519 SCM_EOL, ENOSYS);
1520
1521 return SCM_BOOL_F;
1522#endif
1523}
1524#undef FUNC_NAME
1525
1526/* Define the `nl_item' constants. */
1527static inline void
1528define_langinfo_items (void)
9361f762 1529{
a2f00b9b
LC		 1530#if (defined HAVE_NL_TYPES_H) && (defined HAVE_LANGINFO_H)
1531
1532#define DEFINE_NLITEM_CONSTANT(_item) \
1533 scm_c_define (# _item, scm_from_int (_item))
1534
1535 DEFINE_NLITEM_CONSTANT (CODESET);
1536
1537 /* Abbreviated days of the week. */
1538 DEFINE_NLITEM_CONSTANT (ABDAY_1);
1539 DEFINE_NLITEM_CONSTANT (ABDAY_2);
1540 DEFINE_NLITEM_CONSTANT (ABDAY_3);
1541 DEFINE_NLITEM_CONSTANT (ABDAY_4);
1542 DEFINE_NLITEM_CONSTANT (ABDAY_5);
1543 DEFINE_NLITEM_CONSTANT (ABDAY_6);
1544 DEFINE_NLITEM_CONSTANT (ABDAY_7);
1545
1546 /* Long-named days of the week. */
1547 DEFINE_NLITEM_CONSTANT (DAY_1); /* Sunday */
1548 DEFINE_NLITEM_CONSTANT (DAY_2); /* Monday */
1549 DEFINE_NLITEM_CONSTANT (DAY_3); /* Tuesday */
1550 DEFINE_NLITEM_CONSTANT (DAY_4); /* Wednesday */
1551 DEFINE_NLITEM_CONSTANT (DAY_5); /* Thursday */
1552 DEFINE_NLITEM_CONSTANT (DAY_6); /* Friday */
1553 DEFINE_NLITEM_CONSTANT (DAY_7); /* Saturday */
1554
1555 /* Abbreviated month names. */
1556 DEFINE_NLITEM_CONSTANT (ABMON_1); /* Jan */
1557 DEFINE_NLITEM_CONSTANT (ABMON_2);
1558 DEFINE_NLITEM_CONSTANT (ABMON_3);
1559 DEFINE_NLITEM_CONSTANT (ABMON_4);
1560 DEFINE_NLITEM_CONSTANT (ABMON_5);
1561 DEFINE_NLITEM_CONSTANT (ABMON_6);
1562 DEFINE_NLITEM_CONSTANT (ABMON_7);
1563 DEFINE_NLITEM_CONSTANT (ABMON_8);
1564 DEFINE_NLITEM_CONSTANT (ABMON_9);
1565 DEFINE_NLITEM_CONSTANT (ABMON_10);
1566 DEFINE_NLITEM_CONSTANT (ABMON_11);
1567 DEFINE_NLITEM_CONSTANT (ABMON_12);
1568
1569 /* Long month names. */
1570 DEFINE_NLITEM_CONSTANT (MON_1); /* January */
1571 DEFINE_NLITEM_CONSTANT (MON_2);
1572 DEFINE_NLITEM_CONSTANT (MON_3);
1573 DEFINE_NLITEM_CONSTANT (MON_4);
1574 DEFINE_NLITEM_CONSTANT (MON_5);
1575 DEFINE_NLITEM_CONSTANT (MON_6);
1576 DEFINE_NLITEM_CONSTANT (MON_7);
1577 DEFINE_NLITEM_CONSTANT (MON_8);
1578 DEFINE_NLITEM_CONSTANT (MON_9);
1579 DEFINE_NLITEM_CONSTANT (MON_10);
1580 DEFINE_NLITEM_CONSTANT (MON_11);
1581 DEFINE_NLITEM_CONSTANT (MON_12);
1582
1583 DEFINE_NLITEM_CONSTANT (AM_STR); /* Ante meridiem string. */
1584 DEFINE_NLITEM_CONSTANT (PM_STR); /* Post meridiem string. */
1585
1586 DEFINE_NLITEM_CONSTANT (D_T_FMT); /* Date and time format for strftime. */
1587 DEFINE_NLITEM_CONSTANT (D_FMT); /* Date format for strftime. */
1588 DEFINE_NLITEM_CONSTANT (T_FMT); /* Time format for strftime. */
1589 DEFINE_NLITEM_CONSTANT (T_FMT_AMPM);/* 12-hour time format for strftime. */
1590
1591 DEFINE_NLITEM_CONSTANT (ERA); /* Alternate era. */
1592 DEFINE_NLITEM_CONSTANT (ERA_D_FMT); /* Date in alternate era format. */
1593 DEFINE_NLITEM_CONSTANT (ERA_D_T_FMT); /* Date and time in alternate era
1594 format. */
1595 DEFINE_NLITEM_CONSTANT (ERA_T_FMT); /* Time in alternate era format. */
1596
1597 DEFINE_NLITEM_CONSTANT (ALT_DIGITS); /* Alternate symbols for digits. */
1598 DEFINE_NLITEM_CONSTANT (RADIXCHAR);
1599 DEFINE_NLITEM_CONSTANT (THOUSEP);
1600
1601#ifdef YESEXPR
1602 DEFINE_NLITEM_CONSTANT (YESEXPR);
1603#endif
1604#ifdef NOEXPR
1605 DEFINE_NLITEM_CONSTANT (NOEXPR);
1606#endif
b89c4943 1607
a2f00b9b
LC		 1608#ifdef CRNCYSTR /* currency symbol */
1609 DEFINE_NLITEM_CONSTANT (CRNCYSTR);
1610#endif
b89c4943 1611
a2f00b9b 1612 /* GNU extensions. */
b89c4943 1613
a2f00b9b
LC		 1614#ifdef ERA_YEAR
1615 DEFINE_NLITEM_CONSTANT (ERA_YEAR); /* Year in alternate era format. */
1616#endif
b89c4943 1617
a2f00b9b
LC		 1618 /* LC_MONETARY category: formatting of monetary quantities.
1619 These items each correspond to a member of `struct lconv',
1620 defined in <locale.h>. */
1621#ifdef INT_CURR_SYMBOL
1622 DEFINE_NLITEM_CONSTANT (INT_CURR_SYMBOL);
1623#endif
1624#ifdef MON_DECIMAL_POINT
1625 DEFINE_NLITEM_CONSTANT (MON_DECIMAL_POINT);
1626#endif
1627#ifdef MON_THOUSANDS_SEP
1628 DEFINE_NLITEM_CONSTANT (MON_THOUSANDS_SEP);
1629#endif
1630#ifdef MON_GROUPING
1631 DEFINE_NLITEM_CONSTANT (MON_GROUPING);
1632#endif
1633#ifdef POSITIVE_SIGN
1634 DEFINE_NLITEM_CONSTANT (POSITIVE_SIGN);
1635#endif
1636#ifdef NEGATIVE_SIGN
1637 DEFINE_NLITEM_CONSTANT (NEGATIVE_SIGN);
1638#endif
1639#ifdef GROUPING
1640 DEFINE_NLITEM_CONSTANT (GROUPING);
1641#endif
1642#ifdef INT_FRAC_DIGITS
1643 DEFINE_NLITEM_CONSTANT (INT_FRAC_DIGITS);
1644#endif
1645#ifdef FRAC_DIGITS
1646 DEFINE_NLITEM_CONSTANT (FRAC_DIGITS);
1647#endif
1648#ifdef P_CS_PRECEDES
1649 DEFINE_NLITEM_CONSTANT (P_CS_PRECEDES);
1650#endif
1651#ifdef P_SEP_BY_SPACE
1652 DEFINE_NLITEM_CONSTANT (P_SEP_BY_SPACE);
1653#endif
1654#ifdef N_CS_PRECEDES
1655 DEFINE_NLITEM_CONSTANT (N_CS_PRECEDES);
1656#endif
1657#ifdef N_SEP_BY_SPACE
1658 DEFINE_NLITEM_CONSTANT (N_SEP_BY_SPACE);
1659#endif
1660#ifdef P_SIGN_POSN
1661 DEFINE_NLITEM_CONSTANT (P_SIGN_POSN);
1662#endif
1663#ifdef N_SIGN_POSN
1664 DEFINE_NLITEM_CONSTANT (N_SIGN_POSN);
1665#endif
1666#ifdef INT_P_CS_PRECEDES
1667 DEFINE_NLITEM_CONSTANT (INT_P_CS_PRECEDES);
1668#endif
1669#ifdef INT_P_SEP_BY_SPACE
1670 DEFINE_NLITEM_CONSTANT (INT_P_SEP_BY_SPACE);
1671#endif
1672#ifdef INT_N_CS_PRECEDES
1673 DEFINE_NLITEM_CONSTANT (INT_N_CS_PRECEDES);
1674#endif
1675#ifdef INT_N_SEP_BY_SPACE
1676 DEFINE_NLITEM_CONSTANT (INT_N_SEP_BY_SPACE);
1677#endif
1678#ifdef INT_P_SIGN_POSN
1679 DEFINE_NLITEM_CONSTANT (INT_P_SIGN_POSN);
1680#endif
1681#ifdef INT_N_SIGN_POSN
1682 DEFINE_NLITEM_CONSTANT (INT_N_SIGN_POSN);
1683#endif
1684
1685#undef DEFINE_NLITEM_CONSTANT
1686
1687#endif /* HAVE_NL_TYPES_H */
1688}
1689
1690\f
1691void
1692scm_init_i18n ()
1693{
1694 SCM global_locale_smob;
1695
1696#ifdef HAVE_NL_LANGINFO
1697 scm_add_feature ("nl-langinfo");
1698 define_langinfo_items ();
1699#endif
b89c4943 1700
9361f762 1701#include "libguile/i18n.x"
b89c4943 1702
a2f00b9b
LC		 1703 /* Initialize the global locale object with a special `locale' SMOB. */
1704 SCM_NEWSMOB (global_locale_smob, scm_tc16_locale_smob_type, NULL);
1705 SCM_VARIABLE_SET (scm_global_locale, global_locale_smob);
9361f762
MV		 1706}
1707
756e8a3a
LC		 1708void
1709scm_bootstrap_i18n ()
1710{
1711 scm_c_register_extension ("libguile", "scm_init_i18n",
1712 (scm_t_extension_init_func) scm_init_i18n,
1713 NULL);
1714
1715}
1716
9361f762
MV		 1717
1718/*
1719 Local Variables:
1720 c-file-style: "gnu"
1721 End:
1722*/
Unnamed repository; edit this file 'description' to name the repository.