libguile/i18n.c

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