libguile/i18n.c

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