More i18n

* More i18n
@ 2006-12-10 15:04 Ludovic Courtès
  2006-12-11 19:42 ` Neil Jerram
                   ` (2 more replies)
  0 siblings, 3 replies; 23+ messages in thread
From: Ludovic Courtès @ 2006-12-10 15:04 UTC (permalink / raw)


[-- Attachment #1: Type: text/plain, Size: 3199 bytes --]

Hi,

The patch below provides further i18n support.  In particular, it
internationalizes SRFI-19.  Since SRFI-19 uses internally low-level
locale information (in order to answer questions such as "what's the
name of the first week day in this locale?"), `nl_langinfo ()' seemed
more appropriate than `strftime ()' to achieve this.  Thus, the patch
also provides a wrapper for `nl_langinfo ()', called
`language-information'.

In order to be consistent with the rest of `(ice-9 i18n)',
`language-information' accepts an optional argument which should be a
locale object.  Consequently, `language-information' has to perform
appropriate charset conversion.  Consider the following examples:

  guile> (setlocale LC_ALL "C")
  guile> (language-information DAY_1)
  "Sunday"

  ;; No conversion was needed here, easy.

  guile> (define eo (make-locale LC_ALL_MASK "eo_EO.UTF-8"))
  guile> (setlocale LC_ALL "eo_EO.ISO-8859-3")
  guile> (language-information DAY_1 eo)
  "dimanĉo"

  ;; The UTF-8 string returned by `nl_langinfo ()' was successfully
  ;; converted to ISO-8859-3, the current "internal representation" of
  ;; Guile.

  guile> (setlocale LC_ALL "C")
  guile> (language-information DAY_1 eo)
  standard input:7:1: In procedure make_stringbuf_from_c_string in expression (language-information DAY_1 eo):
  standard input:7:1: Invalid or incomplete multibyte or wide character
  ABORT: (system-error)

  ;; Charset conversion failed (could not convert UTF-8 string to
  ;; ASCII).

This is achieved by the introduction of `scm_from_string ()', a
generalization of `scm_from_locale_string ()':

  -- C Function: SCM scm_from_string (const char *str, const char
           *charset)
  -- C Function: SCM scm_from_stringn (const char *str, size_t len,
           const char *charset)
      These are generalized versions of the above functions.

      Create a Scheme string that has the same contents as STR when
      interpreted in the character encoding specified by CHARSET (the
      interpretation of CHARSET is platform-dependent).

The current implementation of this function is very 8-bit-oriented: it
assumes that the internal representation of strings in Guile is 8-bit
and is defined by the current locale's charset.  For instance,
`(setlocale LC_ALL "eo_EO.ISO-8859-3")' led `scm_from_string' to assume
Latin-3 as the internal string representation.  Of course, in the
(hopefully not so distant) future, the internal string representation
will certainly be locale-independent (UTF-8 or some such), but I believe
this is a reasonable starting point until we switch to Unicode.

Note that `nl_langinfo ()' is specified by SuSv2 but is not available,
for instance, on Windows.  Likewise, `iconv ()' may not be available on
all platforms but fortunately, `libiconv' [0] can be used on platforms
where it is not natively available.

The patch also addresses most of the issues raised by Kevin in the other
thread, and includes the `cond-feature' macro discussed in yet another
thread.  SRFI-19 currently uses it but could easily be changed to use
`provided?' if we decide not to include `cond-feature'.

Comments welcome!

Thanks,
Ludovic.

[0] http://www.gnu.org/software/libiconv/



[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: The new i18n patch --]
[-- Type: text/x-patch, Size: 50666 bytes --]

--- orig/configure.in
+++ mod/configure.in
@@ -525,12 +525,14 @@
 # Reasons for testing:
 #   complex.h - new in C99
 #   fenv.h - available in C99, but not older systems
+#   langinfo.h, nl_types.h - SuS v2
+#   iconv.h - SuS v2
 #
 AC_CHECK_HEADERS([complex.h fenv.h io.h libc.h limits.h malloc.h memory.h string.h \
 regex.h rxposix.h rx/rxposix.h sys/dir.h sys/ioctl.h sys/select.h \
 sys/time.h sys/timeb.h sys/times.h sys/stdtypes.h sys/types.h \
 sys/utime.h time.h unistd.h utime.h pwd.h grp.h sys/utsname.h \
-direct.h])
+direct.h langinfo.h nl_types.h iconv.h])
 
 # "complex double" is new in C99, and "complex" is only a keyword if
 # <complex.h> is included
@@ -613,17 +615,20 @@
 #   truncate - not in mingw
 #   isblank - available as a GNU extension or in C99
 #   _NSGetEnviron - Darwin specific
-#   strcoll_l, newlocale - GNU extensions (glibc)
+#   strcoll_l, newlocale - GNU extensions (glibc), also available on Darwin
+#   nl_langinfo - X/Open, not available on Windows.
+#   iconv - X/Open, SuS v2
 #
-AC_CHECK_FUNCS([DINFINITY DQNAN chsize clog10 ctermid fesetround ftime ftruncate fchown getcwd geteuid gettimeofday gmtime_r ioctl lstat mkdir mknod nice readdir_r readlink rename rmdir select setegid seteuid setlocale setpgid setsid sigaction siginterrupt stat64 strftime strptime symlink sync sysconf tcgetpgrp tcsetpgrp times uname waitpid strdup system usleep atexit on_exit chown link fcntl ttyname getpwent getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp index bcopy memcpy rindex truncate unsetenv isblank _NSGetEnviron strcoll strcoll_l newlocale])
+AC_CHECK_FUNCS([DINFINITY DQNAN chsize clog10 ctermid fesetround ftime ftruncate fchown getcwd geteuid gettimeofday gmtime_r ioctl lstat mkdir mknod nice readdir_r readlink rename rmdir select setegid seteuid setlocale setpgid setsid sigaction siginterrupt stat64 strftime strptime symlink sync sysconf tcgetpgrp tcsetpgrp times uname waitpid strdup system usleep atexit on_exit chown link fcntl ttyname getpwent getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp index bcopy memcpy rindex truncate unsetenv isblank _NSGetEnviron strcoll strcoll_l newlocale nl_langinfo iconv])
 
 # Reasons for testing:
 #   netdb.h - not in mingw
 #   sys/param.h - not in mingw
 #   sethostname - the function itself check because it's not in mingw,
 #       the DECL is checked because Solaris 10 doens't have in any header
+#   xlocale.h - needed on Darwin for the `locale_t' API
 #
-AC_CHECK_HEADERS(crypt.h netdb.h sys/param.h sys/resource.h sys/file.h)
+AC_CHECK_HEADERS(crypt.h netdb.h sys/param.h sys/resource.h sys/file.h xlocale.h)
 AC_CHECK_FUNCS(chroot flock getlogin cuserid getpriority setpriority getpass sethostname gethostname)
 AC_CHECK_DECLS([sethostname])
 


--- orig/doc/ref/api-data.texi
+++ mod/doc/ref/api-data.texi
@@ -3653,6 +3653,18 @@
 null-terminated and the real length will be found with @code{strlen}.
 @end deftypefn
 
+@deftypefn {C Function} SCM scm_from_string (const char *str, const char *charset)
+@deftypefnx {C Function} SCM scm_from_stringn (const char *str, size_t len, const char *charset)
+These are generalized versions of the above functions.
+
+Create a Scheme string that has the same contents as @var{str} when
+interpreted in the character encoding specified by @var{charset} (the
+interpretation of charset is platform-dependent).
+
+The @var{len} and @var{str} must follow the same rules as for the
+above functions.
+@end deftypefn
+
 @deftypefn  {C Function} SCM scm_take_locale_string (char *str)
 @deftypefnx {C Function} SCM scm_take_locale_stringn (char *str, size_t len)
 Like @code{scm_from_locale_string} and @code{scm_from_locale_stringn},


--- orig/doc/ref/api-i18n.texi
+++ mod/doc/ref/api-i18n.texi
@@ -159,34 +159,17 @@
 
 @deffn {Scheme Procedure} string-locale<? s1 s2 [locale]
 @deffnx {C Function} scm_string_locale_lt (s1, s2, locale)
-Compare strings @var{s1} and @var{s2} in a locale-dependent way.  If
-@var{locale} is provided, it should be locale object (as returned by
-@code{make-locale}) and will be used to perform the comparison;
-otherwise, the current system locale is used.
-@end deffn
-
-@deffn {Scheme Procedure} string-locale>? s1 s2 [locale]
+@deffnx {Scheme Procedure} string-locale>? s1 s2 [locale]
 @deffnx {C Function} scm_string_locale_gt (s1, s2, locale)
+@deffnx {Scheme Procedure} string-locale-ci<? s1 s2 [locale]
+@deffnx {C Function} scm_string_locale_ci_lt (s1, s2, locale)
+@deffnx {Scheme Procedure} string-locale-ci>? s1 s2 [locale]
+@deffnx {C Function} scm_string_locale_ci_gt (s1, s2, locale)
 Compare strings @var{s1} and @var{s2} in a locale-dependent way.  If
 @var{locale} is provided, it should be locale object (as returned by
 @code{make-locale}) and will be used to perform the comparison;
-otherwise, the current system locale is used.
-@end deffn
-
-@deffn {Scheme Procedure} string-locale-ci<? s1 s2 [locale]
-@deffnx {C Function} scm_string_locale_ci_lt (s1, s2, locale)
-Compare strings @var{s1} and @var{s2} in a case-insensitive, and
-locale-dependent way.  If @var{locale} is provided, it should be
-locale object (as returned by @code{make-locale}) and will be used to
-perform the comparison; otherwise, the current system locale is used.
-@end deffn
-
-@deffn {Scheme Procedure} string-locale-ci>? s1 s2 [locale]
-@deffnx {C Function} scm_string_locale_ci_gt (s1, s2, locale)
-Compare strings @var{s1} and @var{s2} in a case-insensitive, and
-locale-dependent way.  If @var{locale} is provided, it should be
-locale object (as returned by @code{make-locale}) and will be used to
-perform the comparison; otherwise, the current system locale is used.
+otherwise, the current system locale is used.  For the @code{-ci}
+variants, the comparison is made in a case-insensitive way.
 @end deffn
 
 @deffn {Scheme Procedure} string-locale-ci=? s1 s2 [locale]
@@ -199,26 +182,16 @@
 
 @deffn {Scheme Procedure} char-locale<? c1 c2 [locale]
 @deffnx {C Function} scm_char_locale_lt (c1, c2, locale)
-Return true if character @var{c1} is lower than @var{c2} according to
-@var{locale} or to the current locale.
-@end deffn
-
-@deffn {Scheme Procedure} char-locale>? c1 c2 [locale]
+@deffnx {Scheme Procedure} char-locale>? c1 c2 [locale]
 @deffnx {C Function} scm_char_locale_gt (c1, c2, locale)
-Return true if character @var{c1} is greater than @var{c2} according
-to @var{locale} or to the current locale.
-@end deffn
-
-@deffn {Scheme Procedure} char-locale-ci<? c1 c2 [locale]
+@deffnx {Scheme Procedure} char-locale-ci<? c1 c2 [locale]
 @deffnx {C Function} scm_char_locale_ci_lt (c1, c2, locale)
-Return true if character @var{c1} is lower than @var{c2}, in a case
-insensitive way according to @var{locale} or to the current locale.
-@end deffn
-
-@deffn {Scheme Procedure} char-locale-ci>? c1 c2 [locale]
+@deffnx {Scheme Procedure} char-locale-ci>? c1 c2 [locale]
 @deffnx {C Function} scm_char_locale_ci_gt (c1, c2, locale)
-Return true if character @var{c1} is greater than @var{c2}, in a case
-insensitive way according to @var{locale} or to the current locale.
+Compare characters @var{c1} and @var{c2} according to either
+@var{locale} (a locale object as returned by @code{make-locale}) or
+the current locale.  For the @code{-ci} variants, the comparison is
+made in a case-insensitive way.
 @end deffn
 
 @deffn {Scheme Procedure} char-locale-ci=? c1 c2 [locale]
@@ -236,8 +209,8 @@
 or region of the world.  For instance, while most languages using the
 Latin alphabet map lower-case letter ``i'' to upper-case letter ``I'',
 Turkish maps lower-case ``i'' to ``Latin capital letter I with dot
-above''.  The following procedures allow to provide idiomatic
-character mapping.
+above''.  The following procedures allow programmers to provide
+idiomatic character mapping.
 
 @deffn {Scheme Procedure} char-locale-downcase chr [locale]
 @deffnx {C Function} scm_char_locale_upcase (chr, locale)
@@ -263,12 +236,17 @@
 according to either @var{locale} or the current locale.
 @end deffn
 
-Finally, the following procedures allow programs to read numbers
+Note that in the current implementation Guile has no notion of
+multibyte characters and in a multibyte locale characters may not be
+converted correctly.
+
+The following procedures allow programs to read numbers
 written according to a particular locale.  As an example, in English,
 ``ten thousand and a half'' is usually written @code{10,000.5} while
 in French it is written @code{10000,5}.  These procedures allow to
 account for these differences.
 
+@findex strtod
 @deffn {Scheme Procedure} locale-string->integer str [base [locale]]
 @deffnx {C Function} scm_locale_string_to_integer (str, base, locale)
 Convert string @var{str} into an integer according to either
@@ -276,20 +254,62 @@
 the current process locale.  If @var{base} is specified, then it
 determines the base of the integer being read (e.g., @code{16} for an
 hexadecimal number, @code{10} for a decimal number); by default,
-decimal numbers are read.  Return two values: an integer (on success)
-or @code{#f}, and the number of characters read from @var{str}
-(@code{0} on failure).
+decimal numbers are read.  Return two values (@pxref{Multiple
+Values}): an integer (on success) or @code{#f}, and the number of
+characters read from @var{str} (@code{0} on failure).
+
+This function is based on the C library's @code{strtol} function
+(@pxref{Parsing of Integers, @code{strtol},, libc, The GNU C Library
+Reference Manual}).
 @end deffn
 
+@findex strtod
 @deffn {Scheme Procedure} locale-string->inexact str [locale]
 @deffnx {C Function} scm_locale_string_to_inexact (str, locale)
 Convert string @var{str} into an inexact number according to either
 @var{locale} (a locale object as returned by @code{make-locale}) or
-the current process locale.  Return two values: an inexact number (on
-success) or @code{#f}, and the number of characters read from
-@var{str} (@code{0} on failure).
+the current process locale.  Return two values (@pxref{Multiple
+Values}): an inexact number (on success) or @code{#f}, and the number
+of characters read from @var{str} (@code{0} on failure).
+
+This function is based on the C library's @code{strtod} function
+(@pxref{Parsing of Floats, @code{strtod},, libc, The GNU C Library
+Reference Manual}).
+@end deffn
+
+@findex nl_langinfo
+@cindex low-level locale information
+It is sometimes useful to obtain very specific information about a
+locale such as the name it uses for days or months, its format for
+representing floating-point figures, etc.  The @code{(ice-9 i18n)}
+module provides support for this with the @code{language-information}
+procedure.  Note that this procedure is only available on platforms
+that provide @code{nl_langinfo ()} (@pxref{The Elegant and Fast Way,
+@code{nl_langinfo},, libc, The GNU C Library Reference Manual}).  When
+@code{language-information}, the @code{language-information} feature
+is provided (@pxref{Feature Tracking}).
+
+@deffn {Scheme Procedure} language-information item [locale]
+@deffnx {C Function} scm_language_information (item, locale)
+Return a string denoting locale information for @var{item} in the
+current locale or that specified by @var{locale}.  The semantics and
+arguments are the same as those of the X/Open @code{nl_langinfo}
+function (@pxref{The Elegant and Fast Way, @code{nl_langinfo},, libc,
+The GNU C Library Reference Manual}).
 @end deffn
 
+It can be used as follows:
+
+@example
+(language-information DAY_1 (make-locale LC_ALL_MASK "C"))
+@result{} "Sunday"
+
+(language-information ABMON_2 (make-locale LC_ALL_MASK "C"))
+@result{} "Feb"
+
+(language-information RADIXCHAR (make-locale LC_ALL_MASK "fr_FR"))
+@result{} ","
+@end example
 
 @node Gettext Support
 @subsection Gettext Support


--- orig/doc/ref/srfi-modules.texi
+++ mod/doc/ref/srfi-modules.texi
@@ -2095,10 +2095,10 @@
 described here, since the specification and reference implementation
 differ.
 
-Currently Guile doesn't implement any localizations for the above, all
-outputs are in English, and the @samp{~c} conversion is POSIX
-@code{ctime} style @samp{~a ~b ~d ~H:~M:~S~z ~Y}.  This may change in
-the future.
+Conversion is locale-dependent on systems that support
+@code{language-information} (@pxref{The ice-9 i18n Module,
+@code{language-information}}).  @xref{Locales, @code{setlocale}}, for
+information on how to change the current locale.
 
 
 @node SRFI-19 String to date
@@ -2219,9 +2219,10 @@
 returned, instead the weekday will be derived from the day, month and
 year.
 
-Currently Guile doesn't implement any localizations for the above,
-month and weekday names are always expected in English.  This may
-change in the future.
+Conversion is locale-dependent on systems that support
+@code{language-information} (@pxref{The ice-9 i18n Module,
+@code{language-information}}).  @xref{Locales, @code{setlocale}}, for
+information on how to change the current locale.
 @end defun
 
 


--- orig/ice-9/boot-9.scm
+++ mod/ice-9/boot-9.scm
@@ -3245,25 +3245,17 @@
 		     (append (hashq-ref %cond-expand-table mod '())
 			     features)))))
 
-(define cond-expand
+(define (make-cond-expand-macro feature-available?
+                                syntax-error unfulfilled-error)
   (procedure->memoizing-macro
    (lambda (exp env)
-     (let ((clauses (cdr exp))
-	   (syntax-error (lambda (cl)
-			   (error "invalid clause in `cond-expand'" cl))))
+     (let ((clauses (cdr exp)))
        (letrec
 	   ((test-clause
 	     (lambda (clause)
 	       (cond
 		((symbol? clause)
-		 (or (memq clause %cond-expand-features)
-		     (let lp ((uses (module-uses (env-module env))))
-		       (if (pair? uses)
-			   (or (memq clause
-				     (hashq-ref %cond-expand-table
-						(car uses) '()))
-			       (lp (cdr uses)))
-			   #f))))
+                 (feature-available? clause env))
 		((pair? clause)
 		 (cond
 		  ((eq? 'and (car clause))
@@ -3295,7 +3287,7 @@
 	 (let lp ((c clauses))
 	   (cond
 	    ((null? c)
-	     (error "Unfulfilled `cond-expand'"))
+	     (unfulfilled-error))
 	    ((not (pair? c))
 	     (syntax-error c))
 	    ((not (pair? (car c)))
@@ -3309,6 +3301,21 @@
 	    (else
 	     (lp (cdr c))))))))))
 
+(define cond-expand
+  (make-cond-expand-macro (lambda (clause env)
+                            (or (memq clause %cond-expand-features)
+                                (let lp ((uses (module-uses (env-module env))))
+                                  (if (pair? uses)
+                                      (or (memq clause
+                                                (hashq-ref %cond-expand-table
+                                                           (car uses) '()))
+                                          (lp (cdr uses)))
+                                      #f))))
+                          (lambda (clause)
+                            (error "invalid clause in `cond-expand'" clause))
+                          (lambda ()
+                            (error "unfulfilled `cond-expand'"))))
+
 ;; This procedure gets called from the startup code with a list of
 ;; numbers, which are the numbers of the SRFIs to be loaded on startup.
 ;;
@@ -3323,6 +3330,22 @@
 
 \f
 
+;;; `cond-feature'
+;;;
+
+(define cond-feature
+  ;; Provide a mechanism similar to `cond-expand' for Guile's built-in
+  ;; features.
+  (make-cond-expand-macro (lambda (clause env)
+                            (provided? clause))
+                          (lambda (clause)
+                            (error "invalid clause in `cond-feature'"
+                                   clause))
+                          (lambda ()
+                            (error "unfulfilled `cond-feature'"))))
+
+\f
+
 ;;; srfi-55: require-extension
 ;;;
 


--- orig/ice-9/i18n.scm
+++ mod/ice-9/i18n.scm
@@ -54,7 +54,33 @@
            string-locale-downcase string-locale-upcase
 
            ;; reading numbers
-           locale-string->integer locale-string->inexact))
+           locale-string->integer locale-string->inexact
+
+           ;; detailed language information
+           language-information
+           CODESET
+           ABDAY_1 ABDAY_2 ABDAY_3 ABDAY_4 ABDAY_5 ABDAY_6 ABDAY_7
+           DAY_1 DAY_2 DAY_3 DAY_4 DAY_5 DAY_6 DAY_7
+           ABMON_1 ABMON_2 ABMON_3 ABMON_4 ABMON_5 ABMON_6 ABMON_7
+           ABMON_8 ABMON_9 ABMON_10 ABMON_11 ABMON_12
+           MON_1 MON_2 MON_3 MON_4 MON_5 MON_6 MON_7 MON_8
+           MON_9 MON_10 MON_11 MON_12
+           AM_STR PM_STR
+           D_T_FMT D_FMT T_FMT T_FMT_AMPM
+           ERA ERA_D_FMT ERA_D_T_FMT ERA_T_FMT
+           ALT_DIGITS RADIXCHAR THOUSEP
+           CRNCYSTR
+           YESEXPR NOEXPR YESSTR NOSTR
+
+           ;; GNU extensions (may be unavailable on non-GNU systems)
+           ERA_YEAR DECIMAL_POINT
+           INT_CURR_SYMBOL CURRENCY_SYMBOL
+           MON_DECIMAL_POINT MON_THOUSANDS_SEP MON_GROUPING
+           POSITIVE_SIGN NEGATIVE_SIGN INT_FRAC_DIGITS FRAC_DIGITS
+           P_CS_PRECEDES P_SEP_BY_SPACE N_CS_PRECEDES N_SEP_BY_SPACE
+           P_SIGN_POSN N_SIGN_POSN INT_P_CS_PRECEDES INT_P_SEP_BY_SPACE
+           INT_N_CS_PRECEDES INT_N_SEP_BY_SPACE INT_P_SIGN_POSN
+           INT_N_SIGN_POSN))
 
 
 (load-extension "libguile-i18n-v-0" "scm_init_i18n")


--- orig/libguile/i18n.c
+++ mod/libguile/i18n.c
@@ -46,6 +46,7 @@
 #include "libguile/dynwind.h"
 #include "libguile/validate.h"
 #include "libguile/values.h"
+#include "libguile/threads.h"
 
 #include <locale.h>
 #include <string.h> /* `strcoll ()' */
@@ -56,8 +57,18 @@
 # define USE_GNU_LOCALE_API
 #endif
 
-#ifndef USE_GNU_LOCALE_API
-# include "libguile/posix.h"  /* for `scm_i_locale_mutex' */
+#if (defined USE_GNU_LOCALE_API) && (defined HAVE_XLOCALE_H)
+/* Darwin now supports the "GNU" thread-safe locale API but one has to
+   include <xlocale.h> to get it.  See:
+   http://developer.apple.com/documentation/Darwin/Reference/ManPages/man3/newlocale.3.html  */
+# include <xlocale.h>
+#endif
+
+#include "libguile/posix.h"  /* for `scm_i_locale_mutex' */
+
+#if (defined HAVE_LANGINFO_H) && (defined HAVE_NL_TYPES_H)
+# include <langinfo.h>
+# include <nl_types.h>
 #endif
 
 #ifndef HAVE_SETLOCALE
@@ -69,6 +80,9 @@
 }
 #endif
 
+/* Helper stringification macro.  */
+#define SCM_I18N_STRINGIFY(_name)   # _name
+
 
 \f
 /* Locale objects, string and character collation, and other locale-dependent
@@ -99,44 +113,43 @@
 
 #ifndef USE_GNU_LOCALE_API
 
-/* Provide the locale category masks as found in glibc (copied from
-   <locale.h> as found in glibc 2.3.6).  This must be kept in sync with
-   `locale-categories.h'.  */
-
-# define LC_CTYPE_MASK		(1 << LC_CTYPE)
-# define LC_COLLATE_MASK	(1 << LC_COLLATE)
-# define LC_MESSAGES_MASK	(1 << LC_MESSAGES)
-# define LC_MONETARY_MASK	(1 << LC_MONETARY)
-# define LC_NUMERIC_MASK	(1 << LC_NUMERIC)
-# define LC_TIME_MASK		(1 << LC_TIME)
+/* Provide the locale category masks as found in glibc.  This must be kept in
+   sync with `locale-categories.h'.  */
+
+# define LC_CTYPE_MASK		1
+# define LC_COLLATE_MASK	2
+# define LC_MESSAGES_MASK	4
+# define LC_MONETARY_MASK	8
+# define LC_NUMERIC_MASK	16
+# define LC_TIME_MASK		32
 
 # ifdef LC_PAPER
-#   define LC_PAPER_MASK	(1 << LC_PAPER)
+#   define LC_PAPER_MASK	64
 # else
 #   define LC_PAPER_MASK	0
 # endif
 # ifdef LC_NAME
-#   define LC_NAME_MASK		(1 << LC_NAME)
+#   define LC_NAME_MASK		128
 # else
 #   define LC_NAME_MASK		0
 # endif
 # ifdef LC_ADDRESS
-#   define LC_ADDRESS_MASK	(1 << LC_ADDRESS)
+#   define LC_ADDRESS_MASK	256
 # else
 #   define LC_ADDRESS_MASK	0
 # endif
 # ifdef LC_TELEPHONE
-#   define LC_TELEPHONE_MASK	(1 << LC_TELEPHONE)
+#   define LC_TELEPHONE_MASK	512
 # else
 #   define LC_TELEPHONE_MASK	0
 # endif
 # ifdef LC_MEASUREMENT
-#   define LC_MEASUREMENT_MASK	(1 << LC_MEASUREMENT)
+#   define LC_MEASUREMENT_MASK	1024
 # else
 #   define LC_MEASUREMENT_MASK	0
 # endif
 # ifdef LC_IDENTIFICATION
-#   define LC_IDENTIFICATION_MASK (1 << LC_IDENTIFICATION)
+#   define LC_IDENTIFICATION_MASK 2048
 # else
 #   define LC_IDENTIFICATION_MASK 0
 # endif
@@ -224,7 +237,21 @@
 }
 #endif
 
+/* Throw an exception corresponding to error ERR.  */
+static void inline
+scm_locale_error (const char *func_name, int err)
+{
+  SCM s_err;
+
+  s_err = scm_from_int (err);
+  scm_error (scm_system_error_key, func_name,
+	     "Failed to install locale",
+	     scm_cons (scm_strerror (s_err), SCM_EOL),
+	     scm_cons (s_err, SCM_EOL));
+}
+
 
+\f
 SCM_DEFINE (scm_make_locale, "make-locale", 2, 1, 0,
 	    (SCM category_mask, SCM locale_name, SCM base_locale),
 	    "Return a reference to a data structure representing a set of "
@@ -249,13 +276,13 @@
 
   c_locale = newlocale (c_category_mask, c_locale_name, c_base_locale);
 
+  free (c_locale_name);
+
   if (!c_locale)
-    locale = SCM_BOOL_F;
+    scm_locale_error (FUNC_NAME, errno);
   else
     SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale);
 
-  free (c_locale_name);
-
 #else
 
   c_locale = scm_gc_malloc (sizeof (* c_locale), "locale");
@@ -277,10 +304,7 @@
 	    "Return true if @var{obj} is a locale object.")
 #define FUNC_NAME s_scm_locale_p
 {
-  if (SCM_SMOB_PREDICATE (scm_tc16_locale_smob_type, obj))
-    return SCM_BOOL_T;
-
-  return SCM_BOOL_F;
+  return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_locale_smob_type, obj));
 }
 #undef FUNC_NAME
 
@@ -481,19 +505,6 @@
   return err;
 }
 
-/* Throw an exception corresponding to error ERR.  */
-static void inline
-scm_locale_error (const char *func_name, int err)
-{
-  SCM s_err;
-
-  s_err = scm_from_int (err);
-  scm_error (scm_system_error_key, func_name,
-	     "Failed to install locale",
-	     scm_cons (scm_strerror (s_err), SCM_EOL),
-	     scm_cons (s_err, SCM_EOL));
-}
-
 /* Convenient macro to run STATEMENT in the locale context of C_LOCALE.  */
 #define RUN_IN_LOCALE_SECTION(_c_locale, _statement)			\
   do									\
@@ -1124,25 +1135,309 @@
 }
 #undef FUNC_NAME
 
+\f
+/* Language information, aka. `nl_langinfo ()'.  */
+
+/* FIXME: Issues related to `language-information'.
+
+   1. The `CODESET' value if not normalized.  This is a secondary issue, but
+      still a practical issue.  See
+      http://www.cl.cam.ac.uk/~mgk25/ucs/norm_charmap.c for codeset
+      normalization.
+
+   2. `nl_langinfo ()' is not available on Windows (but do we care?).  */
+
+
+SCM_DEFINE (scm_language_information, "language-information", 1, 1, 0,
+	    (SCM item, SCM locale),
+	    "Return a string denoting locale information for @var{item} "
+	    "in the current locale or that specified by @var{locale}.  "
+	    "The semantics and arguments are the same as those of the "
+	    "X/Open @code{nl_langinfo} function (@pxref{The Elegant and "
+	    "Fast Way, @code{nl_langinfo},, libc, The GNU C Library "
+	    "Reference Manual}).")
+#define FUNC_NAME s_scm_language_information
+{
+#ifdef HAVE_NL_LANGINFO
+  SCM result;
+  nl_item c_item;
+  char *c_result, *codeset;
+  const char *tmp_codeset;
+  scm_t_locale c_locale;
+
+  SCM_VALIDATE_INT_COPY (2, item, c_item);
+  SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale);
+
+  /* Sadly, `nl_langinfo ()' returns a pointer to a static string.  According
+     to SuS v2, that static string may be modified by subsequent calls to
+     `nl_langinfo ()' as well as by calls to `setlocale ()'.  Thus, we must
+     acquire the locale mutex before doing invoking `nl_langinfo ()'.  See
+     http://opengroup.org/onlinepubs/007908799/xsh/nl_langinfo.html for
+     details.  */
+
+  scm_i_pthread_mutex_lock (&scm_i_locale_mutex);
+  if (c_locale != NULL)
+    {
+#ifdef USE_GNU_LOCALE_API
+      c_result = nl_langinfo_l (c_item, c_locale);
+      tmp_codeset = nl_langinfo_l (CODESET, c_locale);
+#else
+      /* We can't use `RUN_IN_LOCALE_SECTION ()' here because the locale
+	 mutex is already taken.  */
+      int lsec_err;
+      scm_t_locale_settings lsec_prev_locale;
+
+      lsec_err = get_current_locale_settings (&lsec_prev_locale);
+      if (lsec_err)
+	scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
+      else
+	{
+	  lsec_err = install_locale (c_locale);
+	  if (lsec_err)
+	    {
+	      leave_locale_section (&prev_locale);
+	      free_locale_settings (&prev_locale);
+	    }
+	}
+
+      if (lsec_err)
+	scm_locale_error (FUNC_NAME, lsec_err);
+      else
+	{
+	  /* Get the result under C_LOCALE.  */
+	  c_result = nl_langinfo (c_item);
+	  tmp_codeset = nl_langinfo (CODESET);
+
+	  leave_locale_section (&lsec_prev_locale);
+	  free_locale_settings (&lsec_prev_locale);
+	}
+#endif
+    }
+  else
+    {
+      c_result = nl_langinfo (c_item);
+      tmp_codeset = nl_langinfo (CODESET);
+    }
+
+  c_result = strdup (c_result);
+
+  codeset = (char *) alloca (strlen (tmp_codeset) + 1);
+  strcpy (codeset, tmp_codeset);
+
+  scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
+
+  if (c_result == NULL)
+    {
+      result = SCM_BOOL_F;
+      /* FIXME: Raise an error.  */
+    }
+  else
+    {
+      /* Interpret C_RESULT using the right encoding.  */
+      result = scm_from_stringn (c_result, strlen (c_result), codeset);
+      free (c_result);
+    }
+
+  return result;
+#else
+  scm_syserror_msg (FUNC_NAME,
+		    "`language-information' not supported on your system",
+		    SCM_EOL, ENOSYS);
+
+  return SCM_BOOL_F;
+#endif
+}
+#undef FUNC_NAME
+
+/* Define the `nl_item' constants.  */
+static inline void
+define_langinfo_items (void)
+{
+#if (defined HAVE_NL_TYPES_H) && (defined HAVE_LANGINFO_H)
+
+#define DEFINE_NLITEM_CONSTANT(_item)					\
+  scm_c_define (# _item, SCM_I_MAKINUM (_item))
+
+  DEFINE_NLITEM_CONSTANT (CODESET);
+
+  /* Abbreviated days of the week. */
+  DEFINE_NLITEM_CONSTANT (ABDAY_1);
+  DEFINE_NLITEM_CONSTANT (ABDAY_2);
+  DEFINE_NLITEM_CONSTANT (ABDAY_3);
+  DEFINE_NLITEM_CONSTANT (ABDAY_4);
+  DEFINE_NLITEM_CONSTANT (ABDAY_5);
+  DEFINE_NLITEM_CONSTANT (ABDAY_6);
+  DEFINE_NLITEM_CONSTANT (ABDAY_7);
+
+  /* Long-named days of the week. */
+  DEFINE_NLITEM_CONSTANT (DAY_1);	/* Sunday */
+  DEFINE_NLITEM_CONSTANT (DAY_2);	/* Monday */
+  DEFINE_NLITEM_CONSTANT (DAY_3);	/* Tuesday */
+  DEFINE_NLITEM_CONSTANT (DAY_4);	/* Wednesday */
+  DEFINE_NLITEM_CONSTANT (DAY_5);	/* Thursday */
+  DEFINE_NLITEM_CONSTANT (DAY_6);	/* Friday */
+  DEFINE_NLITEM_CONSTANT (DAY_7);	/* Saturday */
+
+  /* Abbreviated month names.  */
+  DEFINE_NLITEM_CONSTANT (ABMON_1);	/* Jan */
+  DEFINE_NLITEM_CONSTANT (ABMON_2);
+  DEFINE_NLITEM_CONSTANT (ABMON_3);
+  DEFINE_NLITEM_CONSTANT (ABMON_4);
+  DEFINE_NLITEM_CONSTANT (ABMON_5);
+  DEFINE_NLITEM_CONSTANT (ABMON_6);
+  DEFINE_NLITEM_CONSTANT (ABMON_7);
+  DEFINE_NLITEM_CONSTANT (ABMON_8);
+  DEFINE_NLITEM_CONSTANT (ABMON_9);
+  DEFINE_NLITEM_CONSTANT (ABMON_10);
+  DEFINE_NLITEM_CONSTANT (ABMON_11);
+  DEFINE_NLITEM_CONSTANT (ABMON_12);
+
+  /* Long month names.  */
+  DEFINE_NLITEM_CONSTANT (MON_1);	/* January */
+  DEFINE_NLITEM_CONSTANT (MON_2);
+  DEFINE_NLITEM_CONSTANT (MON_3);
+  DEFINE_NLITEM_CONSTANT (MON_4);
+  DEFINE_NLITEM_CONSTANT (MON_5);
+  DEFINE_NLITEM_CONSTANT (MON_6);
+  DEFINE_NLITEM_CONSTANT (MON_7);
+  DEFINE_NLITEM_CONSTANT (MON_8);
+  DEFINE_NLITEM_CONSTANT (MON_9);
+  DEFINE_NLITEM_CONSTANT (MON_10);
+  DEFINE_NLITEM_CONSTANT (MON_11);
+  DEFINE_NLITEM_CONSTANT (MON_12);
+
+  DEFINE_NLITEM_CONSTANT (AM_STR);	/* Ante meridiem string.  */
+  DEFINE_NLITEM_CONSTANT (PM_STR);	/* Post meridiem string.  */
+
+  DEFINE_NLITEM_CONSTANT (D_T_FMT); /* Date and time format for strftime.  */
+  DEFINE_NLITEM_CONSTANT (D_FMT);   /* Date format for strftime.  */
+  DEFINE_NLITEM_CONSTANT (T_FMT);   /* Time format for strftime.  */
+  DEFINE_NLITEM_CONSTANT (T_FMT_AMPM);/* 12-hour time format for strftime.  */
+
+  DEFINE_NLITEM_CONSTANT (ERA);	        /* Alternate era.  */
+  DEFINE_NLITEM_CONSTANT (ERA_D_FMT);	/* Date in alternate era format.  */
+  DEFINE_NLITEM_CONSTANT (ERA_D_T_FMT);	/* Date and time in alternate era
+					   format.  */
+  DEFINE_NLITEM_CONSTANT (ERA_T_FMT);	/* Time in alternate era format.  */
+
+  DEFINE_NLITEM_CONSTANT (ALT_DIGITS);	/* Alternate symbols for digits.  */
+  DEFINE_NLITEM_CONSTANT (RADIXCHAR);
+  DEFINE_NLITEM_CONSTANT (THOUSEP);
+
+#ifdef YESEXPR
+  DEFINE_NLITEM_CONSTANT (YESEXPR);
+#endif
+#ifdef NOEXPR
+  DEFINE_NLITEM_CONSTANT (NOEXPR);
+#endif
+#ifdef YESSTR
+  DEFINE_NLITEM_CONSTANT (YESSTR);
+#endif
+#ifdef NOSTR
+  DEFINE_NLITEM_CONSTANT (NOSTR);
+#endif
+
+
+  /* GNU extensions.  */
+
+#ifdef ERA_YEAR
+  DEFINE_NLITEM_CONSTANT (ERA_YEAR);	/* Year in alternate era format.  */
+#endif
+#ifdef DECIMAL_POINT
+  DEFINE_NLITEM_CONSTANT (DECIMAL_POINT);  /* Equivalent to `RADIXCHAR'.  */
+#endif
+
+  /* LC_MONETARY category: formatting of monetary quantities.
+     These items each correspond to a member of `struct lconv',
+     defined in <locale.h>.  */
+#ifdef INT_CURR_SYMBOL
+  DEFINE_NLITEM_CONSTANT (INT_CURR_SYMBOL);
+#endif
+#ifdef CURRENCY_SYMBOL
+  DEFINE_NLITEM_CONSTANT (CURRENCY_SYMBOL);
+#endif
+#ifdef CRNCYSTR /* legacy symbol */
+  DEFINE_NLITEM_CONSTANT (CRNCYSTR);
+#endif
+#ifdef MON_DECIMAL_POINT
+  DEFINE_NLITEM_CONSTANT (MON_DECIMAL_POINT);
+#endif
+#ifdef MON_THOUSANDS_SEP
+  DEFINE_NLITEM_CONSTANT (MON_THOUSANDS_SEP);
+#endif
+#ifdef MON_GROUPING
+  DEFINE_NLITEM_CONSTANT (MON_GROUPING);
+#endif
+#ifdef POSITIVE_SIGN
+  DEFINE_NLITEM_CONSTANT (POSITIVE_SIGN);
+#endif
+#ifdef NEGATIVE_SIGN
+  DEFINE_NLITEM_CONSTANT (NEGATIVE_SIGN);
+#endif
+#ifdef INT_FRAC_DIGITS
+  DEFINE_NLITEM_CONSTANT (INT_FRAC_DIGITS);
+#endif
+#ifdef FRAC_DIGITS
+  DEFINE_NLITEM_CONSTANT (FRAC_DIGITS);
+#endif
+#ifdef P_CS_PRECEDES
+  DEFINE_NLITEM_CONSTANT (P_CS_PRECEDES);
+#endif
+#ifdef P_SEP_BY_SPACE
+  DEFINE_NLITEM_CONSTANT (P_SEP_BY_SPACE);
+#endif
+#ifdef N_CS_PRECEDES
+  DEFINE_NLITEM_CONSTANT (N_CS_PRECEDES);
+#endif
+#ifdef N_SEP_BY_SPACE
+  DEFINE_NLITEM_CONSTANT (N_SEP_BY_SPACE);
+#endif
+#ifdef P_SIGN_POSN
+  DEFINE_NLITEM_CONSTANT (P_SIGN_POSN);
+#endif
+#ifdef N_SIGN_POSN
+  DEFINE_NLITEM_CONSTANT (N_SIGN_POSN);
+#endif
+#ifdef INT_P_CS_PRECEDES
+  DEFINE_NLITEM_CONSTANT (INT_P_CS_PRECEDES);
+#endif
+#ifdef INT_P_SEP_BY_SPACE
+  DEFINE_NLITEM_CONSTANT (INT_P_SEP_BY_SPACE);
+#endif
+#ifdef INT_N_CS_PRECEDES
+  DEFINE_NLITEM_CONSTANT (INT_N_CS_PRECEDES);
+#endif
+#ifdef INT_N_SEP_BY_SPACE
+  DEFINE_NLITEM_CONSTANT (INT_N_SEP_BY_SPACE);
+#endif
+#ifdef INT_P_SIGN_POSN
+  DEFINE_NLITEM_CONSTANT (INT_P_SIGN_POSN);
+#endif
+#ifdef INT_N_SIGN_POSN
+  DEFINE_NLITEM_CONSTANT (INT_N_SIGN_POSN);
+#endif
+
+#undef DEFINE_NLITEM_CONSTANT
+
+#endif /* HAVE_NL_TYPES_H */
+}
 
 \f
 void
 scm_init_i18n ()
 {
-  scm_add_feature ("ice-9-i18n");
-
-#define _SCM_STRINGIFY_LC(_name)  # _name
-#define SCM_STRINGIFY_LC(_name)   _SCM_STRINGIFY_LC (_name)
+#ifdef HAVE_NL_LANGINFO
+  scm_add_feature ("language-information");
+  define_langinfo_items ();
+#endif
 
   /* Define all the relevant `_MASK' variables.  */
-#define SCM_DEFINE_LOCALE_CATEGORY(_name)		\
-  scm_c_define ("LC_" SCM_STRINGIFY_LC (_name) "_MASK",	\
+#define SCM_DEFINE_LOCALE_CATEGORY(_name)			\
+  scm_c_define ("LC_" SCM_I18N_STRINGIFY (_name) "_MASK",	\
 		SCM_I_MAKINUM (LC_ ## _name ## _MASK));
 #include "locale-categories.h"
 
 #undef SCM_DEFINE_LOCALE_CATEGORY
-#undef SCM_STRINGIFY_LC
-#undef _SCM_STRINGIFY_LC
 
   scm_c_define ("LC_ALL_MASK", SCM_I_MAKINUM (LC_ALL_MASK));
 


--- orig/libguile/i18n.h
+++ mod/libguile/i18n.h
@@ -40,6 +40,7 @@
 SCM_API SCM scm_string_locale_downcase (SCM chr, SCM locale);
 SCM_API SCM scm_locale_string_to_integer (SCM str, SCM base, SCM locale);
 SCM_API SCM scm_locale_string_to_inexact (SCM str, SCM locale);
+SCM_API SCM scm_language_information (SCM item, SCM locale);
 
 SCM_API void scm_init_i18n (void);
 


--- orig/libguile/posix.c
+++ mod/libguile/posix.c
@@ -119,6 +119,13 @@
 # define USE_GNU_LOCALE_API
 #endif
 
+#if (defined USE_GNU_LOCALE_API) && (defined HAVE_XLOCALE_H)
+/* Darwin now supports the "GNU" thread-safe locale API but one has to
+   include <xlocale.h> to get it.  See:
+   http://developer.apple.com/documentation/Darwin/Reference/ManPages/man3/newlocale.3.html  */
+# include <xlocale.h>
+#endif
+
 #if HAVE_CRYPT_H
 #  include <crypt.h>
 #endif
@@ -1384,12 +1391,11 @@
 }
 #undef FUNC_NAME
 
-#ifndef USE_GNU_LOCALE_API
 /* This mutex is used to serialize invocations of `setlocale ()' on non-GNU
-   systems (i.e., systems where a reentrant locale API is not available).
-   See `i18n.c' for details.  */
-scm_i_pthread_mutex_t scm_i_locale_mutex;
-#endif
+   systems (i.e., systems where a reentrant locale API is not available).  It
+   is also acquired before calls to `nl_langinfo ()'.  See `i18n.c' for
+   details.  */
+scm_i_pthread_mutex_t scm_i_locale_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 
 #ifdef HAVE_SETLOCALE
 
@@ -1406,6 +1412,7 @@
 	    "the locale will be set using environment variables.")
 #define FUNC_NAME s_scm_setlocale
 {
+  int c_category;
   char *clocale;
   char *rv;
 
@@ -1421,13 +1428,11 @@
       scm_dynwind_free (clocale);
     }
 
-#ifndef USE_GNU_LOCALE_API
+  c_category = scm_i_to_lc_category (category, 1);
+
   scm_i_pthread_mutex_lock (&scm_i_locale_mutex);
-#endif
-  rv = setlocale (scm_i_to_lc_category (category, 1), clocale);
-#ifndef USE_GNU_LOCALE_API
+  rv = setlocale (c_category, clocale);
   scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
-#endif
 
   if (rv == NULL)
     {
@@ -1965,10 +1970,6 @@
 void
 scm_init_posix ()
 {
-#ifndef USE_GNU_LOCALE_API
-  scm_i_pthread_mutex_init (&scm_i_locale_mutex, NULL);
-#endif
-
   scm_add_feature ("posix");
 #ifdef HAVE_GETEUID
   scm_add_feature ("EIDs");


--- orig/libguile/strings.c
+++ mod/libguile/strings.c
@@ -17,9 +17,19 @@
 
 
 \f
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
 
 #include <string.h>
 #include <stdio.h>
+#ifdef HAVE_ICONV_H
+# include <iconv.h>
+#endif
+#if (defined HAVE_LANGINFO_H) && (defined HAVE_NL_TYPES_H)
+# include <langinfo.h>
+# include <nl_types.h>
+#endif
 
 #include "libguile/_scm.h"
 #include "libguile/chars.h"
@@ -29,6 +39,10 @@
 #include "libguile/validate.h"
 #include "libguile/dynwind.h"
 
+#include "libguile/threads.h"
+#include "libguile/posix.h" /* `scm_i_locale_mutex' */
+
+
 \f
 
 /* {Strings}
@@ -115,13 +129,176 @@
     }
   else
     {
-      char *mem = scm_gc_malloc (len+1, "string");
+      char *mem = scm_gc_malloc (len+1, "stringbuf");
       mem[len] = '\0';
       return scm_double_cell (STRINGBUF_TAG, (scm_t_bits) mem,
 			      (scm_t_bits) len, (scm_t_bits) 0);
     }
 }
 
+static void
+unlock_mutex (void *mutex)
+{
+  scm_i_pthread_mutex_unlock ((scm_i_pthread_mutex_t *) mutex);
+}
+
+typedef struct
+{
+  char   *start;
+  size_t  max_len;
+} scm_t_buffer;
+
+static void
+free_buf (void *bufp)
+{
+  scm_t_buffer *buf;
+
+  buf = (scm_t_buffer *)bufp;
+  if (buf->start != NULL)
+    {
+      scm_gc_free (buf->start, buf->max_len, "stringbuf");
+      buf->start = NULL;
+      buf->max_len = 0;
+    }
+}
+
+
+/* Return a new stringbuf from string STR of size LEN which is encoded in
+   CHARSET.  */
+static SCM
+make_stringbuf_from_c_string (const char *str, size_t len,
+			      const char *charset)
+{
+  SCM res;
+  char *dst;
+
+  if (len == (size_t) -1)
+    len = strlen (str);
+
+#if (!defined HAVE_NL_LANGINFO) || (!defined HAVE_ICONV)
+  res = make_stringbuf (len);
+  dst = STRINGBUF_CHARS (res);
+  memcpy (dst, str, len);
+#else
+  {
+    /* We make the assumption that the current locale's charset is used as
+       our internal encoding for strings.  */
+    const char *current_charset;
+
+    scm_i_pthread_mutex_lock (&scm_i_locale_mutex);
+    current_charset = nl_langinfo (CODESET);
+    if ((charset == NULL)
+	|| (!strcmp (charset, current_charset)))
+      {
+	/* No conversion needed.  */
+	scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
+
+	res = make_stringbuf (len);
+	dst = STRINGBUF_CHARS (res);
+	memcpy (dst, str, len);
+      }
+    else
+      {
+	/* Need to convert from CHARSET to CURRENT_CHARSET.  */
+	iconv_t cc;
+	size_t nconv, output_avail, output_len;
+	char *output;
+	scm_t_buffer output_buf = { NULL, 0 };
+
+	/* The memory allocation routines may raise an exception so we must
+	   make sure we don't leave the locale mutex locked if that
+	   happens.  */
+	scm_dynwind_begin (0);
+	scm_dynwind_unwind_handler (unlock_mutex, &scm_i_locale_mutex, 0);
+	scm_dynwind_unwind_handler (free_buf, &output_buf, 0);
+
+	cc = iconv_open (current_charset, charset);
+	if (cc == (iconv_t) -1)
+	  goto conv_open_error;
+
+	output_buf.max_len = output_avail = len * 2;
+	output_buf.start = output =
+	  (char *) scm_gc_malloc (output_buf.max_len, "stringbuf");
+
+	nconv = iconv (cc, NULL, NULL, &output, &output_avail);
+	if (nconv == (size_t) -1)
+	  goto conv_error;
+
+	/* Convert from STR into OUTPUT_START.  */
+	while ((len > 0) && (output_avail > 0))
+	  {
+	    nconv = iconv (cc, (char **)&str, &len,
+			   &output, &output_avail);
+
+	    if (nconv == (size_t) -1)
+	      {
+		switch (errno)
+		  {
+		  case E2BIG:
+		    /* We ran output of space in OUTPUT: grow it.  */
+		    output_len = output_buf.max_len - output_avail;
+		    output_buf.start =
+		      scm_gc_realloc (output_buf.start, output_buf.max_len,
+				      output_buf.max_len * 2, "stringbuf");
+
+		    output = output_buf.start + output_len;
+		    output_buf.max_len *= 2;
+		    output_avail = output_buf.max_len - output_len;
+		    break;
+
+		  default:
+		    /* Incomplete byte sequence in STR, or actual conversion
+		       error.  */
+		    goto conv_error;
+		  }
+	      }
+	  }
+
+	output_len = output_buf.max_len - output_avail;
+
+	*output = '\0';
+	iconv_close (cc);
+	goto done;
+
+      conv_error:
+	iconv_close (cc);
+      conv_open_error:
+	scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
+	scm_syserror (__FUNCTION__);
+
+      done:
+	scm_dynwind_end ();
+	scm_i_pthread_mutex_unlock (&scm_i_locale_mutex);
+
+	/* Note: The stringbuf' length will be OUTPUT_LEN, that is, the
+	   length _in octets_ of the converted string.  This will be so until
+	   we switch to Unicode internally.  */
+	if (output_len <= STRINGBUF_MAX_INLINE_LEN - 1)
+	  {
+	    res = scm_double_cell (STRINGBUF_TAG | STRINGBUF_F_INLINE
+				   | (output_len << 16),
+				   0, 0, 0);
+	    memcpy (STRINGBUF_CHARS (res), output_buf.start, output_len);
+	  }
+	else
+	  {
+	    if (output_buf.max_len > output_len + 1)
+	      /* Shrink the output buffer.  */
+	      output_buf.start = scm_gc_realloc (output_buf.start,
+						 output_buf.max_len,
+						 output_len + 1, "stringbuf");
+
+	    res = scm_double_cell (STRINGBUF_TAG,
+				   (scm_t_bits) output_buf.start,
+				   (scm_t_bits) output_len, (scm_t_bits) 0);
+	  }
+      }
+  }
+#endif
+
+  return res;
+}
+
 /* Return a new stringbuf whose underlying storage consists of the LEN+1
    octets pointed to by STR (the last octet is zero).  */
 SCM_C_INLINE_KEYWORD SCM
@@ -149,6 +326,7 @@
 
 scm_i_pthread_mutex_t stringbuf_write_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 
+\f
 /* Copy-on-write strings.
  */
 
@@ -179,16 +357,23 @@
 
 #define IS_SH_STRING(str)   (SCM_CELL_TYPE(str)==SH_STRING_TAG)
 
+static inline SCM
+make_string_from_stringbuf (SCM stringbuf)
+{
+  return (scm_double_cell (STRING_TAG, SCM_UNPACK (stringbuf),
+			   (scm_t_bits) 0,
+			   (scm_t_bits) STRINGBUF_LENGTH (stringbuf)));
+}
+
 SCM
 scm_i_make_string (size_t len, char **charsp)
 {
   SCM buf = make_stringbuf (len);
-  SCM res;
+
   if (charsp)
     *charsp = STRINGBUF_CHARS (buf);
-  res = scm_double_cell (STRING_TAG, SCM_UNPACK(buf),
-			 (scm_t_bits)0, (scm_t_bits) len);
-  return res;
+
+  return (make_string_from_stringbuf (buf));
 }
 
 static void
@@ -842,6 +1027,25 @@
 }
 
 SCM
+scm_from_stringn (const char *str, size_t len,
+		  const char *charset)
+{
+  SCM stringbuf;
+
+  stringbuf = make_stringbuf_from_c_string (str, len, charset);
+  return (make_string_from_stringbuf (stringbuf));
+}
+
+SCM
+scm_from_string (const char *str, const char *charset)
+{
+  SCM stringbuf;
+
+  stringbuf = make_stringbuf_from_c_string (str, -1, charset);
+  return (make_string_from_stringbuf (stringbuf));
+}
+
+SCM
 scm_from_locale_stringn (const char *str, size_t len)
 {
   SCM res;
@@ -849,8 +1053,10 @@
 
   if (len == (size_t)-1)
     len = strlen (str);
+
   res = scm_i_make_string (len, &dst);
   memcpy (dst, str, len);
+
   return res;
 }
 


--- orig/libguile/strings.h
+++ mod/libguile/strings.h
@@ -100,6 +100,9 @@
 SCM_API int scm_is_string (SCM x);
 SCM_API SCM scm_from_locale_string (const char *str);
 SCM_API SCM scm_from_locale_stringn (const char *str, size_t len);
+SCM_API SCM scm_from_string (const char *str, const char *charset);
+SCM_API SCM scm_from_stringn (const char *str, size_t len,
+			      const char *charset);
 SCM_API SCM scm_take_locale_string (char *str);
 SCM_API SCM scm_take_locale_stringn (char *str, size_t len);
 SCM_API char *scm_to_locale_string (SCM str);


--- orig/srfi/srfi-19.scm
+++ mod/srfi/srfi-19.scm
@@ -41,7 +41,8 @@
 (define-module (srfi srfi-19)
   :use-module (srfi srfi-6)
   :use-module (srfi srfi-8)
-  :use-module (srfi srfi-9))
+  :use-module (srfi srfi-9)
+  :use-module (ice-9 i18n))
 
 (begin-deprecated
  ;; Prevent `export' from re-exporting core bindings.  This behaviour
@@ -150,48 +151,70 @@
 
 ;;-- LOCALE dependent constants
 
-(define priv:locale-number-separator ".")
+(define priv:locale-number-separator
+  (cond-feature (language-information RADIXCHAR)
+                (else ".")))
 
 (define priv:locale-abbr-weekday-vector
-  (vector "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))
+  (cond-feature (language-information
+                 (vector ABDAY_1 ABDAY_2 ABDAY_3
+                         ABDAY_4 ABDAY_5 ABDAY_6 ABDAY_7))
+                (else
+                 (vector "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))))
 
 (define priv:locale-long-weekday-vector
-  (vector
-   "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))
+  (cond-feature (language-information
+                 (vector DAY_1 DAY_2 DAY_3 DAY_4 DAY_5 DAY_6 DAY_7))
+                (else
+                 (vector "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday"
+                         "Friday" "Saturday"))))
 
 ;; note empty string in 0th place.
 (define priv:locale-abbr-month-vector
-  (vector ""
-          "Jan"
-          "Feb"
-          "Mar"
-          "Apr"
-          "May"
-          "Jun"
-          "Jul"
-          "Aug"
-          "Sep"
-          "Oct"
-          "Nov"
-          "Dec"))
+  (cond-feature (language-information
+                 (vector #f ABMON_1 ABMON_2 ABMON_3 ABMON_4 ABMON_5 ABMON_6
+                         ABMON_7 ABMON_8 ABMON_9 ABMON_10 ABMON_11 ABMON_12))
+                (else
+                 (vector ""
+                         "Jan"
+                         "Feb"
+                         "Mar"
+                         "Apr"
+                         "May"
+                         "Jun"
+                         "Jul"
+                         "Aug"
+                         "Sep"
+                         "Oct"
+                         "Nov"
+                         "Dec"))))
 
 (define priv:locale-long-month-vector
-  (vector ""
-          "January"
-          "February"
-          "March"
-          "April"
-          "May"
-          "June"
-          "July"
-          "August"
-          "September"
-          "October"
-          "November"
-          "December"))
-
-(define priv:locale-pm "PM")
-(define priv:locale-am "AM")
+  (cond-feature (language-information
+                 (vector #f MON_1 MON_2 MON_3 MON_4 MON_5 MON_6
+                         MON_7 MON_8 MON_9 MON_10 MON_11 MON_12))
+                (else
+                 (vector ""
+                         "January"
+                         "February"
+                         "March"
+                         "April"
+                         "May"
+                         "June"
+                         "July"
+                         "August"
+                         "September"
+                         "October"
+                         "November"
+                         "December"))))
+
+(define priv:locale-pm
+  (cond-feature (language-information PM_STR)
+                (else "PM")))
+
+(define priv:locale-am
+  (cond-feature (language-information AM_STR)
+                (else "AM")))
 
 ;; See date->string
 (define priv:locale-date-time-format "~a ~b ~d ~H:~M:~S~z ~Y")
@@ -965,23 +988,48 @@
   (abs (remainder i (expt 10 n))))
 
 (define (priv:locale-abbr-weekday n)
-  (vector-ref priv:locale-abbr-weekday-vector n))
+  (cond-feature (language-information
+                 (language-information
+                  (vector-ref priv:locale-abbr-weekday-vector n)))
+                (else
+                 (vector-ref priv:locale-abbr-weekday-vector n))))
 
 (define (priv:locale-long-weekday n)
-  (vector-ref priv:locale-long-weekday-vector n))
+  (cond-feature (language-information
+                 (language-information
+                  (vector-ref priv:locale-long-weekday-vector n)))
+                (else
+                 (vector-ref priv:locale-long-weekday-vector n))))
 
 (define (priv:locale-abbr-month n)
-  (vector-ref priv:locale-abbr-month-vector n))
+  (cond-feature (language-information
+                 (language-information
+                  (vector-ref priv:locale-abbr-month-vector n)))
+                (else
+                 (vector-ref priv:locale-abbr-month-vector n))))
 
 (define (priv:locale-long-month n)
-  (vector-ref priv:locale-long-month-vector n))
+  (cond-feature (language-information
+                 (language-information
+                  (vector-ref priv:locale-long-month-vector n)))
+                (else
+                 (vector-ref priv:locale-long-month-vector n))))
 
 (define (priv:vector-find needle haystack comparator)
   (let ((len (vector-length haystack)))
     (define (priv:vector-find-int index)
       (cond
        ((>= index len) #f)
-       ((comparator needle (vector-ref haystack index)) index)
+       ((comparator needle
+                    (cond-feature
+                     (language-information
+                      (let ((item (vector-ref haystack index)))
+                        (if item
+                            (language-information item)
+                            "")))
+                     (else
+                      (vector-ref haystack index))))
+        index)
        (else (priv:vector-find-int (+ index 1)))))
     (priv:vector-find-int 0)))
 
@@ -1003,10 +1051,10 @@
 (define (priv:locale-print-time-zone date port)
   (priv:tz-printer (date-zone-offset date) port))
 
-;; FIXME: we should use strftime to determine this dynamically if possible.
-;; Again, locale specific.
 (define (priv:locale-am/pm hr)
-  (if (> hr 11) priv:locale-pm priv:locale-am))
+  (let ((am/pm (if (> hr 11) priv:locale-pm priv:locale-am)))
+    (cond-feature (language-information (language-information am/pm))
+                  (else am/pm))))
 
 (define (priv:tz-printer offset port)
   (cond


--- orig/test-suite/tests/i18n.test
+++ mod/test-suite/tests/i18n.test
@@ -19,6 +19,7 @@
 
 (define-module (test-suite i18n)
   :use-module (ice-9 i18n)
+  :use-module (srfi srfi-1)
   :use-module (test-suite lib))
 
 ;; Start from a pristine locale state.
@@ -65,7 +66,7 @@
 \f
 (define %french-locale
   (false-if-exception
-   (make-locale (logior LC_CTYPE_MASK LC_COLLATE_MASK)
+   (make-locale (logior LC_CTYPE_MASK LC_COLLATE_MASK LC_NUMERIC_MASK)
                 "fr_FR.ISO-8859-1")))
 
 (define (under-french-locale-or-unresolved thunk)
@@ -134,7 +135,54 @@
                                   (make-locale LC_NUMERIC_MASK "C")))
       (lambda (result char-count)
         (and (equal? result 123.456)
-             (equal? char-count 7))))))
+             (equal? char-count 7)))))
+
+  (pass-if "locale-string->inexact (French)"
+    (under-french-locale-or-unresolved
+     (lambda ()
+       (call-with-values
+           (lambda ()
+             (locale-string->inexact "123,456" %french-locale))
+         (lambda (result char-count)
+           (and (equal? result 123.456)
+                (equal? char-count 7))))))))
+
+\f
+;;;
+;;; `language-information'
+;;;
+
+(define %have-language-information?
+  (provided? 'language-information))
+
+(setlocale LC_ALL "C")
+(define %c-locale (make-locale LC_ALL_MASK "C"))
+
+(define %english-days
+  '("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"))
+
+(define (every? . args)
+  (not (not (apply every args))))
+
+
+(with-test-prefix "language-information"
+
+  (pass-if "language-information (1 arg)"
+    (if (not %have-language-information?)
+        (throw 'unresolved)
+        (every? equal?
+                %english-days
+                (map language-information
+                     (list DAY_1 DAY_2 DAY_3 DAY_4 DAY_5 DAY_6 DAY_7)))))
+
+  (pass-if "language-information (2 args)"
+    (if (not %have-language-information?)
+        (throw 'unresolved)
+        (every? equal?
+                %english-days
+                (map (lambda (day)
+                       (language-information day %c-locale))
+                     (list DAY_1 DAY_2 DAY_3 DAY_4 DAY_5 DAY_6 DAY_7))))))
 
 
 ;;; Local Variables:


--- orig/test-suite/tests/srfi-19.test
+++ mod/test-suite/tests/srfi-19.test
@@ -27,6 +27,9 @@
   :use-module (srfi srfi-19)
   :use-module (ice-9 format))
 
+;; Make sure we use the default locale.
+(setlocale LC_ALL "C")
+
 (define (with-tz* tz thunk)
   "Temporarily set the TZ environment variable to the passed string
 value and call THUNK."
@@ -142,6 +145,19 @@
 		      (string->date "2001-06-01@08:00" "~Y-~m-~d@~H:~M")))
 		   (date->time-utc
 		    (make-date 0 0 0 12 1 6 2001 0))))
+  (pass-if "string->date understands days and months"
+           (time=? (let ((d (string->date "Saturday, December 9, 2006"
+                                          "~A, ~B ~d, ~Y")))
+                     (date->time-utc (make-date (date-nanosecond d)
+                                                (date-second d)
+                                                (date-minute d)
+                                                (date-hour d)
+                                                (date-day d)
+                                                (date-month d)
+                                                (date-year d)
+                                                0)))
+                   (date->time-utc
+                    (make-date 0 0 0 0 9 12 2006 0))))
   ;; check time comparison procedures
   (let* ((time1 (make-time time-monotonic 0 0))
          (time2 (make-time time-monotonic 0 0))




[-- Attachment #3: Type: text/plain, Size: 143 bytes --]

_______________________________________________
Guile-devel mailing list
Guile-devel@gnu.org
http://lists.gnu.org/mailman/listinfo/guile-devel

^ permalink raw reply	[flat|nested] 23+ messages in thread