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