libguile/i18n.c

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