libguile/i18n.c

   1 /* Copyright (C) 2006 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16  */
  17
  18 #define _GNU_SOURCE /* Ask for glibc's `newlocale' API */
  19
  20 #if HAVE_CONFIG_H
  21 # include <config.h>
  22 #endif
  23
  24 #if HAVE_ALLOCA_H
  25 # include <alloca.h>
  26 #elif defined __GNUC__
  27 # define alloca __builtin_alloca
  28 #elif defined _AIX
  29 # define alloca __alloca
  30 #elif defined _MSC_VER
  31 # include <malloc.h>
  32 # define alloca _alloca
  33 #else
  34 # include <stddef.h>
  35 # ifdef  __cplusplus
  36 extern "C"
  37 # endif
  38 void *alloca (size_t);
  39 #endif
  40
  41 #include "libguile/_scm.h"
  42 #include "libguile/feature.h"
  43 #include "libguile/i18n.h"
  44 #include "libguile/strings.h"
  45 #include "libguile/chars.h"
  46 #include "libguile/dynwind.h"
  47 #include "libguile/validate.h"
  48 #include "libguile/values.h"
  49
  50 #include <locale.h>
  51 #include <string.h> /* `strcoll ()' */
  52 #include <ctype.h>  /* `toupper ()' et al. */
  53 #include <errno.h>
  54
  55 #if (defined HAVE_NEWLOCALE) && (defined HAVE_STRCOLL_L)
  56 # define USE_GNU_LOCALE_API
  57 #endif
  58
  59 #ifndef USE_GNU_LOCALE_API
  60 # include "libguile/posix.h"  /* for `scm_i_locale_mutex' */
  61 #endif
  62
  63 #ifndef HAVE_SETLOCALE
  64 static inline char *
  65 setlocale (int category, const char *name)
  66 {
  67   errno = ENOSYS;
  68   return NULL;
  69 }
  70 #endif
  71
  72
  73 \f
  74 /* Locale objects, string and character collation, and other locale-dependent
  75    string operations.
  76
  77    A large part of the code here deals with emulating glibc's reentrant
  78    locale API on non-GNU systems.  The emulation is a bit "brute-force":
  79    Whenever a `-locale<?' procedure is passed a locale object, then:
  80
  81    1. The `scm_t_locale_mutex' is locked.
  82    2. A series of `setlocale ()' call is performed to store the current
  83       locale for each category in an `scm_t_locale_settings' object.
  84    3. A series of `setlocale ()' call is made to install each of the locale
  85       categories of each of the base locales of each locale object,
  86       recursively, starting from the last locale object of the chain.
  87    4. The settings captured in step (2) are restored.
  88    5. The `scm_t_locale_mutex' is released.
  89
  90    Hopefully, some smart standard will make that hack useless someday...
  91    A similar API can be found in MzScheme starting from version 200:
  92    http://download.plt-scheme.org/chronology/mzmr200alpha14.html .
  93
  94    Note: We don't wrap glibc's `uselocale ()' call because it sets the locale
  95    of the current _thread_ (unlike `setlocale ()') and doing so would require
  96    maintaining per-thread locale information on non-GNU systems and always
  97    re-installing this locale upon locale-dependent calls.  */
  98
  99
 100 #ifndef USE_GNU_LOCALE_API
 101
 102 /* Provide the locale category masks as found in glibc (copied from
 103    <locale.h> as found in glibc 2.3.6).  This must be kept in sync with
 104    `locale-categories.h'.  */
 105
 106 # define LC_CTYPE_MASK          (1 << LC_CTYPE)
 107 # define LC_COLLATE_MASK        (1 << LC_COLLATE)
 108 # define LC_MESSAGES_MASK       (1 << LC_MESSAGES)
 109 # define LC_MONETARY_MASK       (1 << LC_MONETARY)
 110 # define LC_NUMERIC_MASK        (1 << LC_NUMERIC)
 111 # define LC_TIME_MASK           (1 << LC_TIME)
 112
 113 # ifdef LC_PAPER
 114 #   define LC_PAPER_MASK        (1 << LC_PAPER)
 115 # else
 116 #   define LC_PAPER_MASK        0
 117 # endif
 118 # ifdef LC_NAME
 119 #   define LC_NAME_MASK         (1 << LC_NAME)
 120 # else
 121 #   define LC_NAME_MASK         0
 122 # endif
 123 # ifdef LC_ADDRESS
 124 #   define LC_ADDRESS_MASK      (1 << LC_ADDRESS)
 125 # else
 126 #   define LC_ADDRESS_MASK      0
 127 # endif
 128 # ifdef LC_TELEPHONE
 129 #   define LC_TELEPHONE_MASK    (1 << LC_TELEPHONE)
 130 # else
 131 #   define LC_TELEPHONE_MASK    0
 132 # endif
 133 # ifdef LC_MEASUREMENT
 134 #   define LC_MEASUREMENT_MASK  (1 << LC_MEASUREMENT)
 135 # else
 136 #   define LC_MEASUREMENT_MASK  0
 137 # endif
 138 # ifdef LC_IDENTIFICATION
 139 #   define LC_IDENTIFICATION_MASK (1 << LC_IDENTIFICATION)
 140 # else
 141 #   define LC_IDENTIFICATION_MASK 0
 142 # endif
 143
 144 # define LC_ALL_MASK            (LC_CTYPE_MASK \
 145                                  | LC_NUMERIC_MASK \
 146                                  | LC_TIME_MASK \
 147                                  | LC_COLLATE_MASK \
 148                                  | LC_MONETARY_MASK \
 149                                  | LC_MESSAGES_MASK \
 150                                  | LC_PAPER_MASK \
 151                                  | LC_NAME_MASK \
 152                                  | LC_ADDRESS_MASK \
 153                                  | LC_TELEPHONE_MASK \
 154                                  | LC_MEASUREMENT_MASK \
 155                                  | LC_IDENTIFICATION_MASK \
 156                                  )
 157
 158 /* Locale objects as returned by `make-locale' on non-GNU systems.  */
 159 typedef struct scm_locale
 160 {
 161   SCM   base_locale; /* a `locale' object */
 162   char *locale_name;
 163   int   category_mask;
 164 } *scm_t_locale;
 165
 166 #else
 167
 168 /* Alias for glibc's locale type.  */
 169 typedef locale_t scm_t_locale;
 170
 171 #endif
 172
 173 /* Validate parameter ARG as a locale object and set C_LOCALE to the
 174    corresponding C locale object.  */
 175 #define SCM_VALIDATE_LOCALE_COPY(_pos, _arg, _c_locale)         \
 176   do                                                            \
 177     {                                                           \
 178       SCM_VALIDATE_SMOB ((_pos), (_arg), locale_smob_type);     \
 179       (_c_locale) = (scm_t_locale)SCM_SMOB_DATA (_arg);         \
 180     }                                                           \
 181   while (0)
 182
 183 /* Validate optional parameter ARG as either undefined or bound to a locale
 184    object.  Set C_LOCALE to the corresponding C locale object or NULL.  */
 185 #define SCM_VALIDATE_OPTIONAL_LOCALE_COPY(_pos, _arg, _c_locale)        \
 186   do                                                                    \
 187     {                                                                   \
 188       if ((_arg) != SCM_UNDEFINED)                                      \
 189         SCM_VALIDATE_LOCALE_COPY (_pos, _arg, _c_locale);               \
 190       else                                                              \
 191         (_c_locale) = NULL;                                             \
 192     }                                                                   \
 193   while (0)
 194
 195
 196 SCM_SMOB (scm_tc16_locale_smob_type, "locale", 0);
 197
 198 SCM_SMOB_FREE (scm_tc16_locale_smob_type, smob_locale_free, locale)
 199 {
 200   scm_t_locale c_locale;
 201
 202   c_locale = (scm_t_locale)SCM_SMOB_DATA (locale);
 203
 204 #ifdef USE_GNU_LOCALE_API
 205   freelocale ((locale_t)c_locale);
 206 #else
 207   c_locale->base_locale = SCM_UNDEFINED;
 208   free (c_locale->locale_name);
 209
 210   scm_gc_free (c_locale, sizeof (* c_locale), "locale");
 211 #endif
 212
 213   return 0;
 214 }
 215
 216 #ifndef USE_GNU_LOCALE_API
 217 static SCM
 218 smob_locale_mark (SCM locale)
 219 {
 220   scm_t_locale c_locale;
 221
 222   c_locale = (scm_t_locale)SCM_SMOB_DATA (locale);
 223   return (c_locale->base_locale);
 224 }
 225 #endif
 226
 227
 228 SCM_DEFINE (scm_make_locale, "make-locale", 2, 1, 0,
 229             (SCM category_mask, SCM locale_name, SCM base_locale),
 230             "Return a reference to a data structure representing a set of "
 231             "locale datasets.  Unlike for the @var{category} parameter for "
 232             "@code{setlocale}, the @var{category_mask} parameter here uses "
 233             "a single bit for each category, made by OR'ing together "
 234             "@code{LC_*_MASK} bits.")
 235 #define FUNC_NAME s_scm_make_locale
 236 {
 237   SCM locale = SCM_BOOL_F;
 238   int c_category_mask;
 239   char *c_locale_name;
 240   scm_t_locale c_base_locale, c_locale;
 241
 242   SCM_VALIDATE_INT_COPY (1, category_mask, c_category_mask);
 243   SCM_VALIDATE_STRING (2, locale_name);
 244   SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, base_locale, c_base_locale);
 245
 246   c_locale_name = scm_to_locale_string (locale_name);
 247
 248 #ifdef USE_GNU_LOCALE_API
 249
 250   c_locale = newlocale (c_category_mask, c_locale_name, c_base_locale);
 251
 252   if (!c_locale)
 253     locale = SCM_BOOL_F;
 254   else
 255     SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale);
 256
 257   free (c_locale_name);
 258
 259 #else
 260
 261   c_locale = scm_gc_malloc (sizeof (* c_locale), "locale");
 262   c_locale->base_locale = base_locale;
 263
 264   c_locale->category_mask = c_category_mask;
 265   c_locale->locale_name = c_locale_name;
 266
 267   SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale);
 268
 269 #endif
 270
 271   return locale;
 272 }
 273 #undef FUNC_NAME
 274
 275 SCM_DEFINE (scm_locale_p, "locale?", 1, 0, 0,
 276             (SCM obj),
 277             "Return true if @var{obj} is a locale object.")
 278 #define FUNC_NAME s_scm_locale_p
 279 {
 280   if (SCM_SMOB_PREDICATE (scm_tc16_locale_smob_type, obj))
 281     return SCM_BOOL_T;
 282
 283   return SCM_BOOL_F;
 284 }
 285 #undef FUNC_NAME
 286
 287
 288 \f
 289 #ifndef USE_GNU_LOCALE_API  /* Emulate GNU's reentrant locale API.  */
 290
 291
 292 /* Maximum number of chained locales (via `base_locale').  */
 293 #define LOCALE_STACK_SIZE_MAX  256
 294
 295 typedef struct
 296 {
 297 #define SCM_DEFINE_LOCALE_CATEGORY(_name)  char * _name;
 298 #include "locale-categories.h"
 299 #undef SCM_DEFINE_LOCALE_CATEGORY
 300 } scm_t_locale_settings;
 301
 302 /* Fill out SETTINGS according to the current locale settings.  On success
 303    zero is returned and SETTINGS is properly initialized.  */
 304 static int
 305 get_current_locale_settings (scm_t_locale_settings *settings)
 306 {
 307   const char *locale_name;
 308
 309 #define SCM_DEFINE_LOCALE_CATEGORY(_name)                       \
 310   {                                                             \
 311     SCM_SYSCALL (locale_name = setlocale (LC_ ## _name, NULL)); \
 312     if (!locale_name)                                           \
 313       goto handle_error;                                        \
 314                                                                 \
 315     settings-> _name = strdup (locale_name);                    \
 316     if (settings-> _name == NULL)                               \
 317       goto handle_oom;                                          \
 318   }
 319
 320 #include "locale-categories.h"
 321 #undef SCM_DEFINE_LOCALE_CATEGORY
 322
 323   return 0;
 324
 325  handle_error:
 326   return errno;
 327
 328  handle_oom:
 329   return ENOMEM;
 330 }
 331
 332 /* Restore locale settings SETTINGS.  On success, return zero.  */
 333 static int
 334 restore_locale_settings (const scm_t_locale_settings *settings)
 335 {
 336   const char *result;
 337
 338 #define SCM_DEFINE_LOCALE_CATEGORY(_name)                               \
 339   SCM_SYSCALL (result = setlocale (LC_ ## _name, settings-> _name));    \
 340   if (result == NULL)                                                   \
 341     goto handle_error;
 342
 343 #include "locale-categories.h"
 344 #undef SCM_DEFINE_LOCALE_CATEGORY
 345
 346   return 0;
 347
 348  handle_error:
 349   return errno;
 350 }
 351
 352 /* Free memory associated with SETTINGS.  */
 353 static void
 354 free_locale_settings (scm_t_locale_settings *settings)
 355 {
 356 #define SCM_DEFINE_LOCALE_CATEGORY(_name)       \
 357   free (settings-> _name);                      \
 358   settings->_name = NULL;
 359 #include  "locale-categories.h"
 360 #undef SCM_DEFINE_LOCALE_CATEGORY
 361 }
 362
 363 /* Install the locale named LOCALE_NAME for all the categories listed in
 364    CATEGORY_MASK.  */
 365 static int
 366 install_locale_categories (const char *locale_name, int category_mask)
 367 {
 368   const char *result;
 369
 370   if (category_mask == LC_ALL_MASK)
 371     {
 372       SCM_SYSCALL (result = setlocale (LC_ALL, locale_name));
 373       if (result == NULL)
 374         goto handle_error;
 375     }
 376   else
 377     {
 378 #define SCM_DEFINE_LOCALE_CATEGORY(_name)                               \
 379   if (category_mask & LC_ ## _name ## _MASK)                            \
 380     {                                                                   \
 381       SCM_SYSCALL (result = setlocale (LC_ ## _name, locale_name));     \
 382       if (result == NULL)                                               \
 383         goto handle_error;                                              \
 384     }
 385 #include "locale-categories.h"
 386 #undef SCM_DEFINE_LOCALE_CATEGORY
 387     }
 388
 389   return 0;
 390
 391  handle_error:
 392   return errno;
 393 }
 394
 395 /* Install LOCALE, recursively installing its base locales first.  On
 396    success, zero is returned.  */
 397 static int
 398 install_locale (scm_t_locale locale)
 399 {
 400   scm_t_locale stack[LOCALE_STACK_SIZE_MAX];
 401   size_t stack_size = 0;
 402   int stack_offset = 0;
 403   const char *result = NULL;
 404
 405   /* Build up a locale stack by traversing the `base_locale' link.  */
 406   do
 407     {
 408       if (stack_size >= LOCALE_STACK_SIZE_MAX)
 409         /* We cannot use `scm_error ()' here because otherwise the locale
 410            mutex may remain locked.  */
 411         return EINVAL;
 412
 413       stack[stack_size++] = locale;
 414
 415       if (locale->base_locale != SCM_UNDEFINED)
 416         locale = (scm_t_locale)SCM_SMOB_DATA (locale->base_locale);
 417       else
 418         locale = NULL;
 419     }
 420   while (locale != NULL);
 421
 422   /* Install the C locale to start from a pristine state.  */
 423   SCM_SYSCALL (result = setlocale (LC_ALL, "C"));
 424   if (result == NULL)
 425     goto handle_error;
 426
 427   /* Install the locales in reverse order.  */
 428   for (stack_offset = stack_size - 1;
 429        stack_offset >= 0;
 430        stack_offset--)
 431     {
 432       int err;
 433       scm_t_locale locale;
 434
 435       locale = stack[stack_offset];
 436       err = install_locale_categories (locale->locale_name,
 437                                        locale->category_mask);
 438       if (err)
 439         goto handle_error;
 440     }
 441
 442   return 0;
 443
 444  handle_error:
 445   return errno;
 446 }
 447
 448 /* Leave the locked locale section.  */
 449 static inline void
 450 leave_locale_section (const scm_t_locale_settings *settings)
 451 {
 452   /* Restore the previous locale settings.  */
 453   (void)restore_locale_settings (settings);
 454
 455   scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
 456 }
 457
 458 /* Enter a locked locale section.  */
 459 static inline int
 460 enter_locale_section (scm_t_locale locale,
 461                       scm_t_locale_settings *prev_locale)
 462 {
 463   int err;
 464
 465   scm_i_pthread_mutex_lock (&scm_i_locale_mutex);
 466
 467   err = get_current_locale_settings (prev_locale);
 468   if (err)
 469     {
 470       scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
 471       return err;
 472     }
 473
 474   err = install_locale (locale);
 475   if (err)
 476     {
 477       leave_locale_section (prev_locale);
 478       free_locale_settings (prev_locale);
 479     }
 480
 481   return err;
 482 }
 483
 484 /* Throw an exception corresponding to error ERR.  */
 485 static void inline
 486 scm_locale_error (const char *func_name, int err)
 487 {
 488   SCM s_err;
 489
 490   s_err = scm_from_int (err);
 491   scm_error (scm_system_error_key, func_name,
 492              "Failed to install locale",
 493              scm_cons (scm_strerror (s_err), SCM_EOL),
 494              scm_cons (s_err, SCM_EOL));
 495 }
 496
 497 /* Convenient macro to run STATEMENT in the locale context of C_LOCALE.  */
 498 #define RUN_IN_LOCALE_SECTION(_c_locale, _statement)                    \
 499   do                                                                    \
 500    {                                                                    \
 501       int lsec_err;                                                     \
 502       scm_t_locale_settings lsec_prev_locale;                           \
 503                                                                         \
 504       lsec_err = enter_locale_section ((_c_locale), &lsec_prev_locale); \
 505       if (lsec_err)                                                     \
 506         scm_locale_error (FUNC_NAME, lsec_err);                         \
 507       else                                                              \
 508         {                                                               \
 509           _statement ;                                                  \
 510                                                                         \
 511           leave_locale_section (&lsec_prev_locale);                     \
 512           free_locale_settings (&lsec_prev_locale);                     \
 513         }                                                               \
 514    }                                                                    \
 515   while (0)
 516
 517 #endif /* !USE_GNU_LOCALE_API */
 518
 519 \f
 520 /* Locale-dependent string comparison.  */
 521
 522 /* Compare null-terminated strings C_S1 and C_S2 according to LOCALE.  Return
 523    an integer whose sign is the same as the difference between C_S1 and
 524    C_S2.  */
 525 static inline int
 526 compare_strings (const char *c_s1, const char *c_s2, SCM locale,
 527                  const char *func_name)
 528 #define FUNC_NAME func_name
 529 {
 530   int result;
 531   scm_t_locale c_locale;
 532
 533   SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale);
 534
 535   if (c_locale)
 536     {
 537 #ifdef USE_GNU_LOCALE_API
 538       result = strcoll_l (c_s1, c_s2, c_locale);
 539 #else
 540 #ifdef HAVE_STRCOLL
 541       RUN_IN_LOCALE_SECTION (c_locale, result = strcoll (c_s1, c_s2));
 542 #else
 543       result = strcmp (c_s1, c_s2);
 544 #endif
 545 #endif /* !USE_GNU_LOCALE_API */
 546     }
 547   else
 548
 549 #ifdef HAVE_STRCOLL
 550     result = strcoll (c_s1, c_s2);
 551 #else
 552     result = strcmp (c_s1, c_s2);
 553 #endif
 554
 555   return result;
 556 }
 557 #undef FUNC_NAME
 558
 559 /* Store into DST an upper-case version of SRC.  */
 560 static inline void
 561 str_upcase (register char *dst, register const char *src)
 562 {
 563   for (; *src != '\0'; src++, dst++)
 564     *dst = toupper (*src);
 565   *dst = '\0';
 566 }
 567
 568 static inline void
 569 str_downcase (register char *dst, register const char *src)
 570 {
 571   for (; *src != '\0'; src++, dst++)
 572     *dst = tolower (*src);
 573   *dst = '\0';
 574 }
 575
 576 #ifdef USE_GNU_LOCALE_API
 577 static inline void
 578 str_upcase_l (register char *dst, register const char *src,
 579               scm_t_locale locale)
 580 {
 581   for (; *src != '\0'; src++, dst++)
 582     *dst = toupper_l (*src, locale);
 583   *dst = '\0';
 584 }
 585
 586 static inline void
 587 str_downcase_l (register char *dst, register const char *src,
 588                 scm_t_locale locale)
 589 {
 590   for (; *src != '\0'; src++, dst++)
 591     *dst = tolower_l (*src, locale);
 592   *dst = '\0';
 593 }
 594 #endif
 595
 596
 597 /* Compare null-terminated strings C_S1 and C_S2 in a case-independent way
 598    according to LOCALE.  Return an integer whose sign is the same as the
 599    difference between C_S1 and C_S2.  */
 600 static inline int
 601 compare_strings_ci (const char *c_s1, const char *c_s2, SCM locale,
 602                     const char *func_name)
 603 #define FUNC_NAME func_name
 604 {
 605   int result;
 606   scm_t_locale c_locale;
 607   char *c_us1, *c_us2;
 608
 609   SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale);
 610
 611   c_us1 = (char *) alloca (strlen (c_s1) + 1);
 612   c_us2 = (char *) alloca (strlen (c_s2) + 1);
 613
 614   if (c_locale)
 615     {
 616 #ifdef USE_GNU_LOCALE_API
 617       str_upcase_l (c_us1, c_s1, c_locale);
 618       str_upcase_l (c_us2, c_s2, c_locale);
 619
 620       result = strcoll_l (c_us1, c_us2, c_locale);
 621 #else
 622       int err;
 623       scm_t_locale_settings prev_locale;
 624
 625       err = enter_locale_section (c_locale, &prev_locale);
 626       if (err)
 627         {
 628           scm_locale_error (func_name, err);
 629           return 0;
 630         }
 631
 632       str_upcase (c_us1, c_s1);
 633       str_upcase (c_us2, c_s2);
 634
 635 #ifdef HAVE_STRCOLL
 636       result = strcoll (c_us1, c_us2);
 637 #else
 638       result = strcmp (c_us1, c_us2);
 639 #endif /* !HAVE_STRCOLL */
 640
 641       leave_locale_section (&prev_locale);
 642       free_locale_settings (&prev_locale);
 643 #endif /* !USE_GNU_LOCALE_API */
 644     }
 645   else
 646     {
 647       str_upcase (c_us1, c_s1);
 648       str_upcase (c_us2, c_s2);
 649
 650 #ifdef HAVE_STRCOLL
 651       result = strcoll (c_us1, c_us2);
 652 #else
 653       result = strcmp (c_us1, c_us2);
 654 #endif
 655     }
 656
 657   return result;
 658 }
 659 #undef FUNC_NAME
 660
 661
 662 SCM_DEFINE (scm_string_locale_lt, "string-locale<?", 2, 1, 0,
 663             (SCM s1, SCM s2, SCM locale),
 664             "Compare strings @var{s1} and @var{s2} in a locale-dependent way."
 665             "If @var{locale} is provided, it should be locale object (as "
 666             "returned by @code{make-locale}) and will be used to perform the "
 667             "comparison; otherwise, the current system locale is used.")
 668 #define FUNC_NAME s_scm_string_locale_lt
 669 {
 670   int result;
 671   const char *c_s1, *c_s2;
 672
 673   SCM_VALIDATE_STRING (1, s1);
 674   SCM_VALIDATE_STRING (2, s2);
 675
 676   c_s1 = scm_i_string_chars (s1);
 677   c_s2 = scm_i_string_chars (s2);
 678
 679   result = compare_strings (c_s1, c_s2, locale, FUNC_NAME);
 680
 681   scm_remember_upto_here_2 (s1, s2);
 682
 683   return scm_from_bool (result < 0);
 684 }
 685 #undef FUNC_NAME
 686
 687 SCM_DEFINE (scm_string_locale_gt, "string-locale>?", 2, 1, 0,
 688             (SCM s1, SCM s2, SCM locale),
 689             "Compare strings @var{s1} and @var{s2} in a locale-dependent way."
 690             "If @var{locale} is provided, it should be locale object (as "
 691             "returned by @code{make-locale}) and will be used to perform the "
 692             "comparison; otherwise, the current system locale is used.")
 693 #define FUNC_NAME s_scm_string_locale_gt
 694 {
 695   int result;
 696   const char *c_s1, *c_s2;
 697
 698   SCM_VALIDATE_STRING (1, s1);
 699   SCM_VALIDATE_STRING (2, s2);
 700
 701   c_s1 = scm_i_string_chars (s1);
 702   c_s2 = scm_i_string_chars (s2);
 703
 704   result = compare_strings (c_s1, c_s2, locale, FUNC_NAME);
 705
 706   scm_remember_upto_here_2 (s1, s2);
 707
 708   return scm_from_bool (result > 0);
 709 }
 710 #undef FUNC_NAME
 711
 712 SCM_DEFINE (scm_string_locale_ci_lt, "string-locale-ci<?", 2, 1, 0,
 713             (SCM s1, SCM s2, SCM locale),
 714             "Compare strings @var{s1} and @var{s2} in a case-insensitive, "
 715             "and locale-dependent way.  If @var{locale} is provided, it "
 716             "should be locale object (as returned by @code{make-locale}) "
 717             "and will be used to perform the comparison; otherwise, the "
 718             "current system locale is used.")
 719 #define FUNC_NAME s_scm_string_locale_ci_lt
 720 {
 721   int result;
 722   const char *c_s1, *c_s2;
 723
 724   SCM_VALIDATE_STRING (1, s1);
 725   SCM_VALIDATE_STRING (2, s2);
 726
 727   c_s1 = scm_i_string_chars (s1);
 728   c_s2 = scm_i_string_chars (s2);
 729
 730   result = compare_strings_ci (c_s1, c_s2, locale, FUNC_NAME);
 731
 732   scm_remember_upto_here_2 (s1, s2);
 733
 734   return scm_from_bool (result < 0);
 735 }
 736 #undef FUNC_NAME
 737
 738 SCM_DEFINE (scm_string_locale_ci_gt, "string-locale-ci>?", 2, 1, 0,
 739             (SCM s1, SCM s2, SCM locale),
 740             "Compare strings @var{s1} and @var{s2} in a case-insensitive, "
 741             "and locale-dependent way.  If @var{locale} is provided, it "
 742             "should be locale object (as returned by @code{make-locale}) "
 743             "and will be used to perform the comparison; otherwise, the "
 744             "current system locale is used.")
 745 #define FUNC_NAME s_scm_string_locale_ci_gt
 746 {
 747   int result;
 748   const char *c_s1, *c_s2;
 749
 750   SCM_VALIDATE_STRING (1, s1);
 751   SCM_VALIDATE_STRING (2, s2);
 752
 753   c_s1 = scm_i_string_chars (s1);
 754   c_s2 = scm_i_string_chars (s2);
 755
 756   result = compare_strings_ci (c_s1, c_s2, locale, FUNC_NAME);
 757
 758   scm_remember_upto_here_2 (s1, s2);
 759
 760   return scm_from_bool (result > 0);
 761 }
 762 #undef FUNC_NAME
 763
 764 SCM_DEFINE (scm_string_locale_ci_eq, "string-locale-ci=?", 2, 1, 0,
 765             (SCM s1, SCM s2, SCM locale),
 766             "Compare strings @var{s1} and @var{s2} in a case-insensitive, "
 767             "and locale-dependent way.  If @var{locale} is provided, it "
 768             "should be locale object (as returned by @code{make-locale}) "
 769             "and will be used to perform the comparison; otherwise, the "
 770             "current system locale is used.")
 771 #define FUNC_NAME s_scm_string_locale_ci_eq
 772 {
 773   int result;
 774   const char *c_s1, *c_s2;
 775
 776   SCM_VALIDATE_STRING (1, s1);
 777   SCM_VALIDATE_STRING (2, s2);
 778
 779   c_s1 = scm_i_string_chars (s1);
 780   c_s2 = scm_i_string_chars (s2);
 781
 782   result = compare_strings_ci (c_s1, c_s2, locale, FUNC_NAME);
 783
 784   scm_remember_upto_here_2 (s1, s2);
 785
 786   return scm_from_bool (result == 0);
 787 }
 788 #undef FUNC_NAME
 789
 790
 791 SCM_DEFINE (scm_char_locale_lt, "char-locale<?", 2, 1, 0,
 792             (SCM c1, SCM c2, SCM locale),
 793             "Return true if character @var{c1} is lower than @var{c2} "
 794             "according to @var{locale} or to the current locale.")
 795 #define FUNC_NAME s_scm_char_locale_lt
 796 {
 797   char c_c1[2], c_c2[2];
 798
 799   SCM_VALIDATE_CHAR (1, c1);
 800   SCM_VALIDATE_CHAR (2, c2);
 801
 802   c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0';
 803   c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0';
 804
 805   return scm_from_bool (compare_strings (c_c1, c_c2, locale, FUNC_NAME) < 0);
 806 }
 807 #undef FUNC_NAME
 808
 809 SCM_DEFINE (scm_char_locale_gt, "char-locale>?", 2, 1, 0,
 810             (SCM c1, SCM c2, SCM locale),
 811             "Return true if character @var{c1} is greater than @var{c2} "
 812             "according to @var{locale} or to the current locale.")
 813 #define FUNC_NAME s_scm_char_locale_gt
 814 {
 815   char c_c1[2], c_c2[2];
 816
 817   SCM_VALIDATE_CHAR (1, c1);
 818   SCM_VALIDATE_CHAR (2, c2);
 819
 820   c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0';
 821   c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0';
 822
 823   return scm_from_bool (compare_strings (c_c1, c_c2, locale, FUNC_NAME) > 0);
 824 }
 825 #undef FUNC_NAME
 826
 827 SCM_DEFINE (scm_char_locale_ci_lt, "char-locale-ci<?", 2, 1, 0,
 828             (SCM c1, SCM c2, SCM locale),
 829             "Return true if character @var{c1} is lower than @var{c2}, "
 830             "in a case insensitive way according to @var{locale} or to "
 831             "the current locale.")
 832 #define FUNC_NAME s_scm_char_locale_ci_lt
 833 {
 834   int result;
 835   char c_c1[2], c_c2[2];
 836
 837   SCM_VALIDATE_CHAR (1, c1);
 838   SCM_VALIDATE_CHAR (2, c2);
 839
 840   c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0';
 841   c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0';
 842
 843   result = compare_strings_ci (c_c1, c_c2, locale, FUNC_NAME);
 844
 845   return scm_from_bool (result < 0);
 846 }
 847 #undef FUNC_NAME
 848
 849 SCM_DEFINE (scm_char_locale_ci_gt, "char-locale-ci>?", 2, 1, 0,
 850             (SCM c1, SCM c2, SCM locale),
 851             "Return true if character @var{c1} is greater than @var{c2}, "
 852             "in a case insensitive way according to @var{locale} or to "
 853             "the current locale.")
 854 #define FUNC_NAME s_scm_char_locale_ci_gt
 855 {
 856   int result;
 857   char c_c1[2], c_c2[2];
 858
 859   SCM_VALIDATE_CHAR (1, c1);
 860   SCM_VALIDATE_CHAR (2, c2);
 861
 862   c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0';
 863   c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0';
 864
 865   result = compare_strings_ci (c_c1, c_c2, locale, FUNC_NAME);
 866
 867   return scm_from_bool (result > 0);
 868 }
 869 #undef FUNC_NAME
 870
 871 SCM_DEFINE (scm_char_locale_ci_eq, "char-locale-ci=?", 2, 1, 0,
 872             (SCM c1, SCM c2, SCM locale),
 873             "Return true if character @var{c1} is equal to @var{c2}, "
 874             "in a case insensitive way according to @var{locale} or to "
 875             "the current locale.")
 876 #define FUNC_NAME s_scm_char_locale_ci_eq
 877 {
 878   int result;
 879   char c_c1[2], c_c2[2];
 880
 881   SCM_VALIDATE_CHAR (1, c1);
 882   SCM_VALIDATE_CHAR (2, c2);
 883
 884   c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0';
 885   c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0';
 886
 887   result = compare_strings_ci (c_c1, c_c2, locale, FUNC_NAME);
 888
 889   return scm_from_bool (result == 0);
 890 }
 891 #undef FUNC_NAME
 892
 893
 894 \f
 895 /* Locale-dependent alphabetic character mapping.  */
 896
 897 SCM_DEFINE (scm_char_locale_downcase, "char-locale-downcase", 1, 1, 0,
 898             (SCM chr, SCM locale),
 899             "Return the lowercase character that corresponds to @var{chr} "
 900             "according to either @var{locale} or the current locale.")
 901 #define FUNC_NAME s_scm_char_locale_downcase
 902 {
 903   char c_chr;
 904   int c_result;
 905   scm_t_locale c_locale;
 906
 907   SCM_VALIDATE_CHAR (1, chr);
 908   c_chr = SCM_CHAR (chr);
 909
 910   SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
 911
 912   if (c_locale != NULL)
 913     {
 914 #ifdef USE_GNU_LOCALE_API
 915       c_result = tolower_l (c_chr, c_locale);
 916 #else
 917       RUN_IN_LOCALE_SECTION (c_locale, c_result = tolower (c_chr));
 918 #endif
 919     }
 920   else
 921     c_result = tolower (c_chr);
 922
 923   return (SCM_MAKE_CHAR (c_result));
 924 }
 925 #undef FUNC_NAME
 926
 927 SCM_DEFINE (scm_char_locale_upcase, "char-locale-upcase", 1, 1, 0,
 928             (SCM chr, SCM locale),
 929             "Return the uppercase character that corresponds to @var{chr} "
 930             "according to either @var{locale} or the current locale.")
 931 #define FUNC_NAME s_scm_char_locale_upcase
 932 {
 933   char c_chr;
 934   int c_result;
 935   scm_t_locale c_locale;
 936
 937   SCM_VALIDATE_CHAR (1, chr);
 938   c_chr = SCM_CHAR (chr);
 939
 940   SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
 941
 942   if (c_locale != NULL)
 943     {
 944 #ifdef USE_GNU_LOCALE_API
 945       c_result = toupper_l (c_chr, c_locale);
 946 #else
 947       RUN_IN_LOCALE_SECTION (c_locale, c_result = toupper (c_chr));
 948 #endif
 949     }
 950   else
 951     c_result = toupper (c_chr);
 952
 953   return (SCM_MAKE_CHAR (c_result));
 954 }
 955 #undef FUNC_NAME
 956
 957 SCM_DEFINE (scm_string_locale_upcase, "string-locale-upcase", 1, 1, 0,
 958             (SCM str, SCM locale),
 959             "Return a new string that is the uppercase version of "
 960             "@var{str} according to either @var{locale} or the current "
 961             "locale.")
 962 #define FUNC_NAME s_scm_string_locale_upcase
 963 {
 964   const char *c_str;
 965   char *c_ustr;
 966   scm_t_locale c_locale;
 967
 968   SCM_VALIDATE_STRING (1, str);
 969   SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
 970
 971   c_str = scm_i_string_chars (str);
 972   c_ustr = (char *) alloca (strlen (c_str) + 1);
 973
 974   if (c_locale)
 975     {
 976 #ifdef USE_GNU_LOCALE_API
 977       str_upcase_l (c_ustr, c_str, c_locale);
 978 #else
 979       RUN_IN_LOCALE_SECTION (c_locale, str_upcase (c_ustr, c_str));
 980 #endif
 981     }
 982   else
 983     str_upcase (c_ustr, c_str);
 984
 985   scm_remember_upto_here (str);
 986
 987   return (scm_from_locale_string (c_ustr));
 988 }
 989 #undef FUNC_NAME
 990
 991 SCM_DEFINE (scm_string_locale_downcase, "string-locale-downcase", 1, 1, 0,
 992             (SCM str, SCM locale),
 993             "Return a new string that is the down-case version of "
 994             "@var{str} according to either @var{locale} or the current "
 995             "locale.")
 996 #define FUNC_NAME s_scm_string_locale_downcase
 997 {
 998   const char *c_str;
 999   char *c_lstr;
1000   scm_t_locale c_locale;
1001
1002   SCM_VALIDATE_STRING (1, str);
1003   SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
1004
1005   c_str = scm_i_string_chars (str);
1006   c_lstr = (char *) alloca (strlen (c_str) + 1);
1007
1008   if (c_locale)
1009     {
1010 #ifdef USE_GNU_LOCALE_API
1011       str_downcase_l (c_lstr, c_str, c_locale);
1012 #else
1013       RUN_IN_LOCALE_SECTION (c_locale, str_downcase (c_lstr, c_str));
1014 #endif
1015     }
1016   else
1017     str_downcase (c_lstr, c_str);
1018
1019   scm_remember_upto_here (str);
1020
1021   return (scm_from_locale_string (c_lstr));
1022 }
1023 #undef FUNC_NAME
1024
1025 /* Note: We don't provide mutative versions of `string-locale-(up|down)case'
1026    because, in some languages, a single downcase character maps to a couple
1027    of uppercase characters.  Read the SRFI-13 document for a detailed
1028    discussion about this.  */
1029
1030
1031 \f
1032 /* Locale-dependent number parsing.  */
1033
1034 SCM_DEFINE (scm_locale_string_to_integer, "locale-string->integer",
1035             1, 2, 0, (SCM str, SCM base, SCM locale),
1036             "Convert string @var{str} into an integer according to either "
1037             "@var{locale} (a locale object as returned by @code{make-locale}) "
1038             "or the current process locale.  Return two values: an integer "
1039             "(on success) or @code{#f}, and the number of characters read "
1040             "from @var{str} (@code{0} on failure).")
1041 #define FUNC_NAME s_scm_locale_string_to_integer
1042 {
1043   SCM result;
1044   long c_result;
1045   int c_base;
1046   const char *c_str;
1047   char *c_endptr;
1048   scm_t_locale c_locale;
1049
1050   SCM_VALIDATE_STRING (1, str);
1051   c_str = scm_i_string_chars (str);
1052
1053   if (base != SCM_UNDEFINED)
1054     SCM_VALIDATE_INT_COPY (2, base, c_base);
1055   else
1056     c_base = 10;
1057
1058   SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale);
1059
1060   if (c_locale != NULL)
1061     {
1062 #ifdef USE_GNU_LOCALE_API
1063       c_result = strtol_l (c_str, &c_endptr, c_base, c_locale);
1064 #else
1065       RUN_IN_LOCALE_SECTION (c_locale,
1066                              c_result = strtol (c_str, &c_endptr, c_base));
1067 #endif
1068     }
1069   else
1070     c_result = strtol (c_str, &c_endptr, c_base);
1071
1072   scm_remember_upto_here (str);
1073
1074   if (c_endptr == c_str)
1075     result = SCM_BOOL_F;
1076   else
1077     result = scm_from_long (c_result);
1078
1079   return (scm_values (scm_list_2 (result, scm_from_long (c_endptr - c_str))));
1080 }
1081 #undef FUNC_NAME
1082
1083 SCM_DEFINE (scm_locale_string_to_inexact, "locale-string->inexact",
1084             1, 1, 0, (SCM str, SCM locale),
1085             "Convert string @var{str} into an inexact number according to "
1086             "either @var{locale} (a locale object as returned by "
1087             "@code{make-locale}) or the current process locale.  Return "
1088             "two values: an inexact number (on success) or @code{#f}, and "
1089             "the number of characters read from @var{str} (@code{0} on "
1090             "failure).")
1091 #define FUNC_NAME s_scm_locale_string_to_inexact
1092 {
1093   SCM result;
1094   double c_result;
1095   const char *c_str;
1096   char *c_endptr;
1097   scm_t_locale c_locale;
1098
1099   SCM_VALIDATE_STRING (1, str);
1100   c_str = scm_i_string_chars (str);
1101
1102   SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
1103
1104   if (c_locale != NULL)
1105     {
1106 #ifdef USE_GNU_LOCALE_API
1107       c_result = strtod_l (c_str, &c_endptr, c_locale);
1108 #else
1109       RUN_IN_LOCALE_SECTION (c_locale,
1110                              c_result = strtod (c_str, &c_endptr));
1111 #endif
1112     }
1113   else
1114     c_result = strtod (c_str, &c_endptr);
1115
1116   scm_remember_upto_here (str);
1117
1118   if (c_endptr == c_str)
1119     result = SCM_BOOL_F;
1120   else
1121     result = scm_from_double (c_result);
1122
1123   return (scm_values (scm_list_2 (result, scm_from_long (c_endptr - c_str))));
1124 }
1125 #undef FUNC_NAME
1126
1127
1128 \f
1129 void
1130 scm_init_i18n ()
1131 {
1132   scm_add_feature ("ice-9-i18n");
1133
1134 #define _SCM_STRINGIFY_LC(_name)  # _name
1135 #define SCM_STRINGIFY_LC(_name)   _SCM_STRINGIFY_LC (_name)
1136
1137   /* Define all the relevant `_MASK' variables.  */
1138 #define SCM_DEFINE_LOCALE_CATEGORY(_name)               \
1139   scm_c_define ("LC_" SCM_STRINGIFY_LC (_name) "_MASK", \
1140                 SCM_I_MAKINUM (LC_ ## _name ## _MASK));
1141 #include "locale-categories.h"
1142
1143 #undef SCM_DEFINE_LOCALE_CATEGORY
1144 #undef SCM_STRINGIFY_LC
1145 #undef _SCM_STRINGIFY_LC
1146
1147   scm_c_define ("LC_ALL_MASK", SCM_I_MAKINUM (LC_ALL_MASK));
1148
1149 #include "libguile/i18n.x"
1150
1151 #ifndef USE_GNU_LOCALE_API
1152   scm_set_smob_mark (scm_tc16_locale_smob_type, smob_locale_mark);
1153 #endif
1154 }
1155
1156
1157 /*
1158   Local Variables:
1159   c-file-style: "gnu"
1160   End:
1161 */