From: ludo@chbouib.org (Ludovic Courtès)
Subject: More i18n
Date: Sun, 10 Dec 2006 16:04:56 +0100 [thread overview]
Message-ID: <877iwzokpz.fsf@chbouib.org> (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
next reply other threads:[~2006-12-10 15:04 UTC|newest]
Thread overview: 23+ messages / expand[flat|nested] mbox.gz Atom feed top
2006-12-10 15:04 Ludovic Courtès [this message]
2006-12-11 19:42 ` More i18n Neil Jerram
2006-12-12 9:09 ` Ludovic Courtès
2006-12-12 19:48 ` Kevin Ryde
2006-12-31 16:23 ` Neil Jerram
2006-12-31 16:22 ` Neil Jerram
2006-12-13 0:11 ` Kevin Ryde
2006-12-31 16:54 ` Neil Jerram
2006-12-11 23:26 ` Kevin Ryde
2006-12-12 9:36 ` Ludovic Courtès
2006-12-12 19:43 ` Kevin Ryde
2006-12-12 19:19 ` Kevin Ryde
2006-12-31 16:15 ` Neil Jerram
2007-01-01 22:32 ` Kevin Ryde
2007-01-16 21:46 ` Ludovic Courtès
2007-01-16 22:08 ` Ludovic Courtès
2007-01-23 0:49 ` Kevin Ryde
2007-01-23 0:46 ` Kevin Ryde
2007-01-23 23:44 ` Ludovic Courtès
2007-01-24 20:58 ` Kevin Ryde
2007-01-31 21:13 ` Ludovic Courtès
2007-01-31 22:06 ` Kevin Ryde
2007-01-25 1:05 ` Kevin Ryde
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=877iwzokpz.fsf@chbouib.org \
--to=ludo@chbouib.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).