libguile/i18n.c

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