libguile/i18n.c

   1 /* Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16  * 02110-1301 USA
  17  */
  18
  19 #ifdef HAVE_CONFIG_H
  20 # include <config.h>
  21 #endif
  22
  23 #include <alloca.h>
  24
  25 #include "libguile/_scm.h"
  26 #include "libguile/extensions.h"
  27 #include "libguile/feature.h"
  28 #include "libguile/i18n.h"
  29 #include "libguile/strings.h"
  30 #include "libguile/chars.h"
  31 #include "libguile/dynwind.h"
  32 #include "libguile/validate.h"
  33 #include "libguile/values.h"
  34 #include "libguile/threads.h"
  35
  36 #include <locale.h>
  37 #include <string.h> /* `strcoll ()' */
  38 #include <ctype.h>  /* `toupper ()' et al. */
  39 #include <errno.h>
  40 #include <unicase.h>
  41 #include <unistr.h>
  42
  43 #if (defined HAVE_NEWLOCALE) && (defined HAVE_STRCOLL_L)
  44 /* The GNU thread-aware locale API is documented in ``Thread-Aware Locale
  45    Model, a Proposal'', by Ulrich Drepper:
  46
  47      http://people.redhat.com/drepper/tllocale.ps.gz
  48
  49    It is now also implemented by Darwin:
  50
  51      http://developer.apple.com/documentation/Darwin/Reference/ManPages/man3/newlocale.3.html
  52
  53    The whole API was eventually standardized in the ``Open Group Base
  54    Specifications Issue 7'' (aka. "POSIX 2008"):
  55
  56      http://www.opengroup.org/onlinepubs/9699919799/basedefs/locale.h.html  */
  57 # define USE_GNU_LOCALE_API
  58 #endif
  59
  60 #include "libguile/posix.h"  /* for `scm_i_locale_mutex' */
  61
  62 /* Use Gnulib's header, which also provides `nl_item' & co.  */
  63 #include <langinfo.h>
  64
  65 #ifndef HAVE_SETLOCALE
  66 static inline char *
  67 setlocale (int category, const char *name)
  68 {
  69   errno = ENOSYS;
  70   return NULL;
  71 }
  72 #endif
  73
  74 /* Helper stringification macro.  */
  75 #define SCM_I18N_STRINGIFY(_name)   # _name
  76
  77 /* Acquiring and releasing the locale lock.  */
  78
  79 static inline void
  80 lock_locale_mutex (void)
  81 {
  82 #ifdef HAVE_POSIX
  83   scm_i_pthread_mutex_lock (&scm_i_locale_mutex);
  84 #else
  85 #endif
  86 }
  87
  88 static inline void
  89 unlock_locale_mutex (void)
  90 {
  91 #ifdef HAVE_POSIX
  92   scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
  93 #else
  94 #endif
  95 }
  96
  97 \f
  98 /* Locale objects, string and character collation, and other locale-dependent
  99    string operations.
 100
 101    A large part of the code here deals with emulating glibc's reentrant
 102    locale API on non-GNU systems.  The emulation is a bit "brute-force":
 103    Whenever a `-locale<?' procedure is passed a locale object, then:
 104
 105    1. The `scm_i_locale_mutex' is locked.
 106    2. A series of `setlocale ()' call is performed to store the current
 107       locale for each category in an `scm_t_locale' object.
 108    3. A series of `setlocale ()' call is made to install each of the locale
 109       categories of each of the base locales of each locale object,
 110       recursively, starting from the last locale object of the chain.
 111    4. The settings captured in step (2) are restored.
 112    5. The `scm_i_locale_mutex' is released.
 113
 114    Hopefully, the X/Open standard will eventually make this hack useless.
 115
 116    Note: We don't wrap glibc's `uselocale ()' call because it sets the locale
 117    of the current _thread_ (unlike `setlocale ()') and doing so would require
 118    maintaining per-thread locale information on non-GNU systems and always
 119    re-installing this locale upon locale-dependent calls.  */
 120
 121
 122 /* Return the category mask corresponding to CAT.  */
 123 #define SCM_LOCALE_CATEGORY_MASK(_cat)    LC_ ## _cat ## _MASK
 124
 125
 126 #ifndef USE_GNU_LOCALE_API
 127
 128 /* Provide the locale category masks as found in glibc.  This must be kept in
 129    sync with `locale-categories.h'.  */
 130
 131 # define LC_CTYPE_MASK          1
 132 # define LC_COLLATE_MASK        2
 133 # define LC_MESSAGES_MASK       4
 134 # define LC_MONETARY_MASK       8
 135 # define LC_NUMERIC_MASK        16
 136 # define LC_TIME_MASK           32
 137
 138 # ifdef LC_PAPER
 139 #   define LC_PAPER_MASK        64
 140 # else
 141 #   define LC_PAPER_MASK        0
 142 # endif
 143 # ifdef LC_NAME
 144 #   define LC_NAME_MASK         128
 145 # else
 146 #   define LC_NAME_MASK         0
 147 # endif
 148 # ifdef LC_ADDRESS
 149 #   define LC_ADDRESS_MASK      256
 150 # else
 151 #   define LC_ADDRESS_MASK      0
 152 # endif
 153 # ifdef LC_TELEPHONE
 154 #   define LC_TELEPHONE_MASK    512
 155 # else
 156 #   define LC_TELEPHONE_MASK    0
 157 # endif
 158 # ifdef LC_MEASUREMENT
 159 #   define LC_MEASUREMENT_MASK  1024
 160 # else
 161 #   define LC_MEASUREMENT_MASK  0
 162 # endif
 163 # ifdef LC_IDENTIFICATION
 164 #   define LC_IDENTIFICATION_MASK 2048
 165 # else
 166 #   define LC_IDENTIFICATION_MASK 0
 167 # endif
 168
 169 # define LC_ALL_MASK            (LC_CTYPE_MASK                  \
 170                                  | LC_NUMERIC_MASK              \
 171                                  | LC_TIME_MASK                 \
 172                                  | LC_COLLATE_MASK              \
 173                                  | LC_MONETARY_MASK             \
 174                                  | LC_MESSAGES_MASK             \
 175                                  | LC_PAPER_MASK                \
 176                                  | LC_NAME_MASK                 \
 177                                  | LC_ADDRESS_MASK              \
 178                                  | LC_TELEPHONE_MASK            \
 179                                  | LC_MEASUREMENT_MASK          \
 180                                  | LC_IDENTIFICATION_MASK       \
 181                                  )
 182
 183 /* Locale objects as returned by `make-locale' on non-GNU systems.  */
 184 typedef struct scm_locale
 185 {
 186   SCM   base_locale; /* a `locale' object */
 187   char *locale_name;
 188   int   category_mask;
 189 } *scm_t_locale;
 190
 191 #else /* USE_GNU_LOCALE_API */
 192
 193 /* Alias for glibc's locale type.  */
 194 typedef locale_t scm_t_locale;
 195
 196 #endif /* USE_GNU_LOCALE_API */
 197
 198
 199 /* A locale object denoting the global locale.  */
 200 SCM_GLOBAL_VARIABLE (scm_global_locale, "%global-locale");
 201
 202
 203 /* Validate parameter ARG as a locale object and set C_LOCALE to the
 204    corresponding C locale object.  */
 205 #define SCM_VALIDATE_LOCALE_COPY(_pos, _arg, _c_locale)         \
 206   do                                                            \
 207     {                                                           \
 208       SCM_VALIDATE_SMOB ((_pos), (_arg), locale_smob_type);     \
 209       (_c_locale) = (scm_t_locale)SCM_SMOB_DATA (_arg);         \
 210     }                                                           \
 211   while (0)
 212
 213 /* Validate optional parameter ARG as either undefined or bound to a locale
 214    object.  Set C_LOCALE to the corresponding C locale object or NULL.  */
 215 #define SCM_VALIDATE_OPTIONAL_LOCALE_COPY(_pos, _arg, _c_locale)        \
 216   do                                                                    \
 217     {                                                                   \
 218       if (!SCM_UNBNDP (_arg))                                           \
 219         SCM_VALIDATE_LOCALE_COPY (_pos, _arg, _c_locale);               \
 220       else                                                              \
 221         (_c_locale) = NULL;                                             \
 222     }                                                                   \
 223   while (0)
 224
 225
 226 SCM_SMOB (scm_tc16_locale_smob_type, "locale", 0);
 227
 228 #ifdef USE_GNU_LOCALE_API
 229
 230 SCM_SMOB_FREE (scm_tc16_locale_smob_type, smob_locale_free, locale)
 231 {
 232   scm_t_locale c_locale;
 233
 234   c_locale = (scm_t_locale) SCM_SMOB_DATA (locale);
 235   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
1469 SCM_DEFINE (scm_nl_langinfo, "nl-langinfo", 1, 1, 0,
1470             (SCM item, SCM locale),
1471             "Return a string denoting locale information for @var{item} "
1472             "in the current locale or that specified by @var{locale}.  "
1473             "The semantics and arguments are the same as those of the "
1474             "X/Open @code{nl_langinfo} function (@pxref{The Elegant and "
1475             "Fast Way, @code{nl_langinfo},, libc, The GNU C Library "
1476             "Reference Manual}).")
1477 #define FUNC_NAME s_scm_nl_langinfo
1478 {
1479   SCM result;
1480   nl_item c_item;
1481   char *c_result;
1482   scm_t_locale c_locale;
1483   char *codeset;
1484
1485   SCM_VALIDATE_INT_COPY (2, item, c_item);
1486   SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
1487
1488   /* Sadly, `nl_langinfo ()' returns a pointer to a static string.  According
1489      to SuS v2, that static string may be modified by subsequent calls to
1490      `nl_langinfo ()' as well as by calls to `setlocale ()'.  Thus, we must
1491      acquire the locale mutex before doing invoking `nl_langinfo ()'.  See
1492      http://opengroup.org/onlinepubs/007908799/xsh/nl_langinfo.html for
1493      details.  */
1494
1495   lock_locale_mutex ();
1496   if (c_locale != NULL)
1497     {
1498 #ifdef USE_GNU_LOCALE_API
1499       c_result = nl_langinfo_l (c_item, c_locale);
1500       codeset = nl_langinfo_l (CODESET, c_locale);
1501 #else /* !USE_GNU_LOCALE_API */
1502       /* We can't use `RUN_IN_LOCALE_SECTION ()' here because the locale
1503          mutex is already taken.  */
1504       int lsec_err;
1505       scm_t_locale_settings lsec_prev_locale;
1506
1507       lsec_err = get_current_locale_settings (&lsec_prev_locale);
1508       if (lsec_err)
1509         unlock_locale_mutex ();
1510       else
1511         {
1512           lsec_err = install_locale (c_locale);
1513           if (lsec_err)
1514             {
1515               leave_locale_section (&lsec_prev_locale);
1516               free_locale_settings (&lsec_prev_locale);
1517             }
1518         }
1519
1520       if (lsec_err)
1521         scm_locale_error (FUNC_NAME, lsec_err);
1522       else
1523         {
1524           c_result = nl_langinfo (c_item);
1525           codeset = nl_langinfo (CODESET);
1526
1527           restore_locale_settings (&lsec_prev_locale);
1528           free_locale_settings (&lsec_prev_locale);
1529         }
1530 #endif
1531     }
1532   else
1533     {
1534       c_result = nl_langinfo (c_item);
1535       codeset = nl_langinfo (CODESET);
1536     }
1537
1538   if (c_result != NULL)
1539     c_result = strdup (c_result);
1540
1541   unlock_locale_mutex ();
1542
1543   if (c_result == NULL)
1544     result = SCM_BOOL_F;
1545   else
1546     {
1547       switch (c_item)
1548         {
1549 #if (defined GROUPING) && (defined MON_GROUPING)
1550         case GROUPING:
1551         case MON_GROUPING:
1552           {
1553             char *p;
1554
1555             /* In this cases, the result is to be interpreted as a list
1556                of numbers.  If the last item is `CHAR_MAX' or a negative
1557                number, it has the special meaning "no more grouping"
1558                (negative numbers aren't specified in POSIX but can be
1559                used by glibc; see
1560                <http://lists.gnu.org/archive/html/bug-guile/2011-02/msg00159.html>).  */
1561             result = SCM_EOL;
1562             for (p = c_result; (*p > 0) && (*p != CHAR_MAX); p++)
1563               result = scm_cons (SCM_I_MAKINUM ((int) *p), result);
1564
1565             {
1566               SCM last_pair = result;
1567
1568               result = scm_reverse_x (result, SCM_EOL);
1569
1570               if (*p == 0)
1571                 {
1572                   /* Cyclic grouping information.  */
1573                   if (!scm_is_null (last_pair))
1574                     SCM_SETCDR (last_pair, result);
1575                 }
1576             }
1577
1578             free (c_result);
1579             break;
1580           }
1581 #endif
1582
1583 #if (defined FRAC_DIGITS) && (defined INT_FRAC_DIGITS)
1584         case FRAC_DIGITS:
1585         case INT_FRAC_DIGITS:
1586           /* This is to be interpreted as a single integer.  */
1587           if (*c_result == CHAR_MAX)
1588             /* Unspecified.  */
1589             result = SCM_BOOL_F;
1590           else
1591             result = SCM_I_MAKINUM (*c_result);
1592
1593           free (c_result);
1594           break;
1595 #endif
1596
1597 #if (defined P_CS_PRECEDES) && (defined INT_N_CS_PRECEDES)
1598         case P_CS_PRECEDES:
1599         case N_CS_PRECEDES:
1600         case INT_P_CS_PRECEDES:
1601         case INT_N_CS_PRECEDES:
1602 #if (defined P_SEP_BY_SPACE) && (defined N_SEP_BY_SPACE)
1603         case P_SEP_BY_SPACE:
1604         case N_SEP_BY_SPACE:
1605 #endif
1606           /* This is to be interpreted as a boolean.  */
1607           result = scm_from_bool (*c_result);
1608
1609           free (c_result);
1610           break;
1611 #endif
1612
1613 #if (defined P_SIGN_POSN) && (defined INT_N_SIGN_POSN)
1614         case P_SIGN_POSN:
1615         case N_SIGN_POSN:
1616         case INT_P_SIGN_POSN:
1617         case INT_N_SIGN_POSN:
1618           /* See `(libc) Sign of Money Amount' for the interpretation of the
1619              return value here.  */
1620           switch (*c_result)
1621             {
1622             case 0:
1623               result = scm_from_latin1_symbol ("parenthesize");
1624               break;
1625
1626             case 1:
1627               result = scm_from_latin1_symbol ("sign-before");
1628               break;
1629
1630             case 2:
1631               result = scm_from_latin1_symbol ("sign-after");
1632               break;
1633
1634             case 3:
1635               result = scm_from_latin1_symbol ("sign-before-currency-symbol");
1636               break;
1637
1638             case 4:
1639               result = scm_from_latin1_symbol ("sign-after-currency-symbol");
1640               break;
1641
1642             default:
1643               result = scm_from_latin1_symbol ("unspecified");
1644             }
1645           free (c_result);
1646           break;
1647 #endif
1648
1649         default:
1650           result = scm_from_stringn (c_result, strlen (c_result),
1651                                      codeset,
1652                                      SCM_FAILED_CONVERSION_QUESTION_MARK);
1653           free (c_result);
1654         }
1655     }
1656
1657   return result;
1658 }
1659 #undef FUNC_NAME
1660
1661 /* Define the `nl_item' constants.  */
1662 static inline void
1663 define_langinfo_items (void)
1664 {
1665 #define DEFINE_NLITEM_CONSTANT(_item)           \
1666   scm_c_define (# _item, scm_from_int (_item))
1667
1668   DEFINE_NLITEM_CONSTANT (CODESET);
1669
1670   /* Abbreviated days of the week. */
1671   DEFINE_NLITEM_CONSTANT (ABDAY_1);
1672   DEFINE_NLITEM_CONSTANT (ABDAY_2);
1673   DEFINE_NLITEM_CONSTANT (ABDAY_3);
1674   DEFINE_NLITEM_CONSTANT (ABDAY_4);
1675   DEFINE_NLITEM_CONSTANT (ABDAY_5);
1676   DEFINE_NLITEM_CONSTANT (ABDAY_6);
1677   DEFINE_NLITEM_CONSTANT (ABDAY_7);
1678
1679   /* Long-named days of the week. */
1680   DEFINE_NLITEM_CONSTANT (DAY_1);       /* Sunday */
1681   DEFINE_NLITEM_CONSTANT (DAY_2);       /* Monday */
1682   DEFINE_NLITEM_CONSTANT (DAY_3);       /* Tuesday */
1683   DEFINE_NLITEM_CONSTANT (DAY_4);       /* Wednesday */
1684   DEFINE_NLITEM_CONSTANT (DAY_5);       /* Thursday */
1685   DEFINE_NLITEM_CONSTANT (DAY_6);       /* Friday */
1686   DEFINE_NLITEM_CONSTANT (DAY_7);       /* Saturday */
1687
1688   /* Abbreviated month names.  */
1689   DEFINE_NLITEM_CONSTANT (ABMON_1);     /* Jan */
1690   DEFINE_NLITEM_CONSTANT (ABMON_2);
1691   DEFINE_NLITEM_CONSTANT (ABMON_3);
1692   DEFINE_NLITEM_CONSTANT (ABMON_4);
1693   DEFINE_NLITEM_CONSTANT (ABMON_5);
1694   DEFINE_NLITEM_CONSTANT (ABMON_6);
1695   DEFINE_NLITEM_CONSTANT (ABMON_7);
1696   DEFINE_NLITEM_CONSTANT (ABMON_8);
1697   DEFINE_NLITEM_CONSTANT (ABMON_9);
1698   DEFINE_NLITEM_CONSTANT (ABMON_10);
1699   DEFINE_NLITEM_CONSTANT (ABMON_11);
1700   DEFINE_NLITEM_CONSTANT (ABMON_12);
1701
1702   /* Long month names.  */
1703   DEFINE_NLITEM_CONSTANT (MON_1);       /* January */
1704   DEFINE_NLITEM_CONSTANT (MON_2);
1705   DEFINE_NLITEM_CONSTANT (MON_3);
1706   DEFINE_NLITEM_CONSTANT (MON_4);
1707   DEFINE_NLITEM_CONSTANT (MON_5);
1708   DEFINE_NLITEM_CONSTANT (MON_6);
1709   DEFINE_NLITEM_CONSTANT (MON_7);
1710   DEFINE_NLITEM_CONSTANT (MON_8);
1711   DEFINE_NLITEM_CONSTANT (MON_9);
1712   DEFINE_NLITEM_CONSTANT (MON_10);
1713   DEFINE_NLITEM_CONSTANT (MON_11);
1714   DEFINE_NLITEM_CONSTANT (MON_12);
1715
1716   DEFINE_NLITEM_CONSTANT (AM_STR);      /* Ante meridiem string.  */
1717   DEFINE_NLITEM_CONSTANT (PM_STR);      /* Post meridiem string.  */
1718
1719   DEFINE_NLITEM_CONSTANT (D_T_FMT); /* Date and time format for strftime.  */
1720   DEFINE_NLITEM_CONSTANT (D_FMT);   /* Date format for strftime.  */
1721   DEFINE_NLITEM_CONSTANT (T_FMT);   /* Time format for strftime.  */
1722   DEFINE_NLITEM_CONSTANT (T_FMT_AMPM);/* 12-hour time format for strftime.  */
1723
1724 #ifdef ERA
1725   DEFINE_NLITEM_CONSTANT (ERA);         /* Alternate era.  */
1726 #endif
1727 #ifdef ERA_D_FMT
1728   DEFINE_NLITEM_CONSTANT (ERA_D_FMT);   /* Date in alternate era format.  */
1729 #endif
1730 #ifdef ERA_D_T_FMT
1731   DEFINE_NLITEM_CONSTANT (ERA_D_T_FMT); /* Date and time in alternate era
1732                                            format.  */
1733 #endif
1734 #ifdef ERA_T_FMT
1735   DEFINE_NLITEM_CONSTANT (ERA_T_FMT);   /* Time in alternate era format.  */
1736 #endif
1737
1738 #ifdef ALT_DIGITS
1739   DEFINE_NLITEM_CONSTANT (ALT_DIGITS);  /* Alternate symbols for digits.  */
1740 #endif
1741   DEFINE_NLITEM_CONSTANT (RADIXCHAR);
1742   DEFINE_NLITEM_CONSTANT (THOUSEP);
1743
1744 #ifdef YESEXPR
1745   DEFINE_NLITEM_CONSTANT (YESEXPR);
1746 #endif
1747 #ifdef NOEXPR
1748   DEFINE_NLITEM_CONSTANT (NOEXPR);
1749 #endif
1750
1751 #ifdef CRNCYSTR /* currency symbol */
1752   DEFINE_NLITEM_CONSTANT (CRNCYSTR);
1753 #endif
1754
1755   /* GNU extensions.  */
1756
1757 #ifdef ERA_YEAR
1758   DEFINE_NLITEM_CONSTANT (ERA_YEAR);    /* Year in alternate era format.  */
1759 #endif
1760
1761   /* LC_MONETARY category: formatting of monetary quantities.
1762      These items each correspond to a member of `struct lconv',
1763      defined in <locale.h>.  */
1764 #ifdef INT_CURR_SYMBOL
1765   DEFINE_NLITEM_CONSTANT (INT_CURR_SYMBOL);
1766 #endif
1767 #ifdef MON_DECIMAL_POINT
1768   DEFINE_NLITEM_CONSTANT (MON_DECIMAL_POINT);
1769 #endif
1770 #ifdef MON_THOUSANDS_SEP
1771   DEFINE_NLITEM_CONSTANT (MON_THOUSANDS_SEP);
1772 #endif
1773 #ifdef MON_GROUPING
1774   DEFINE_NLITEM_CONSTANT (MON_GROUPING);
1775 #endif
1776 #ifdef POSITIVE_SIGN
1777   DEFINE_NLITEM_CONSTANT (POSITIVE_SIGN);
1778 #endif
1779 #ifdef NEGATIVE_SIGN
1780   DEFINE_NLITEM_CONSTANT (NEGATIVE_SIGN);
1781 #endif
1782 #ifdef GROUPING
1783   DEFINE_NLITEM_CONSTANT (GROUPING);
1784 #endif
1785 #ifdef INT_FRAC_DIGITS
1786   DEFINE_NLITEM_CONSTANT (INT_FRAC_DIGITS);
1787 #endif
1788 #ifdef FRAC_DIGITS
1789   DEFINE_NLITEM_CONSTANT (FRAC_DIGITS);
1790 #endif
1791 #ifdef P_CS_PRECEDES
1792   DEFINE_NLITEM_CONSTANT (P_CS_PRECEDES);
1793 #endif
1794 #ifdef P_SEP_BY_SPACE
1795   DEFINE_NLITEM_CONSTANT (P_SEP_BY_SPACE);
1796 #endif
1797 #ifdef N_CS_PRECEDES
1798   DEFINE_NLITEM_CONSTANT (N_CS_PRECEDES);
1799 #endif
1800 #ifdef N_SEP_BY_SPACE
1801   DEFINE_NLITEM_CONSTANT (N_SEP_BY_SPACE);
1802 #endif
1803 #ifdef P_SIGN_POSN
1804   DEFINE_NLITEM_CONSTANT (P_SIGN_POSN);
1805 #endif
1806 #ifdef N_SIGN_POSN
1807   DEFINE_NLITEM_CONSTANT (N_SIGN_POSN);
1808 #endif
1809 #ifdef INT_P_CS_PRECEDES
1810   DEFINE_NLITEM_CONSTANT (INT_P_CS_PRECEDES);
1811 #endif
1812 #ifdef INT_P_SEP_BY_SPACE
1813   DEFINE_NLITEM_CONSTANT (INT_P_SEP_BY_SPACE);
1814 #endif
1815 #ifdef INT_N_CS_PRECEDES
1816   DEFINE_NLITEM_CONSTANT (INT_N_CS_PRECEDES);
1817 #endif
1818 #ifdef INT_N_SEP_BY_SPACE
1819   DEFINE_NLITEM_CONSTANT (INT_N_SEP_BY_SPACE);
1820 #endif
1821 #ifdef INT_P_SIGN_POSN
1822   DEFINE_NLITEM_CONSTANT (INT_P_SIGN_POSN);
1823 #endif
1824 #ifdef INT_N_SIGN_POSN
1825   DEFINE_NLITEM_CONSTANT (INT_N_SIGN_POSN);
1826 #endif
1827
1828 #undef DEFINE_NLITEM_CONSTANT
1829 }
1830
1831 \f
1832 void
1833 scm_init_i18n ()
1834 {
1835   SCM global_locale_smob;
1836
1837   scm_add_feature ("nl-langinfo");
1838   define_langinfo_items ();
1839
1840 #include "libguile/i18n.x"
1841
1842   /* Initialize the global locale object with a special `locale' SMOB.  */
1843   /* XXX: We don't define it as `LC_GLOBAL_LOCALE' because of bugs as of
1844      glibc <= 2.11 not (yet) worked around by Gnulib.  See
1845      http://sourceware.org/bugzilla/show_bug.cgi?id=11009 for details.  */
1846   SCM_NEWSMOB (global_locale_smob, scm_tc16_locale_smob_type, NULL);
1847   SCM_VARIABLE_SET (scm_global_locale, global_locale_smob);
1848 }
1849
1850 void
1851 scm_bootstrap_i18n ()
1852 {
1853   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
1854                             "scm_init_i18n",
1855                             (scm_t_extension_init_func) scm_init_i18n,
1856                             NULL);
1857
1858 }
1859
1860
1861 /*
1862   Local Variables:
1863   c-file-style: "gnu"
1864   End:
1865 */