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