--- orig/configure.in +++ mod/configure.in @@ -613,8 +613,9 @@ AC_CHECK_HEADERS([assert.h crt_externs.h # truncate - not in mingw # isblank - available as a GNU extension or in C99 # _NSGetEnviron - Darwin specific +# strcoll_l, newlocale - GNU extensions (glibc) # -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]) +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]) # Reasons for testing: # netdb.h - not in mingw --- orig/doc/ref/api-i18n.texi +++ mod/doc/ref/api-i18n.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -8,6 +8,266 @@ @node Internationalization @section Support for Internationalization +@cindex internationalization +@cindex i18n + +Guile provides internationalization support for Scheme programs in two +ways. First, procedures to manipulate text and data in a way that +conforms to particular cultural conventions (i.e., in a +``locale-dependent'' way) are provided in the @code{(ice-9 i18n)}. +Second, Guile allows the use of GNU @code{gettext} to translate +program message strings. + +@menu +* The ice-9 i18n Module:: Honoring cultural conventions. +* Gettext Support:: Translating message strings. +@end menu + + +@node The ice-9 i18n Module +@subsection The @code{(ice-9 i18n)} Module + +In order to make use of the following functions, one must import the +@code{(ice-9 i18n)} module in the usual way: + +@example +(use-modules (ice-9 i18n)) +@end example + +@cindex cultural conventions + +The @code{(ice-9 i18n)} module provides procedures to manipulate text +and other data in a way that conforms to the cultural conventions +chosen by the user. Each region of the world or language has its own +customs to, for instance, represent real numbers, classify characters, +collate text, etc. All these aspects comprise the so-called +``cultural conventions'' of that region or language. + +@cindex locale +@cindex locale category + +Computer systems typically refer to a set of cultural conventions as a +@dfn{locale}. For each particular aspect that comprise those cultural +conventions, a @dfn{locale category} is defined. For instance, the +way characters are classified is defined by the @code{LC_CTYPE} +category, while the language in which program messages are issued to +the user is defined by the @code{LC_MESSAGES} category +(@pxref{Locales, General Locale Information} for details). + +@cindex locale object + +The procedures provided by this module allow the development of +programs that adapt automatically to any locale setting. As we will +see later, many of the locale-dependent procedures provided by this +module can optionally take a @dfn{locale object} argument. This +additional argument defines the locale settings that must be followed +by the invoked procedure. When it is omitted, then the current locale +settings of the process are followed (@pxref{Locales, +@code{setlocale}}). + +The following procedures allow the manipulation of such locale +objects. + +@deffn {Scheme Procedure} make-locale category_mask locale_name [base_locale] +Return a reference to a data structure representing a set of locale +datasets. Unlike for the @var{category} parameter for +@code{setlocale}, the @var{category_mask} parameter here uses a single +bit for each category, made by OR'ing together @code{LC_*_MASK} bits. +The optional @var{base_locale} argument can be used to specify a +locale object whose settings are to be used as a basis for the locale +object being returned. + +The available locale category masks are the following: + +@defvar LC_COLLATE_MASK +Represents the collation locale category. +@end defvar +@defvar LC_CTYPE_MASK +Represents the character classification locale category. +@end defvar +@defvar LC_MESSAGES_MASK +Represents the messages locale category. +@end defvar +@defvar LC_MONETARY_MASK +Represents the monetary locale category. +@end defvar +@defvar LC_NUMERIC_MASK +Represents the way numbers are displayed. +@end defvar +@defvar LC_TIME_MASK +Represents the way date and time are displayed +@end defvar + +The following category masks are also available but will not have any +effect on systems that do not support them: + +@defvar LC_PAPER_MASK +@defvarx LC_NAME_MASK +@defvarx LC_ADDRESS_MASK +@defvarx LC_TELEPHONE_MASK +@defvarx LC_MEASUREMENT_MASK +@defvarx LC_IDENTIFICATION_MASK +@end defvar + +Finally, there is also: + +@defvar LC_ALL_MASK +This represents all the locale categories supported by the system. +@end defvar + +The @code{LC_*_MASK} variables are bound to integers which may be OR'd +together using @code{logior} (@pxref{Primitive Numerics, +@code{logior}}). For instance, the following invocation creates a +locale object that combines the use of Esperanto for messages and +character classification with the default settings for the other +categories (i.e., the settings of the default @code{C} locale which +usually represents conventions in use in the USA): + +@example +(make-locale (logior LC_MESSAGE_MASK LC_CTYPE_MASK) "eo_EO") +@end example + +The following example combines the use of Swedish conventions with +monetary conventions from Croatia: + +@example +(make-locale LC_MONETARY_MASK "hr_HR" + (make-locale LC_ALL_MASK "sv_SE")) +@end example + +A @code{system-error} exception (@pxref{Handling Errors}) is raised by +@code{make-locale} when @var{locale_name} does not match any of the +locales compiled on the system. + +@end deffn + +@deffn {Scheme Procedure} locale? obj +Return true if @var{obj} is a locale object. +@end deffn + +The following procedures provide support for text collation. + +@deffn {Scheme Procedure} string-locale? 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] +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] +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} char-locale? 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] +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. +@end deffn + +@deffn {Scheme Procedure} char-locale-ci=? c1 c2 [locale] +Return true if character @var{c1} is equal to @var{c2}, in a case +insensitive way according to @var{locale} or to the current locale. +@end deffn + +The procedures below provide support for ``character case mapping'', +i.e., to convert characters or strings to their upper-case or +lower-case equivalent. Note that SRFI-13 provides procedures that +look similar (@pxref{Alphabetic Case Mapping}). However, the SRFI-13 +procedures are locale-independent. Therefore, they do not take into +account specificities of the customs in use in a particular language +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. + +@deffn {Scheme Procedure} char-locale-downcase chr [locale] +Return the lowercase character that corresponds to @var{chr} according +to either @var{locale} or the current locale. +@end deffn + +@deffn {Scheme Procedure} char-locale-upcase chr [locale] +Return the uppercase character that corresponds to @var{chr} according +to either @var{locale} or the current locale. +@end deffn + +@deffn {Scheme Procedure} string-locale-upcase str [locale] +Return a new string that is the uppercase version of @var{str} +according to either @var{locale} or the current locale. +@end deffn + +@deffn {Scheme Procedure} string-locale-downcase str [locale] +Return a new string that is the down-case version of @var{str} +according to either @var{locale} or the current locale. +@end deffn + +Finally, 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 this differences. + +@deffn {Scheme Procedure} locale-string->integer str [base [locale]] +Convert string @var{str} into an integer according to either +@var{locale} (a locale object as returned by @code{make-locale}) or +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). +@end deffn + +@deffn {Scheme Procedure} locale-string->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). +@end deffn + + +@node Gettext Support +@subsection Gettext Support + Guile provides an interface to GNU @code{gettext} for translating message strings (@pxref{Introduction,,, gettext, GNU @code{gettext} utilities}). @@ -155,4 +415,5 @@ future. @c Local Variables: @c TeX-master: "guile.texi" +@c ispell-local-dictionary: "american" @c End: --- orig/doc/ref/posix.texi +++ mod/doc/ref/posix.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -3159,6 +3159,10 @@ categories based on standard environment For full details on categories and locale names @pxref{Locales,, Locales and Internationalization, libc, The GNU C Library Reference Manual}. + +Note that @code{setlocale} affects locale settings for the whole +process. For a safer, thread-safe and reentrant alternative, +@xref{The ice-9 i18n Module, Locale Objects and @code{make-locale}}. @end deffn @node Encryption --- orig/libguile/Makefile.am +++ mod/libguile/Makefile.am @@ -31,7 +31,7 @@ INCLUDES = -I.. -I$(top_srcdir) ETAGS_ARGS = --regex='/SCM_\(GLOBAL_\)?\(G?PROC\|G?PROC1\|SYMBOL\|VCELL\|CONST_LONG\).*\"\([^\"]\)*\"/\3/' \ --regex='/[ \t]*SCM_[G]?DEFINE1?[ \t]*(\([^,]*\),[^,]*/\1/' -lib_LTLIBRARIES = libguile.la +lib_LTLIBRARIES = libguile.la libguile-i18n-v0.la bin_PROGRAMS = guile noinst_PROGRAMS = guile_filter_doc_snarfage gen-scmconfig @@ -97,9 +97,10 @@ libguile_la_SOURCES = alist.c arbiters.c deprecated.c discouraged.c dynwind.c environments.c eq.c error.c \ eval.c evalext.c extensions.c feature.c fluids.c fports.c \ futures.c gc.c gc-mark.c gc-segment.c gc-malloc.c gc-card.c \ - gc-freelist.c gc_os_dep.c gdbint.c gh_data.c gh_eval.c gh_funcs.c \ + gc-freelist.c gc_os_dep.c gdbint.c gettext.c \ + gh_data.c gh_eval.c gh_funcs.c \ gh_init.c gh_io.c gh_list.c gh_predicates.c goops.c gsubr.c \ - guardians.c hash.c hashtab.c hooks.c i18n.c init.c inline.c \ + guardians.c hash.c hashtab.c hooks.c init.c inline.c \ ioext.c keywords.c lang.c list.c load.c macros.c mallocs.c \ modules.c numbers.c objects.c objprop.c options.c pairs.c ports.c \ print.c procprop.c procs.c properties.c random.c rdelim.c read.c \ @@ -109,11 +110,16 @@ libguile_la_SOURCES = alist.c arbiters.c throw.c values.c variable.c vectors.c version.c vports.c weaks.c \ ramap.c unif.c +libguile_i18n_v0_la_SOURCES = i18n.c +libguile_i18n_v0_la_CFLAGS = $(libguile_la_CFLAGS) +libguile_i18n_v0_la_LDFLAGS = -module -L$(builddir) -lguile + DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \ continuations.x debug.x deprecation.x deprecated.x discouraged.x \ dynl.x dynwind.x environments.x eq.x error.x eval.x evalext.x \ extensions.x feature.x fluids.x fports.x futures.x gc.x gc-mark.x \ - gc-segment.x gc-malloc.x gc-card.x goops.x gsubr.x guardians.x \ + gc-segment.x gc-malloc.x gc-card.x gettext.x goops.x \ + gsubr.x guardians.x \ hash.x hashtab.x hooks.x i18n.x init.x ioext.x keywords.x lang.x \ list.x load.x macros.x mallocs.x modules.x numbers.x objects.x \ objprop.x options.x pairs.x ports.x print.x procprop.x procs.x \ @@ -131,7 +137,8 @@ DOT_DOC_FILES = alist.doc arbiters.doc a environments.doc eq.doc error.doc eval.doc evalext.doc \ extensions.doc feature.doc fluids.doc fports.doc futures.doc \ gc.doc goops.doc gsubr.doc gc-mark.doc gc-segment.doc \ - gc-malloc.doc gc-card.doc guardians.doc hash.doc hashtab.doc \ + gc-malloc.doc gc-card.doc gettext.doc \ + guardians.doc hash.doc hashtab.doc \ hooks.doc i18n.doc init.doc ioext.doc keywords.doc lang.doc \ list.doc load.doc macros.doc mallocs.doc modules.doc numbers.doc \ objects.doc objprop.doc options.doc pairs.doc ports.doc print.doc \ @@ -153,8 +160,9 @@ EXTRA_libguile_la_SOURCES = _scm.h \ inet_aton.c memmove.c putenv.c strerror.c \ dynl.c regex-posix.c \ filesys.c posix.c net_db.c socket.c \ - debug-malloc.c mkstemp.c \ - win32-uname.c win32-dirent.c win32-socket.c + debug-malloc.c mkstemp.c \ + win32-uname.c win32-dirent.c win32-socket.c \ + locale-categories.h ## delete guile-snarf.awk from the installation bindir, in case it's ## lingering there due to an earlier guile version not having been @@ -187,7 +195,8 @@ modinclude_HEADERS = __scm.h alist.h arb deprecation.h deprecated.h discouraged.h dynl.h dynwind.h \ environments.h eq.h error.h eval.h evalext.h extensions.h \ feature.h filesys.h fluids.h fports.h futures.h gc.h \ - gdb_interface.h gdbint.h goops.h gsubr.h guardians.h hash.h \ + gdb_interface.h gdbint.h gettext.h goops.h \ + gsubr.h guardians.h hash.h \ hashtab.h hooks.h i18n.h init.h inline.h ioext.h iselect.h \ keywords.h lang.h list.h load.h macros.h mallocs.h modules.h \ net_db.h numbers.h objects.h objprop.h options.h pairs.h ports.h \ @@ -212,7 +221,7 @@ EXTRA_DIST = ChangeLog-gh ChangeLog-scm cpp_errno.c cpp_err_symbols.in cpp_err_symbols.c \ cpp_sig_symbols.c cpp_sig_symbols.in cpp_cnvt.awk \ c-tokenize.lex version.h.in \ - scmconfig.h.top gettext.h + scmconfig.h.top libgettext.h # $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) \ # guile-procedures.txt guile.texi --- orig/libguile/i18n.c +++ mod/libguile/gettext.c @@ -22,11 +22,11 @@ #include "libguile/_scm.h" #include "libguile/feature.h" -#include "libguile/i18n.h" #include "libguile/strings.h" #include "libguile/dynwind.h" -#include "gettext.h" +#include "libguile/gettext.h" +#include "libgettext.h" #include @@ -312,11 +312,15 @@ SCM_DEFINE (scm_bind_textdomain_codeset, } #undef FUNC_NAME -void -scm_init_i18n () +void +scm_init_gettext () { + /* When gettext support was first added (in 1.8.0), it provided feature + `i18n'. We keep this as is although the name is a bit misleading + now. */ scm_add_feature ("i18n"); -#include "libguile/i18n.x" + +#include "libguile/gettext.x" } --- orig/libguile/i18n.h +++ mod/libguile/gettext.h @@ -1,7 +1,7 @@ /* classes: h_files */ -#ifndef SCM_I18N_H -#define SCM_I18N_H +#ifndef SCM_GETTEXT_H +#define SCM_GETTEXT_H /* Copyright (C) 2004, 2006 Free Software Foundation, Inc. * @@ -30,9 +30,9 @@ SCM_API SCM scm_bind_textdomain_codeset SCM_API int scm_i_to_lc_category (SCM category, int allow_lc_all); -SCM_API void scm_init_i18n (void); +SCM_API void scm_init_gettext (void); -#endif /* SCM_I18N_H */ +#endif /* SCM_GETTEXT_H */ /* Local Variables: --- orig/libguile/init.c +++ mod/libguile/init.c @@ -63,7 +63,7 @@ #include "libguile/hash.h" #include "libguile/hashtab.h" #include "libguile/hooks.h" -#include "libguile/i18n.h" +#include "libguile/gettext.h" #include "libguile/iselect.h" #include "libguile/ioext.h" #include "libguile/keywords.h" @@ -473,7 +473,7 @@ scm_i_init_guile (SCM_STACKITEM *base) scm_init_properties (); scm_init_hooks (); /* Requires smob_prehistory */ scm_init_gc (); /* Requires hooks, async */ - scm_init_i18n (); + scm_init_gettext (); scm_init_ioext (); scm_init_keywords (); scm_init_list (); --- orig/libguile/posix.c +++ mod/libguile/posix.c @@ -40,7 +40,7 @@ #include "libguile/validate.h" #include "libguile/posix.h" -#include "libguile/i18n.h" +#include "libguile/gettext.h" #include "libguile/threads.h" @@ -115,6 +115,10 @@ extern char ** environ; #include #endif +#if (defined HAVE_NEWLOCALE) && (defined HAVE_STRCOLL_L) +# define USE_GNU_LOCALE_API +#endif + #if HAVE_CRYPT_H # include #endif @@ -1380,7 +1384,15 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, } #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 + #ifdef HAVE_SETLOCALE + SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0, (SCM category, SCM locale), "If @var{locale} is omitted, return the current value of the\n" @@ -1409,7 +1421,14 @@ SCM_DEFINE (scm_setlocale, "setlocale", scm_dynwind_free (clocale); } +#ifndef USE_GNU_LOCALE_API + 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 + scm_i_pthread_mutex_unlock (&scm_i_locale_mutex); +#endif + if (rv == NULL) { /* POSIX and C99 don't say anything about setlocale setting errno, so @@ -1943,9 +1962,13 @@ SCM_DEFINE (scm_gethostname, "gethostnam #endif /* HAVE_GETHOSTNAME */ -void +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/posix.h +++ mod/libguile/posix.h @@ -23,8 +23,7 @@ #include "libguile/__scm.h" - - +#include "libguile/threads.h" @@ -87,6 +86,8 @@ SCM_API SCM scm_sethostname (SCM name); SCM_API SCM scm_gethostname (void); SCM_API void scm_init_posix (void); +SCM_API scm_i_pthread_mutex_t scm_i_locale_mutex; + #endif /* SCM_POSIX_H */ /* --- orig/test-suite/Makefile.am +++ mod/test-suite/Makefile.am @@ -43,6 +43,7 @@ SCM_TESTS = tests/alist.test \ tests/guardians.test \ tests/hash.test \ tests/hooks.test \ + tests/i18n.test \ tests/import.test \ tests/interp.test \ tests/list.test \ * added files --- /dev/null +++ mod/ice-9/.arch-ids/i18n.scm.id @@ -0,0 +1 @@ +Ludovic Courtes Sat Oct 21 16:12:32 2006 29433.0 --- /dev/null +++ mod/ice-9/i18n.scm @@ -0,0 +1,68 @@ +;;;; i18n.scm --- internationalization support + +;;;; Copyright (C) 2006 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2.1 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Author: Ludovic Courtès + +;;; Commentary: +;;; +;;; This module provides a number of routines that support +;;; internationalization (e.g., locale-dependent text collation, character +;;; mapping, etc.). It also defines `locale' objects, representing locale +;;; settings, that may be passed around to most of these procedures. +;;; + +;;; Code: + +(define-module (ice-9 i18n) + :export (;; `locale' type + make-locale locale? + + ;; locale category masks (standard) + LC_ALL_MASK + LC_COLLATE_MASK LC_CTYPE_MASK LC_MESSAGES_MASK + LC_MONETARY_MASK LC_NUMERIC_MASK LC_TIME_MASK + + ;; locale category masks (non-standard) + LC_PAPER_MASK LC_NAME_MASK LC_ADDRESS_MASK + LC_TELEPHONE_MASK LC_MEASUREMENT_MASK + LC_IDENTIFICATION_MASK + + ;; text collation + string-locale? + string-locale-ci? string-locale-ci=? + + char-locale? + char-locale-ci? char-locale-ci=? + + ;; character mapping + char-locale-downcase char-locale-upcase + string-locale-downcase string-locale-upcase + + ;; reading numbers + locale-string->integer locale-string->inexact)) + + +(dynamic-call "scm_init_i18n" + (dynamic-link "libguile-i18n-v0")) + + +;;; Local Variables: +;;; coding: latin-1 +;;; End: + +;;; i18n.scm ends here --- /dev/null +++ mod/libguile/.arch-ids/i18n.c.id @@ -0,0 +1 @@ +Ludovic Courtes Sat Oct 21 17:24:34 2006 11178.0 --- /dev/null +++ mod/libguile/.arch-ids/i18n.h.id @@ -0,0 +1 @@ +Ludovic Courtes Sat Oct 21 17:24:44 2006 11192.0 --- /dev/null +++ mod/libguile/.arch-ids/locale-categories.h.id @@ -0,0 +1 @@ +Ludovic Courtes Sat Oct 14 17:20:45 2006 6695.0 --- /dev/null +++ mod/libguile/i18n.c @@ -0,0 +1,1161 @@ +/* Copyright (C) 2006 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ + +#define _GNU_SOURCE /* Ask for glibc's `newlocale' API */ + +#if HAVE_CONFIG_H +# include +#endif + +#if HAVE_ALLOCA_H +# include +#elif defined __GNUC__ +# define alloca __builtin_alloca +#elif defined _AIX +# define alloca __alloca +#elif defined _MSC_VER +# include +# define alloca _alloca +#else +# include +# ifdef __cplusplus +extern "C" +# endif +void *alloca (size_t); +#endif + +#include "libguile/_scm.h" +#include "libguile/feature.h" +#include "libguile/i18n.h" +#include "libguile/strings.h" +#include "libguile/chars.h" +#include "libguile/dynwind.h" +#include "libguile/validate.h" +#include "libguile/values.h" + +#include +#include /* `strcoll ()' */ +#include /* `toupper ()' et al. */ +#include + +#if (defined HAVE_NEWLOCALE) && (defined HAVE_STRCOLL_L) +# define USE_GNU_LOCALE_API +#endif + +#ifndef USE_GNU_LOCALE_API +# include "libguile/posix.h" /* for `scm_i_locale_mutex' */ +#endif + +#ifndef HAVE_SETLOCALE +static inline char * +setlocale (int category, const char *name) +{ + errno = ENOSYS; + return NULL; +} +#endif + + + +/* Locale objects, string and character collation, and other locale-dependent + string operations. + + A large part of the code here deals with emulating glibc's reentrant + locale API on non-GNU systems. The emulation is a bit "brute-force": + Whenever a `-locale 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) + +# ifdef LC_PAPER +# define LC_PAPER_MASK (1 << LC_PAPER) +# else +# define LC_PAPER_MASK 0 +# endif +# ifdef LC_NAME +# define LC_NAME_MASK (1 << LC_NAME) +# else +# define LC_NAME_MASK 0 +# endif +# ifdef LC_ADDRESS +# define LC_ADDRESS_MASK (1 << LC_ADDRESS) +# else +# define LC_ADDRESS_MASK 0 +# endif +# ifdef LC_TELEPHONE +# define LC_TELEPHONE_MASK (1 << LC_TELEPHONE) +# else +# define LC_TELEPHONE_MASK 0 +# endif +# ifdef LC_MEASUREMENT +# define LC_MEASUREMENT_MASK (1 << LC_MEASUREMENT) +# else +# define LC_MEASUREMENT_MASK 0 +# endif +# ifdef LC_IDENTIFICATION +# define LC_IDENTIFICATION_MASK (1 << LC_IDENTIFICATION) +# else +# define LC_IDENTIFICATION_MASK 0 +# endif + +# define LC_ALL_MASK (LC_CTYPE_MASK \ + | LC_NUMERIC_MASK \ + | LC_TIME_MASK \ + | LC_COLLATE_MASK \ + | LC_MONETARY_MASK \ + | LC_MESSAGES_MASK \ + | LC_PAPER_MASK \ + | LC_NAME_MASK \ + | LC_ADDRESS_MASK \ + | LC_TELEPHONE_MASK \ + | LC_MEASUREMENT_MASK \ + | LC_IDENTIFICATION_MASK \ + ) + +/* Locale objects as returned by `make-locale' on non-GNU systems. */ +typedef struct scm_locale +{ + SCM base_locale; /* a `locale' object */ + char *locale_name; + int category_mask; +} *scm_t_locale; + +#else + +/* Alias for glibc's locale type. */ +typedef locale_t scm_t_locale; + +#endif + +/* Validate parameter ARG as a locale object and set C_LOCALE to the + corresponding C locale object. */ +#define SCM_VALIDATE_LOCALE_COPY(_pos, _arg, _c_locale) \ + do \ + { \ + SCM_VALIDATE_SMOB ((_pos), (_arg), locale_smob_type); \ + (_c_locale) = (scm_t_locale)SCM_SMOB_DATA (_arg); \ + } \ + while (0) + +/* Validate optional parameter ARG as either undefined or bound to a locale + object. Set C_LOCALE to the corresponding C locale object or NULL. */ +#define SCM_VALIDATE_OPTIONAL_LOCALE_COPY(_pos, _arg, _c_locale) \ + do \ + { \ + if ((_arg) != SCM_UNDEFINED) \ + SCM_VALIDATE_LOCALE_COPY (_pos, _arg, _c_locale); \ + else \ + (_c_locale) = NULL; \ + } \ + while (0) + + +SCM_SMOB (scm_tc16_locale_smob_type, "locale", 0); + +SCM_SMOB_FREE (scm_tc16_locale_smob_type, smob_locale_free, locale) +{ + scm_t_locale c_locale; + + c_locale = (scm_t_locale)SCM_SMOB_DATA (locale); + +#ifdef USE_GNU_LOCALE_API + freelocale ((locale_t)c_locale); +#else + c_locale->base_locale = SCM_UNDEFINED; + free (c_locale->locale_name); + + scm_gc_free (c_locale, sizeof (* c_locale), "locale"); +#endif + + return 0; +} + +#ifndef USE_GNU_LOCALE_API +static SCM +smob_locale_mark (SCM locale) +{ + scm_t_locale c_locale; + + c_locale = (scm_t_locale)SCM_SMOB_DATA (locale); + return (c_locale->base_locale); +} +#endif + + +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 " + "locale datasets. Unlike for the @var{category} parameter for " + "@code{setlocale}, the @var{category_mask} parameter here uses " + "a single bit for each category, made by OR'ing together " + "@code{LC_*_MASK} bits.") +#define FUNC_NAME s_scm_make_locale +{ + SCM locale = SCM_BOOL_F; + int c_category_mask; + char *c_locale_name; + scm_t_locale c_base_locale, c_locale; + + SCM_VALIDATE_INT_COPY (1, category_mask, c_category_mask); + SCM_VALIDATE_STRING (2, locale_name); + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, base_locale, c_base_locale); + + c_locale_name = scm_to_locale_string (locale_name); + +#ifdef USE_GNU_LOCALE_API + + c_locale = newlocale (c_category_mask, c_locale_name, c_base_locale); + + if (!c_locale) + locale = SCM_BOOL_F; + 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"); + c_locale->base_locale = base_locale; + + c_locale->category_mask = c_category_mask; + c_locale->locale_name = c_locale_name; + + SCM_NEWSMOB (locale, scm_tc16_locale_smob_type, c_locale); + +#endif + + return locale; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_locale_p, "locale?", 1, 0, 0, + (SCM obj), + "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; +} +#undef FUNC_NAME + + + +#ifndef USE_GNU_LOCALE_API /* Emulate GNU's reentrant locale API. */ + + +/* Maximum number of chained locales (via `base_locale'). */ +#define LOCALE_STACK_SIZE_MAX 256 + +typedef struct +{ +#define SCM_DEFINE_LOCALE_CATEGORY(_name) char * _name; +#include "locale-categories.h" +#undef SCM_DEFINE_LOCALE_CATEGORY +} scm_t_locale_settings; + +/* Fill out SETTINGS according to the current locale settings. On success + zero is returned and SETTINGS is properly initialized. */ +static int +get_current_locale_settings (scm_t_locale_settings *settings) +{ + const char *locale_name; + +#define SCM_DEFINE_LOCALE_CATEGORY(_name) \ + { \ + SCM_SYSCALL (locale_name = setlocale (LC_ ## _name, NULL)); \ + if (!locale_name) \ + goto handle_error; \ + \ + settings-> _name = strdup (locale_name); \ + if (settings-> _name == NULL) \ + goto handle_oom; \ + } + +#include "locale-categories.h" +#undef SCM_DEFINE_LOCALE_CATEGORY + + return 0; + + handle_error: + return errno; + + handle_oom: + return ENOMEM; +} + +/* Restore locale settings SETTINGS. On success, return zero. */ +static int +restore_locale_settings (const scm_t_locale_settings *settings) +{ + const char *result; + +#define SCM_DEFINE_LOCALE_CATEGORY(_name) \ + SCM_SYSCALL (result = setlocale (LC_ ## _name, settings-> _name)); \ + if (result == NULL) \ + goto handle_error; + +#include "locale-categories.h" +#undef SCM_DEFINE_LOCALE_CATEGORY + + return 0; + + handle_error: + return errno; +} + +/* Free memory associated with SETTINGS. */ +static void +free_locale_settings (scm_t_locale_settings *settings) +{ +#define SCM_DEFINE_LOCALE_CATEGORY(_name) \ + free (settings-> _name); \ + settings->_name = NULL; +#include "locale-categories.h" +#undef SCM_DEFINE_LOCALE_CATEGORY +} + +/* Install the locale named LOCALE_NAME for all the categories listed in + CATEGORY_MASK. */ +static int +install_locale_categories (const char *locale_name, int category_mask) +{ + const char *result; + + if (category_mask == LC_ALL_MASK) + { + SCM_SYSCALL (result = setlocale (LC_ALL, locale_name)); + if (result == NULL) + goto handle_error; + } + else + { +#define SCM_DEFINE_LOCALE_CATEGORY(_name) \ + if (category_mask & LC_ ## _name ## _MASK) \ + { \ + SCM_SYSCALL (result = setlocale (LC_ ## _name, locale_name)); \ + if (result == NULL) \ + goto handle_error; \ + } +#include "locale-categories.h" +#undef SCM_DEFINE_LOCALE_CATEGORY + } + + return 0; + + handle_error: + return errno; +} + +/* Install LOCALE, recursively installing its base locales first. On + success, zero is returned. */ +static int +install_locale (scm_t_locale locale) +{ + scm_t_locale stack[LOCALE_STACK_SIZE_MAX]; + size_t stack_size = 0; + int stack_offset = 0; + const char *result = NULL; + + /* Build up a locale stack by traversing the `base_locale' link. */ + do + { + if (stack_size >= LOCALE_STACK_SIZE_MAX) + /* We cannot use `scm_error ()' here because otherwise the locale + mutex may remain locked. */ + return EINVAL; + + stack[stack_size++] = locale; + + if (locale->base_locale != SCM_UNDEFINED) + locale = (scm_t_locale)SCM_SMOB_DATA (locale->base_locale); + else + locale = NULL; + } + while (locale != NULL); + + /* Install the C locale to start from a pristine state. */ + SCM_SYSCALL (result = setlocale (LC_ALL, "C")); + if (result == NULL) + goto handle_error; + + /* Install the locales in reverse order. */ + for (stack_offset = stack_size - 1; + stack_offset >= 0; + stack_offset--) + { + int err; + scm_t_locale locale; + + locale = stack[stack_offset]; + err = install_locale_categories (locale->locale_name, + locale->category_mask); + if (err) + goto handle_error; + } + + return 0; + + handle_error: + return errno; +} + +/* Leave the locked locale section. */ +static inline void +leave_locale_section (const scm_t_locale_settings *settings) +{ + /* Restore the previous locale settings. */ + (void)restore_locale_settings (settings); + + scm_i_pthread_mutex_unlock (&scm_i_locale_mutex); +} + +/* Enter a locked locale section. */ +static inline int +enter_locale_section (scm_t_locale locale, + scm_t_locale_settings *prev_locale) +{ + int err; + + scm_i_pthread_mutex_lock (&scm_i_locale_mutex); + + err = get_current_locale_settings (prev_locale); + if (err) + { + scm_i_pthread_mutex_unlock (&scm_i_locale_mutex); + return err; + } + + err = install_locale (locale); + if (err) + { + leave_locale_section (prev_locale); + free_locale_settings (prev_locale); + } + + 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 \ + { \ + int lsec_err; \ + scm_t_locale_settings lsec_prev_locale; \ + \ + lsec_err = enter_locale_section ((_c_locale), &lsec_prev_locale); \ + if (lsec_err) \ + scm_locale_error (FUNC_NAME, lsec_err); \ + else \ + { \ + _statement ; \ + \ + leave_locale_section (&lsec_prev_locale); \ + free_locale_settings (&lsec_prev_locale); \ + } \ + } \ + while (0) + +#endif /* !USE_GNU_LOCALE_API */ + + +/* Locale-dependent string comparison. */ + +/* Compare null-terminated strings C_S1 and C_S2 according to LOCALE. Return + an integer whose sign is the same as the difference between C_S1 and + C_S2. */ +static inline int +compare_strings (const char *c_s1, const char *c_s2, SCM locale, + const char *func_name) +#define FUNC_NAME func_name +{ + int result; + scm_t_locale c_locale; + + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale); + + if (c_locale) + { +#ifdef USE_GNU_LOCALE_API + result = strcoll_l (c_s1, c_s2, c_locale); +#else +#ifdef HAVE_STRCOLL + RUN_IN_LOCALE_SECTION (c_locale, result = strcoll (c_s1, c_s2)); +#else + result = strcmp (c_s1, c_s2); +#endif +#endif /* !USE_GNU_LOCALE_API */ + } + else + +#ifdef HAVE_STRCOLL + result = strcoll (c_s1, c_s2); +#else + result = strcmp (c_s1, c_s2); +#endif + + return result; +} +#undef FUNC_NAME + +/* Store into DST an upper-case version of SRC. */ +static inline void +str_upcase (register char *dst, register const char *src) +{ + for (; *src != '\0'; src++, dst++) + *dst = toupper (*src); + *dst = '\0'; +} + +static inline void +str_downcase (register char *dst, register const char *src) +{ + for (; *src != '\0'; src++, dst++) + *dst = tolower (*src); + *dst = '\0'; +} + +#ifdef USE_GNU_LOCALE_API +static inline void +str_upcase_l (register char *dst, register const char *src, + scm_t_locale locale) +{ + for (; *src != '\0'; src++, dst++) + *dst = toupper_l (*src, locale); + *dst = '\0'; +} + +static inline void +str_downcase_l (register char *dst, register const char *src, + scm_t_locale locale) +{ + for (; *src != '\0'; src++, dst++) + *dst = tolower_l (*src, locale); + *dst = '\0'; +} +#endif + + +/* Compare null-terminated strings C_S1 and C_S2 in a case-independent way + according to LOCALE. Return an integer whose sign is the same as the + difference between C_S1 and C_S2. */ +static inline int +compare_strings_ci (const char *c_s1, const char *c_s2, SCM locale, + const char *func_name) +#define FUNC_NAME func_name +{ + int result; + scm_t_locale c_locale; + char *c_us1, *c_us2; + + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale); + + c_us1 = (char *) alloca (strlen (c_s1) + 1); + c_us2 = (char *) alloca (strlen (c_s2) + 1); + + if (c_locale) + { +#ifdef USE_GNU_LOCALE_API + str_upcase_l (c_us1, c_s1, c_locale); + str_upcase_l (c_us2, c_s2, c_locale); + + result = strcoll_l (c_us1, c_us2, c_locale); +#else + int err; + scm_t_locale_settings prev_locale; + + err = enter_locale_section (c_locale, &prev_locale); + if (err) + { + scm_locale_error (func_name, err); + return 0; + } + + str_upcase (c_us1, c_s1); + str_upcase (c_us2, c_s2); + +#ifdef HAVE_STRCOLL + result = strcoll (c_us1, c_us2); +#else + result = strcmp (c_us1, c_us2); +#endif /* !HAVE_STRCOLL */ + + leave_locale_section (&prev_locale); + free_locale_settings (&prev_locale); +#endif /* !USE_GNU_LOCALE_API */ + } + else + { + str_upcase (c_us1, c_s1); + str_upcase (c_us2, c_s2); + +#ifdef HAVE_STRCOLL + result = strcoll (c_us1, c_us2); +#else + result = strcmp (c_us1, c_us2); +#endif + } + + return result; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_string_locale_lt, "string-locale?", 2, 1, 0, + (SCM s1, SCM s2, SCM 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.") +#define FUNC_NAME s_scm_string_locale_gt +{ + int result; + const char *c_s1, *c_s2; + + SCM_VALIDATE_STRING (1, s1); + SCM_VALIDATE_STRING (2, s2); + + c_s1 = scm_i_string_chars (s1); + c_s2 = scm_i_string_chars (s2); + + result = compare_strings (c_s1, c_s2, locale, FUNC_NAME); + + scm_remember_upto_here_2 (s1, s2); + + return scm_from_bool (result > 0); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_locale_ci_lt, "string-locale-ci?", 2, 1, 0, + (SCM s1, SCM s2, SCM 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.") +#define FUNC_NAME s_scm_string_locale_ci_gt +{ + int result; + const char *c_s1, *c_s2; + + SCM_VALIDATE_STRING (1, s1); + SCM_VALIDATE_STRING (2, s2); + + c_s1 = scm_i_string_chars (s1); + c_s2 = scm_i_string_chars (s2); + + result = compare_strings_ci (c_s1, c_s2, locale, FUNC_NAME); + + scm_remember_upto_here_2 (s1, s2); + + return scm_from_bool (result > 0); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_locale_ci_eq, "string-locale-ci=?", 2, 1, 0, + (SCM s1, SCM s2, SCM 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.") +#define FUNC_NAME s_scm_string_locale_ci_eq +{ + int result; + const char *c_s1, *c_s2; + + SCM_VALIDATE_STRING (1, s1); + SCM_VALIDATE_STRING (2, s2); + + c_s1 = scm_i_string_chars (s1); + c_s2 = scm_i_string_chars (s2); + + result = compare_strings_ci (c_s1, c_s2, locale, FUNC_NAME); + + scm_remember_upto_here_2 (s1, s2); + + return scm_from_bool (result == 0); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_char_locale_lt, "char-locale?", 2, 1, 0, + (SCM c1, SCM c2, SCM locale), + "Return true if character @var{c1} is greater than @var{c2} " + "according to @var{locale} or to the current locale.") +#define FUNC_NAME s_scm_char_locale_gt +{ + char c_c1[2], c_c2[2]; + + SCM_VALIDATE_CHAR (1, c1); + SCM_VALIDATE_CHAR (2, c2); + + c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0'; + c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0'; + + return scm_from_bool (compare_strings (c_c1, c_c2, locale, FUNC_NAME) > 0); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_char_locale_ci_lt, "char-locale-ci?", 2, 1, 0, + (SCM c1, SCM c2, SCM 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.") +#define FUNC_NAME s_scm_char_locale_ci_gt +{ + int result; + char c_c1[2], c_c2[2]; + + SCM_VALIDATE_CHAR (1, c1); + SCM_VALIDATE_CHAR (2, c2); + + c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0'; + c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0'; + + result = compare_strings_ci (c_c1, c_c2, locale, FUNC_NAME); + + return scm_from_bool (result > 0); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_char_locale_ci_eq, "char-locale-ci=?", 2, 1, 0, + (SCM c1, SCM c2, SCM locale), + "Return true if character @var{c1} is equal to @var{c2}, " + "in a case insensitive way according to @var{locale} or to " + "the current locale.") +#define FUNC_NAME s_scm_char_locale_ci_eq +{ + int result; + char c_c1[2], c_c2[2]; + + SCM_VALIDATE_CHAR (1, c1); + SCM_VALIDATE_CHAR (2, c2); + + c_c1[0] = (char)SCM_CHAR (c1); c_c1[1] = '\0'; + c_c2[0] = (char)SCM_CHAR (c2); c_c2[1] = '\0'; + + result = compare_strings_ci (c_c1, c_c2, locale, FUNC_NAME); + + return scm_from_bool (result == 0); +} +#undef FUNC_NAME + + + +/* Locale-dependent alphabetic character mapping. */ + +SCM_DEFINE (scm_char_locale_downcase, "char-locale-downcase", 1, 1, 0, + (SCM chr, SCM locale), + "Return the lowercase character that corresponds to @var{chr} " + "according to either @var{locale} or the current locale.") +#define FUNC_NAME s_scm_char_locale_downcase +{ + char c_chr; + int c_result; + scm_t_locale c_locale; + + SCM_VALIDATE_CHAR (1, chr); + c_chr = SCM_CHAR (chr); + + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale); + + if (c_locale != NULL) + { +#ifdef USE_GNU_LOCALE_API + c_result = tolower_l (c_chr, c_locale); +#else + RUN_IN_LOCALE_SECTION (c_locale, c_result = tolower (c_chr)); +#endif + } + else + c_result = tolower (c_chr); + + return (SCM_MAKE_CHAR (c_result)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_char_locale_upcase, "char-locale-upcase", 1, 1, 0, + (SCM chr, SCM locale), + "Return the uppercase character that corresponds to @var{chr} " + "according to either @var{locale} or the current locale.") +#define FUNC_NAME s_scm_char_locale_upcase +{ + char c_chr; + int c_result; + scm_t_locale c_locale; + + SCM_VALIDATE_CHAR (1, chr); + c_chr = SCM_CHAR (chr); + + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale); + + if (c_locale != NULL) + { +#ifdef USE_GNU_LOCALE_API + c_result = toupper_l (c_chr, c_locale); +#else + RUN_IN_LOCALE_SECTION (c_locale, c_result = toupper (c_chr)); +#endif + } + else + c_result = toupper (c_chr); + + return (SCM_MAKE_CHAR (c_result)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_locale_upcase, "string-locale-upcase", 1, 1, 0, + (SCM str, SCM locale), + "Return a new string that is the uppercase version of " + "@var{str} according to either @var{locale} or the current " + "locale.") +#define FUNC_NAME s_scm_string_locale_upcase +{ + const char *c_str; + char *c_ustr; + scm_t_locale c_locale; + + SCM_VALIDATE_STRING (1, str); + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale); + + c_str = scm_i_string_chars (str); + c_ustr = (char *) alloca (strlen (c_str) + 1); + + if (c_locale) + { +#ifdef USE_GNU_LOCALE_API + str_upcase_l (c_ustr, c_str, c_locale); +#else + RUN_IN_LOCALE_SECTION (c_locale, str_upcase (c_ustr, c_str)); +#endif + } + else + str_upcase (c_ustr, c_str); + + scm_remember_upto_here (str); + + return (scm_from_locale_string (c_ustr)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_string_locale_downcase, "string-locale-downcase", 1, 1, 0, + (SCM str, SCM locale), + "Return a new string that is the down-case version of " + "@var{str} according to either @var{locale} or the current " + "locale.") +#define FUNC_NAME s_scm_string_locale_downcase +{ + const char *c_str; + char *c_lstr; + scm_t_locale c_locale; + + SCM_VALIDATE_STRING (1, str); + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale); + + c_str = scm_i_string_chars (str); + c_lstr = (char *) alloca (strlen (c_str) + 1); + + if (c_locale) + { +#ifdef USE_GNU_LOCALE_API + str_downcase_l (c_lstr, c_str, c_locale); +#else + RUN_IN_LOCALE_SECTION (c_locale, str_downcase (c_lstr, c_str)); +#endif + } + else + str_downcase (c_lstr, c_str); + + scm_remember_upto_here (str); + + return (scm_from_locale_string (c_lstr)); +} +#undef FUNC_NAME + +/* Note: We don't provide mutative versions of `string-locale-(up|down)case' + because, in some languages, a single downcase character maps to a couple + of uppercase characters. Read the SRFI-13 document for a detailed + discussion about this. */ + + + +/* Locale-dependent number parsing. */ + +SCM_DEFINE (scm_locale_string_to_integer, "locale-string->integer", + 1, 2, 0, (SCM str, SCM base, SCM locale), + "Convert string @var{str} into an integer according to either " + "@var{locale} (a locale object as returned by @code{make-locale}) " + "or the current process locale. Return two values: an integer " + "(on success) or @code{#f}, and the number of characters read " + "from @var{str} (@code{0} on failure).") +#define FUNC_NAME s_scm_locale_string_to_integer +{ + SCM result; + long c_result; + int c_base; + const char *c_str; + char *c_endptr; + scm_t_locale c_locale; + + SCM_VALIDATE_STRING (1, str); + c_str = scm_i_string_chars (str); + + if (base != SCM_UNDEFINED) + SCM_VALIDATE_INT_COPY (2, base, c_base); + else + c_base = 10; + + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (3, locale, c_locale); + + if (c_locale != NULL) + { +#ifdef USE_GNU_LOCALE_API + c_result = strtol_l (c_str, &c_endptr, c_base, c_locale); +#else + RUN_IN_LOCALE_SECTION (c_locale, + c_result = strtol (c_str, &c_endptr, c_base)); +#endif + } + else + c_result = strtol (c_str, &c_endptr, c_base); + + scm_remember_upto_here (str); + + if (c_endptr == c_str) + result = SCM_BOOL_F; + else + result = scm_from_long (c_result); + + return (scm_values (scm_list_2 (result, scm_from_long (c_endptr - c_str)))); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_locale_string_to_inexact, "locale-string->inexact", + 1, 1, 0, (SCM str, SCM 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).") +#define FUNC_NAME s_scm_locale_string_to_inexact +{ + SCM result; + double c_result; + const char *c_str; + char *c_endptr; + scm_t_locale c_locale; + + SCM_VALIDATE_STRING (1, str); + c_str = scm_i_string_chars (str); + + SCM_VALIDATE_OPTIONAL_LOCALE_COPY (2, locale, c_locale); + + if (c_locale != NULL) + { +#ifdef USE_GNU_LOCALE_API + c_result = strtod_l (c_str, &c_endptr, c_locale); +#else + RUN_IN_LOCALE_SECTION (c_locale, + c_result = strtod (c_str, &c_endptr)); +#endif + } + else + c_result = strtod (c_str, &c_endptr); + + scm_remember_upto_here (str); + + if (c_endptr == c_str) + result = SCM_BOOL_F; + else + result = scm_from_double (c_result); + + return (scm_values (scm_list_2 (result, scm_from_long (c_endptr - c_str)))); +} +#undef FUNC_NAME + + + +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) + + /* Define all the relevant `_MASK' variables. */ +#define SCM_DEFINE_LOCALE_CATEGORY(_name) \ + scm_c_define ("LC_" SCM_STRINGIFY_LC (_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)); + +#include "libguile/i18n.x" + +#ifndef USE_GNU_LOCALE_API + scm_set_smob_mark (scm_tc16_locale_smob_type, smob_locale_mark); +#endif +} + + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ --- /dev/null +++ mod/libguile/i18n.h @@ -0,0 +1,52 @@ +/* classes: h_files */ + +#ifndef SCM_I18N_H +#define SCM_I18N_H + +/* Copyright (C) 2006 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ + +#include "libguile/__scm.h" + +SCM_API SCM scm_make_locale (SCM category_mask, SCM locale_name, SCM base_locale); +SCM_API SCM scm_locale_p (SCM obj); +SCM_API SCM scm_string_locale_lt (SCM s1, SCM s2, SCM locale); +SCM_API SCM scm_string_locale_gt (SCM s1, SCM s2, SCM locale); +SCM_API SCM scm_string_locale_ci_lt (SCM s1, SCM s2, SCM locale); +SCM_API SCM scm_string_locale_ci_gt (SCM s1, SCM s2, SCM locale); +SCM_API SCM scm_string_locale_ci_eq (SCM s1, SCM s2, SCM locale); +SCM_API SCM scm_char_locale_lt (SCM c1, SCM c2, SCM locale); +SCM_API SCM scm_char_locale_gt (SCM c1, SCM c2, SCM locale); +SCM_API SCM scm_char_locale_ci_lt (SCM c1, SCM c2, SCM locale); +SCM_API SCM scm_char_locale_ci_gt (SCM c1, SCM c2, SCM locale); +SCM_API SCM scm_char_locale_ci_eq (SCM c1, SCM c2, SCM locale); +SCM_API SCM scm_char_locale_upcase (SCM chr, SCM locale); +SCM_API SCM scm_char_locale_downcase (SCM chr, SCM locale); +SCM_API SCM scm_string_locale_upcase (SCM chr, SCM locale); +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 void scm_init_i18n (void); + +#endif /* SCM_I18N_H */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ --- /dev/null +++ mod/libguile/locale-categories.h @@ -0,0 +1,47 @@ +/* Copyright (C) 2006 Free Software Foundation, Inc. + * + * This library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Lesser General Public + * License as published by the Free Software Foundation; either + * version 2.1 of the License, or (at your option) any later version. + * + * This library is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + * Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public + * License along with this library; if not, write to the Free Software + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + */ + +/* A list of all available locale categories, not including `ALL'. */ + + +/* The six standard categories, as defined in IEEE Std 1003.1-2001. */ +SCM_DEFINE_LOCALE_CATEGORY (COLLATE) +SCM_DEFINE_LOCALE_CATEGORY (CTYPE) +SCM_DEFINE_LOCALE_CATEGORY (MESSAGES) +SCM_DEFINE_LOCALE_CATEGORY (MONETARY) +SCM_DEFINE_LOCALE_CATEGORY (NUMERIC) +SCM_DEFINE_LOCALE_CATEGORY (TIME) + +/* Additional non-standard categories. */ +#ifdef LC_PAPER +SCM_DEFINE_LOCALE_CATEGORY (PAPER) +#endif +#ifdef LC_NAME +SCM_DEFINE_LOCALE_CATEGORY (NAME) +#endif +#ifdef LC_ADDRESS +SCM_DEFINE_LOCALE_CATEGORY (ADDRESS) +#endif +#ifdef LC_TELEPHONE +SCM_DEFINE_LOCALE_CATEGORY (TELEPHONE) +#endif +#ifdef LC_MEASUREMENT +SCM_DEFINE_LOCALE_CATEGORY (MEASUREMENT) +#endif +#ifdef LC_IDENTIFICATION +SCM_DEFINE_LOCALE_CATEGORY (IDENTIFICATION) +#endif --- /dev/null +++ mod/test-suite/tests/.arch-ids/i18n.test.id @@ -0,0 +1 @@ +Ludovic Courtes Thu Oct 19 01:46:26 2006 25287.0 --- /dev/null +++ mod/test-suite/tests/i18n.test @@ -0,0 +1,143 @@ +;;;; i18n.test --- Exercise the i18n API. +;;;; +;;;; Copyright (C) 2006 Free Software Foundation, Inc. +;;;; Ludovic Courtès +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 2.1 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-suite i18n) + :use-module (ice-9 i18n) + :use-module (test-suite lib)) + +;; Start from a pristine locale state. +(setlocale LC_ALL "C") + + +(with-test-prefix "locale objects" + + (pass-if "make-locale (2 args)" + (not (not (make-locale LC_ALL_MASK "C")))) + + (pass-if "make-locale (3 args)" + (not (not (make-locale LC_COLLATE_MASK "C" + (make-locale LC_MESSAGES_MASK "C"))))) + + (pass-if "locale?" + (and (locale? (make-locale LC_ALL_MASK "C")) + (locale? (make-locale (logior LC_MESSAGES_MASK LC_NUMERIC_MASK) "C" + (make-locale LC_CTYPE_MASK "C")))))) + + + +(with-test-prefix "text collation (English)" + + (pass-if "string-locale?" + (under-french-locale-or-unresolved + (lambda () + (and (string-locale-ci? "HiVeR" "été" %french-locale))))) + + (pass-if "char-locale-ci<>?" + (under-french-locale-or-unresolved + (lambda () + (and (char-locale-ci? #\h #\É %french-locale)))))) + + +(with-test-prefix "character mapping" + + (pass-if "char-locale-downcase" + (and (eq? #\a (char-locale-downcase #\A)) + (eq? #\a (char-locale-downcase #\A (make-locale LC_ALL_MASK "C"))))) + + (pass-if "char-locale-upcase" + (and (eq? #\Z (char-locale-upcase #\z)) + (eq? #\Z (char-locale-upcase #\z (make-locale LC_ALL_MASK "C")))))) + + +(with-test-prefix "number parsing" + + (pass-if "locale-string->integer" + (call-with-values (lambda () (locale-string->integer "123")) + (lambda (result char-count) + (and (equal? result 123) + (equal? char-count 3))))) + + (pass-if "locale-string->inexact" + (call-with-values + (lambda () + (locale-string->inexact "123.456" + (make-locale LC_NUMERIC_MASK "C"))) + (lambda (result char-count) + (and (equal? result 123.456) + (equal? char-count 7)))))) + + +;;; Local Variables: +;;; coding: latin-1 +;;; mode: scheme +;;; End: